From 9c589a97467de57f09b0fb01196774bbf5c5343a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 27 Apr 2022 20:28:33 +0200 Subject: [PATCH 001/164] Model of the algorithm for universe checking inspired by Bezem et al Terminating but incorrect loop check Improved version, whose termination relies on the correctness of check_model Move back to template-coq folder Improve the algorithm after discussion with Marc Bezem Comment a bit Try enforcing new constraints Reorganize inner loop Cleaner inner_loop Finished inner loop Inner loop termination proven Before change of v_minus_w_bound Prove the well-foundedness of loop Inner loop termination proof finished Finished all proofs Finish proofs of auxilliary lemmas Finished all proofs with new invariants Comments and extraction setup Abstract LoopChecking on level / sets / maps implementation Move clauses.v to LoopChecking and TemplateLoopChecking Functorize the algorithm Simplified loops Cleaned up LoopChecking and TemplateLoopChecking Support correct quoting/unquoting of the universe graph/context. Also rename Constraint to LevelConstraint, preparing for a later move to general universe constraints Add a new (extracted) plugin to test the loop checking algorithm. Move back to subst_instance_cstr for level constraints Move live tests of loop_checking to the test-suite Revert changes to Universes.v Avoid repeateadly folding over clauses in inner loop Optimize a bit loop checking to avoid partitioning clause repeatedly Fix UnivConstraint -> LevelConstraint change Remove useless extraction file in template-coq MSetList is no longer needed --- .gitignore | 4 + .vscode/metarocq.code-workspace | 1 + common/theories/EnvironmentTyping.v | 2 +- common/theories/Reflect.v | 50 +- common/theories/Universes.v | 471 ++- common/theories/uGraph.v | 4 +- .../Conversion/PCUICUnivSubstitutionConv.v | 2 +- template-rocq/_PluginProject.in | 6 +- template-rocq/_RocqProject.in | 4 + template-rocq/src/ast_denoter.ml | 2 +- template-rocq/src/ast_quoter.ml | 2 +- template-rocq/src/plugin_core.ml | 6 +- template-rocq/src/plugin_core.mli | 2 +- template-rocq/src/quoter.ml | 30 +- template-rocq/src/run_extractable.ml | 12 +- template-rocq/src/tm_util.ml | 33 + template-rocq/theories/Constants.v | 2 +- template-rocq/theories/ExtractLoopChecking.v | 17 + template-rocq/theories/LoopChecking.v | 2823 +++++++++++++++++ template-rocq/theories/TemplateLoopChecking.v | 101 + template-rocq/theories/TemplateMonad/Common.v | 2 +- template-rocq/theories/TemplateMonad/Core.v | 2 +- .../theories/TemplateMonad/Extractable.v | 2 +- test-suite/loop-checking/.gitignore | 7 + test-suite/loop-checking/Makefile | 26 + .../loop-checking/Makefile.plugin.local | 10 + test-suite/loop-checking/README.md | 16 + test-suite/loop-checking/_CoqProject | 9 + test-suite/loop-checking/_PluginProject | 20 + test-suite/loop-checking/gen-src/to-lower.sh | 10 + .../src/g_metacoq_loop_checking_plugin.mlg | 11 + .../src/metacoq_loop_checking_plugin.mlpack | 4 + test-suite/loop-checking/test/test.v | 7 + .../loop-checking/theories/Extraction.v | 13 + test-suite/loop-checking/theories/Loader.v | 2 + .../theories/LoopCheckingPlugin.v | 28 + .../loop-checking/theories/all_stdlib.v | 559 ++++ .../theories/loop_checking_live_test.v | 353 +++ utils/theories/MRProd.v | 25 +- utils/theories/bytestring.v | 6 + 40 files changed, 4516 insertions(+), 170 deletions(-) create mode 100644 template-rocq/theories/ExtractLoopChecking.v create mode 100644 template-rocq/theories/LoopChecking.v create mode 100644 template-rocq/theories/TemplateLoopChecking.v create mode 100644 test-suite/loop-checking/.gitignore create mode 100644 test-suite/loop-checking/Makefile create mode 100644 test-suite/loop-checking/Makefile.plugin.local create mode 100644 test-suite/loop-checking/README.md create mode 100644 test-suite/loop-checking/_CoqProject create mode 100644 test-suite/loop-checking/_PluginProject create mode 100755 test-suite/loop-checking/gen-src/to-lower.sh create mode 100644 test-suite/loop-checking/src/g_metacoq_loop_checking_plugin.mlg create mode 100644 test-suite/loop-checking/src/metacoq_loop_checking_plugin.mlpack create mode 100644 test-suite/loop-checking/test/test.v create mode 100644 test-suite/loop-checking/theories/Extraction.v create mode 100644 test-suite/loop-checking/theories/Loader.v create mode 100644 test-suite/loop-checking/theories/LoopCheckingPlugin.v create mode 100644 test-suite/loop-checking/theories/all_stdlib.v create mode 100644 test-suite/loop-checking/theories/loop_checking_live_test.v diff --git a/.gitignore b/.gitignore index 17f5c2b7e..2ede99286 100644 --- a/.gitignore +++ b/.gitignore @@ -413,3 +413,7 @@ template-rocq/_TemplateRocqProject .gitignore template-rocq/_PluginProject template-rocq/_RocqProject +template-coq/extraction_clauses/clauses.ml +template-coq/extraction_clauses/clauses.mli +template-coq/extraction_clauses/loop_checking.mli +template-coq/extraction_clauses/loop_checking.ml diff --git a/.vscode/metarocq.code-workspace b/.vscode/metarocq.code-workspace index 35433b164..0398c8308 100644 --- a/.vscode/metarocq.code-workspace +++ b/.vscode/metarocq.code-workspace @@ -35,6 +35,7 @@ "-R", "examples", "MetaRocq.Examples", ], "vscoq.args": [ + // "-bt", // get backtraces from Rocq on errors "-R", "utils/theories", "MetaRocq.Utils", "-R", "common/theories", "MetaRocq.Common", diff --git a/common/theories/EnvironmentTyping.v b/common/theories/EnvironmentTyping.v index 385f66397..ea368eaf4 100644 --- a/common/theories/EnvironmentTyping.v +++ b/common/theories/EnvironmentTyping.v @@ -288,7 +288,7 @@ Module Lookup (T : Term) (E : EnvironmentSig T). Definition wf_universe_dec Σ u : {wf_universe Σ u} + {~wf_universe Σ u}. Proof. - cbv [wf_universe LevelExprSet.In LevelExprSet.this t_set]. + cbv [wf_universe LevelExprSet.In LevelExprSet.this LevelExprSet.t_set]. destruct u as [[t _] _]. induction t as [|t ts [IHt|IHt]]; [ left | | right ]. { inversion 1. } diff --git a/common/theories/Reflect.v b/common/theories/Reflect.v index 9a612fb0e..398c17601 100644 --- a/common/theories/Reflect.v +++ b/common/theories/Reflect.v @@ -223,7 +223,9 @@ Next Obligation. Qed. Scheme level_lt_ind_dep := Induction for Level.lt_ Sort Prop. +Scheme level_expr_lt_ind_dep := Induction for LevelExpr.lt_ Sort Prop. Scheme constraint_type_lt_ind_dep := Induction for ConstraintType.lt_ Sort Prop. +Scheme level_constraint_lt_ind_dep := Induction for LevelConstraint.lt_ Sort Prop. Scheme constraint_lt_ind_dep := Induction for UnivConstraint.lt_ Sort Prop. Derive Signature for UnivConstraint.lt_. Derive Signature for le. @@ -254,6 +256,33 @@ Proof. - f_equal. apply nat_le_irrel. Qed. +Lemma lt_levelexpr_irrel {x y : LevelExpr.t} (l l' : LevelExpr.lt_ x y) : l = l'. +Proof. + induction l using level_expr_lt_ind_dep. + - depelim l'; auto. + * now replace l0 with l2 by now apply nat_le_irrel. + * exfalso. now eapply RelationClasses.irreflexivity in l2. + - depelim l'; auto. + * exfalso. now eapply RelationClasses.irreflexivity in l0. + * now replace l0 with l2 by now apply lt_level_irrel. +Qed. + +From Coq Require Import ProofIrrelevance. + +Lemma lt_universe_irrel {x y : Universe.t} (l l' : LevelExprSet.lt x y) : l = l'. +Proof. + apply ProofIrrelevance.proof_irrelevance. +Qed. + (* destruct l. + induction l using level_expr_set_lt_ind_dep. + - depelim l'; auto. + * now replace l0 with l2 by now apply nat_le_irrel. + * exfalso. now eapply RelationClasses.irreflexivity in l2. + - depelim l'; auto. + * exfalso. now eapply RelationClasses.irreflexivity in l0. + * now replace l0 with l2 by now apply lt_level_irrel. +Qed. *) + Lemma constraint_type_lt_level_irrel {x y} (l l' : ConstraintType.lt_ x y) : l = l'. Proof. induction l using constraint_type_lt_ind_dep; depelim l'; auto. @@ -265,6 +294,23 @@ From Stdlib Require Import RelationClasses. Lemma constraint_lt_irrel (x y : UnivConstraint.t) (l l' : UnivConstraint.lt_ x y) : l = l'. Proof. revert l'. induction l using constraint_lt_ind_dep. + - intros l'. depelim l'. f_equal. + apply lt_universe_irrel. + now elim (irreflexivity (R:=ConstraintType.lt) l4). + now elim (irreflexivity l4). + - intros l'; depelim l'. + now elim (irreflexivity (R:=ConstraintType.lt) l). + now rewrite (constraint_type_lt_level_irrel l l4). + now elim (irreflexivity l4). + - intros l'; depelim l'. + now elim (irreflexivity l). + now elim (irreflexivity l). + now rewrite (lt_universe_irrel l l4). +Qed. + +Lemma levelconstraint_lt_irrel (x y : LevelConstraint.t) (l l' : LevelConstraint.lt_ x y) : l = l'. +Proof. + revert l'. induction l using level_constraint_lt_ind_dep. - intros l'. depelim l'. now rewrite (lt_level_irrel l l4). now elim (irreflexivity (R:=ConstraintType.lt) l4). @@ -372,9 +418,9 @@ Module ConstraintSetsUIP. - depelim o'. f_equal; auto. clear -l0 l2. red in l0, l2. extensionality y. extensionality inl. - apply constraint_lt_irrel. + apply levelconstraint_lt_irrel. extensionality y. extensionality inl. - apply constraint_lt_irrel. + apply levelconstraint_lt_irrel. Qed. #[global,program] Instance reflect_ConstraintSet : ReflectEq ConstraintSet.t := diff --git a/common/theories/Universes.v b/common/theories/Universes.v index a11af0a6e..70e6a677f 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -252,7 +252,9 @@ Module LevelExpr. Global Instance Evaluable : Evaluable t := fun v l => (snd l + val v (fst l)). - Definition succ (l : t) := (fst l, S (snd l)). + Definition succ (l : t) : t := (fst l, S (snd l)). + + Definition add (k : nat) (l : t) : t := (fst l, k + snd l). Definition get_level (e : t) : Level.t := fst e. @@ -276,7 +278,7 @@ Module LevelExpr. Inductive lt_ : t -> t -> Prop := | ltLevelExpr1 l n n' : (n < n')%nat -> lt_ (l, n) (l, n') | ltLevelExpr2 l l' b b' : Level.lt l l' -> lt_ (l, b) (l', b'). - + Derive Signature for lt_. Definition lt := lt_. Global Instance lt_strorder : StrictOrder lt. @@ -331,7 +333,18 @@ Module LevelExpr. End LevelExpr. -Module LevelExprSet := MSetList.MakeWithLeibniz LevelExpr. +Module LevelExprSet. + Include MSetList.MakeWithLeibniz LevelExpr. + + Definition levels (e : t) := + fold (fun le => LevelSet.add (LevelExpr.get_level le)) e LevelSet.empty. + + Record nonEmptyLevelExprSet + := { t_set : LevelExprSet.t ; + t_ne : LevelExprSet.is_empty t_set = false }. + +End LevelExprSet. + Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. Module LevelExprSetOrdProp := MSetProperties.OrdProperties LevelExprSet. Module LevelExprSetProp := LevelExprSetOrdProp.P. @@ -354,11 +367,7 @@ Qed. #[global] Instance levelexprset_eq_dec : Classes.EqDec LevelExprSet.t := Classes.eq_dec. - - -Record nonEmptyLevelExprSet - := { t_set : LevelExprSet.t ; - t_ne : LevelExprSet.is_empty t_set = false }. +Import LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). Derive NoConfusion for nonEmptyLevelExprSet. @@ -632,12 +641,13 @@ Module Universe. Definition is_level (u : t) : bool := (LevelExprSet.cardinal u =? 1)%nat && is_levels u. - (* Used for quoting. *) + Definition succ : t -> t := map LevelExpr.succ. + + Definition add (k : nat) : t -> t := map (LevelExpr.add k). + Definition from_kernel_repr (e : Level.t * nat) (es : list (Level.t * nat)) : t := add_list es (Universe.make e). - Definition succ : t -> t := map LevelExpr.succ. - (** The l.u.b. of 2 non-prop universe sets *) Definition sup : t -> t -> t := non_empty_union. @@ -663,6 +673,9 @@ Module Universe. { intros ? H. apply irreflexivity in H; assumption. } { intros ??? H1 H2; etransitivity; tea. } Qed. + + + End Universe. Ltac u := @@ -892,6 +905,81 @@ Module ConstraintType. End ConstraintType. Module UnivConstraint. + Definition t : Type := Universe.t * ConstraintType.t * Universe.t. + + Definition eq : t -> t -> Prop := eq. + Definition eq_equiv : Equivalence eq := _. + + Definition make l1 ct l2 : t := (l1, ct, l2). + + Inductive lt_ : t -> t -> Prop := + | lt_Level2 l1 t (l2 l2' : Universe.t) : LevelExprSet.lt l2 l2' -> lt_ (l1, t, l2) (l1, t, l2') + | lt_Cstr l1 t t' l2 l2' : ConstraintType.lt t t' -> lt_ (l1, t, l2) (l1, t', l2') + | lt_Level1 (l1 l1' : Universe.t) t t' l2 l2' : LevelExprSet.lt l1 l1' -> lt_ (l1, t, l2) (l1', t', l2'). + Derive Signature for lt_. + Definition lt := lt_. + + Lemma lt_strorder : StrictOrder lt. + Proof. + constructor. + - intros []; intro X; inversion X; subst; + try (eapply LevelExprSet.lt_strorder; eassumption). + eapply ConstraintType.lt_strorder; eassumption. + - intros ? ? ? X Y; invs X; invs Y; constructor; tea. + etransitivity; eassumption. + 2: etransitivity; eassumption. + eapply ConstraintType.lt_strorder; eassumption. + Qed. + + Lemma lt_compat : Proper (eq ==> eq ==> iff) lt. + Proof. + intros ? ? X ? ? Y; invs X; invs Y. reflexivity. + Qed. + + Definition compare : t -> t -> comparison := + fun '(l1, t, l2) '(l1', t', l2') => + compare_cont (LevelExprSet.compare l1 l1') + (compare_cont (ConstraintType.compare t t') + (LevelExprSet.compare l2 l2')). + + Lemma universe_eq (x y : Universe.t) : t_set x = t_set y -> x = y. + Proof. + destruct x, y; cbn. intros ->. + now eapply NonEmptySetFacts.eq_univ; cbn. + Qed. + + Lemma compare_spec x y + : CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). + Proof. + destruct x as [[l1 t] l2], y as [[l1' t'] l2']; cbn. + destruct (LevelExprSet.compare_spec l1 l1'); cbn; repeat constructor; tas. + eapply LevelExprSet.eq_leibniz, universe_eq in H. subst l1'. + destruct (ConstraintType.compare_spec t t'); cbn; repeat constructor; tas. + invs H. + destruct (LevelExprSet.compare_spec l2 l2'); cbn; repeat constructor; tas. + eapply LevelExprSet.eq_leibniz, universe_eq in H. now subst l2'. + Qed. + + Lemma eq_dec x y : {eq x y} + {~ eq x y}. + Proof. + unfold eq. decide equality; apply eq_dec. + Defined. + + Definition eq_leibniz (x y : t) : eq x y -> x = y := id. +End UnivConstraint. + +Module UnivConstraintSet := MSetAVL.Make UnivConstraint. +Module UnivConstraintSetFact := WFactsOn UnivConstraint UnivConstraintSet. +Module UnivConstraintSetOrdProp := MSetProperties.OrdProperties UnivConstraintSet. +Module UnivConstraintSetProp := UnivConstraintSetOrdProp.P. +(* Module CS := UnivConstraintSet. *) +Module UnivConstraintSetDecide := UnivConstraintSetProp.Dec. +Module UnivConstraintSetExtraOrdProp := MSets.ExtraOrdProperties UnivConstraintSet UnivConstraintSetOrdProp. +Module UnivConstraintSetExtraDecide := MSetAVL.Decide UnivConstraint UnivConstraintSet. +(* Ltac csets := UnivConstraintSetDecide.fsetdec. *) +Ltac ucsets := UnivConstraintSetDecide.fsetdec. + +Module LevelConstraint. Definition t : Set := Level.t * ConstraintType.t * Level.t. Definition eq : t -> t -> Prop := eq. @@ -903,6 +991,7 @@ Module UnivConstraint. | lt_Level2 l1 t l2 l2' : Level.lt l2 l2' -> lt_ (l1, t, l2) (l1, t, l2') | lt_Cstr l1 t t' l2 l2' : ConstraintType.lt t t' -> lt_ (l1, t, l2) (l1, t', l2') | lt_Level1 l1 l1' t t' l2 l2' : Level.lt l1 l1' -> lt_ (l1, t, l2) (l1', t', l2'). + Derive Signature for lt_. Definition lt := lt_. Lemma lt_strorder : StrictOrder lt. @@ -946,16 +1035,13 @@ Module UnivConstraint. Defined. Definition eq_leibniz (x y : t) : eq x y -> x = y := id. -End UnivConstraint. +End LevelConstraint. -Module ConstraintSet := MSetAVL.Make UnivConstraint. -Module ConstraintSetFact := WFactsOn UnivConstraint ConstraintSet. -Module ConstraintSetOrdProp := MSetProperties.OrdProperties ConstraintSet. -Module ConstraintSetProp := ConstraintSetOrdProp.P. +Module ConstraintSet := MSetAVL.Make LevelConstraint. +Module ConstraintSetFact := WFactsOn LevelConstraint ConstraintSet. +Module ConstraintSetProp := WPropertiesOn LevelConstraint ConstraintSet. Module CS := ConstraintSet. -Module ConstraintSetDecide := ConstraintSetProp.Dec. -Module ConstraintSetExtraOrdProp := MSets.ExtraOrdProperties ConstraintSet ConstraintSetOrdProp. -Module ConstraintSetExtraDecide := MSetAVL.Decide UnivConstraint ConstraintSet. +Module ConstraintSetDecide := WDecide (ConstraintSet). Ltac csets := ConstraintSetDecide.fsetdec. Notation "(=_cset)" := ConstraintSet.Equal (at level 0). @@ -963,14 +1049,22 @@ Infix "=_cset" := ConstraintSet.Equal (at level 30). Notation "(==_cset)" := ConstraintSet.equal (at level 0). Infix "==_cset" := ConstraintSet.equal (at level 30). -Definition declared_cstr_levels levels (cstr : UnivConstraint.t) := +Definition declared_cstr_levels levels (cstr : LevelConstraint.t) := let '(l1,_,l2) := cstr in LevelSet.In l1 levels /\ LevelSet.In l2 levels. -Definition is_declared_cstr_levels levels (cstr : UnivConstraint.t) : bool := +Definition is_declared_cstr_levels levels (cstr : LevelConstraint.t) : bool := let '(l1,_,l2) := cstr in LevelSet.mem l1 levels && LevelSet.mem l2 levels. +Definition declared_univ_cstr_levels levels (cstr : UnivConstraint.t) := + let '(l1,_,l2) := cstr in + LevelSet.Subset (LevelExprSet.levels l1) levels /\ LevelSet.Subset (LevelExprSet.levels l2) levels. + +Definition is_declared_univ_cstr_levels levels (cstr : UnivConstraint.t) : bool := + let '(l1,_,l2) := cstr in + LevelSet.subset (LevelExprSet.levels l1) levels && LevelSet.subset (LevelExprSet.levels l2) levels. + Lemma CS_union_empty s : ConstraintSet.union ConstraintSet.empty s =_cset s. Proof. intros x; rewrite ConstraintSet.union_spec. lsets. @@ -1195,106 +1289,219 @@ Definition constraints_of_udecl u := Declare Scope univ_scope. Delimit Scope univ_scope with u. -Inductive satisfies0 (v : valuation) : UnivConstraint.t -> Prop := -| satisfies0_Lt (l l' : Level.t) (z : Z) : (Z.of_nat (val v l) <= Z.of_nat (val v l') - z)%Z - -> satisfies0 v (l, ConstraintType.Le z, l') -| satisfies0_Eq (l l' : Level.t) : val v l = val v l' - -> satisfies0 v (l, ConstraintType.Eq, l'). +Section Univ. + Context {cf: checker_flags}. -Definition satisfies v : ConstraintSet.t -> Prop := - ConstraintSet.For_all (satisfies0 v). + Inductive satisfies0 (v : valuation) : LevelConstraint.t -> Prop := + | satisfies0_Lt (l l' : Level.t) (z : Z) : (Z.of_nat (val v l) <= Z.of_nat (val v l') - z)%Z + -> satisfies0 v (l, ConstraintType.Le z, l') + | satisfies0_Eq (l l' : Level.t) : val v l = val v l' + -> satisfies0 v (l, ConstraintType.Eq, l'). -Lemma satisfies_union v φ1 φ2 : - satisfies v (CS.union φ1 φ2) - <-> (satisfies v φ1 /\ satisfies v φ2). -Proof using Type. - unfold satisfies. split. - - intros H; split; intros c Hc; apply H; now apply CS.union_spec. - - intros [H1 H2] c Hc; apply CS.union_spec in Hc; destruct Hc; auto. -Qed. + Definition satisfies v : ConstraintSet.t -> Prop := + ConstraintSet.For_all (satisfies0 v). -Lemma satisfies_subset φ φ' val : - ConstraintSet.Subset φ φ' -> - satisfies val φ' -> - satisfies val φ. -Proof using Type. - intros sub sat ? isin. - apply sat, sub; auto. -Qed. + Lemma satisfies_union v φ1 φ2 : + satisfies v (CS.union φ1 φ2) + <-> (satisfies v φ1 /\ satisfies v φ2). + Proof. + unfold satisfies. split. + - intros H; split; intros c Hc; apply H; now apply CS.union_spec. + - intros [H1 H2] c Hc; apply CS.union_spec in Hc; destruct Hc; auto. + Qed. -Definition consistent ctrs := exists v, satisfies v ctrs. + Lemma satisfies_subset φ φ' val : + ConstraintSet.Subset φ φ' -> + satisfies val φ' -> + satisfies val φ. + Proof using Type. + intros sub sat ? isin. + apply sat, sub; auto. + Qed. -Definition consistent_extension_on cs cstr := - forall v, satisfies v (ContextSet.constraints cs) -> exists v', - satisfies v' cstr /\ - LevelSet.For_all (fun l => val v l = val v' l) (ContextSet.levels cs). + Definition consistent ctrs := exists v, satisfies v ctrs. -Lemma consistent_extension_on_empty Σ : - consistent_extension_on Σ CS.empty. -Proof using Type. - move=> v hv; exists v; split; [move=> ? /CS.empty_spec[]| move=> ??//]. -Qed. + Definition consistent_extension_on cs cstr := + forall v, satisfies v (ContextSet.constraints cs) -> exists v', + satisfies v' cstr /\ + LevelSet.For_all (fun l => val v l = val v' l) (ContextSet.levels cs). + + Lemma consistent_extension_on_empty Σ : + consistent_extension_on Σ CS.empty. + Proof. + move=> v hv; exists v; split; [move=> ? /CS.empty_spec[]| move=> ??//]. + Qed. + + Lemma fold_right_ext {A B} (f g : B -> A -> A) acc acc' l l' : + (forall x y, f x y = g x y) -> acc = acc' -> l = l' -> + fold_right f acc l = fold_right g acc' l'. + Proof. + intros hfg -> ->; induction l'; cbn; auto; congruence. + Qed. + + Lemma fold_right_map {A B C} (f : B -> A -> A) (g : C -> B) acc l : + fold_right (fun x acc => f (g x) acc) acc l = + fold_right (fun x acc => f x acc) acc (List.map g l). + Proof. + induction l; cbn; auto. congruence. + Qed. + + Lemma subset_levels_exprs {le levels} : + LevelSet.Subset (LevelExprSet.levels le) levels -> + forall e, LevelExprSet.In e le -> LevelSet.In e.1 levels. + Proof. + intros hs e hin. + destruct e as [l k]. + apply (hs l). clear hs. + unfold LevelExprSet.levels. + revert hin. + eapply LevelExprSetProp.fold_rec. + - intros s' emp hin. now specialize (emp _ hin). + - intros x a s' s'' hin hnin hadd hk. intros hin'. + rewrite LevelSet.add_spec. + apply hadd in hin'. destruct hin'. subst. now left. + firstorder. + Qed. + + Definition max_ne_list x l := + fold_right Nat.max x l. + + Lemma fold_right_assoc {A} (f : A -> A -> A) acc acc' l : + (forall x y z, f x (f y z) = f y (f x z)) -> + fold_right f (f acc acc') l = f acc (fold_right f acc' l). + Proof. + intros hf. induction l in acc |- *; cbn; auto. + now rewrite IHl hf. + Qed. + + Lemma fold_right_assoc_comm {A} (f : A -> A -> A) acc l : + (forall x y, f x y = f y x) -> + (forall x y z, f x (f y z) = f y (f x z)) -> + fold_right f acc l = fold_right f acc (List.rev l). + Proof. + intros hf hf'. induction l in acc |- *; cbn; auto. + rewrite fold_right_app /= -IHl fold_right_assoc //. + Qed. -Lemma consistent_extension_on_union X cstrs - (wfX : forall c, CS.In c X.2 -> LS.In c.1.1 X.1 /\ LS.In c.2 X.1) : - consistent_extension_on X cstrs <-> + Lemma max_ne_list_rev {x l} : max_ne_list x l = max_ne_list x (List.rev l). + Proof. + unfold max_ne_list. + rewrite fold_right_assoc_comm //; lia. + Qed. + + Lemma val_max (l : Universe.t) (v : valuation) : + val v l = let nel := to_nonempty_list l in + max_ne_list (val v nel.1) (List.map (val v) nel.2). + Proof. + cbn. + rewrite val_fold_right. unfold Universe.exprs. + rewrite fold_right_map max_ne_list_rev /max_ne_list map_rev //. + Qed. + + Lemma val_eq_level_expr v v' levels : + LevelSet.For_all (fun l : LevelSet.elt => val v l = val v' l) levels -> + forall le : LevelExpr.t, LevelSet.In le.1 levels -> val v le = val v' le. + Proof. + intros hl [l k] hin; cbn. + rewrite hl //. + Qed. + + Lemma val_eq_levels_alg v v' levels : + LevelSet.For_all (fun l : LevelSet.elt => val v l = val v' l) levels -> + forall le : Universe.t, + LevelSet.Subset (LevelExprSet.levels le) levels -> + val v le = val v' le. + Proof. + move=> hl le /subset_levels_exprs sub. + rewrite !val_max. + move: (to_nonempty_list_spec le). destruct to_nonempty_list as [hd tl]. cbn. + intros heq. f_equal. + - cbn. eapply val_eq_level_expr; tea. + eapply sub. + apply LevelExprSetFact.elements_2. rewrite -heq. now left. + - eapply map_ext_in => x inx. + eapply val_eq_level_expr; tea. + apply sub, LevelExprSetFact.elements_2. rewrite -heq. now right. + Qed. + + (* Lemma consistent_extension_on_union X cstrs + (wfX : forall c, CS.In c X.2 -> LS.Subset (LevelExprSet.levels c.1.1) X.1 /\ LS.Subset (LevelExprSet.levels c.2) X.1) : + consistent_extension_on X cstrs -> consistent_extension_on X (CS.union cstrs X.2). -Proof using Type. - split. - 2: move=> h v /h [v' [/satisfies_union [??] eqv']]; exists v'; split=> //. +Proof. move=> hext v /[dup] vsat /hext [v' [v'sat v'eq]]. exists v'; split=> //. apply/satisfies_union; split=> //. move=> c hc. destruct (wfX c hc). - destruct (vsat c hc); constructor; rewrite -!v'eq //. -Qed. + destruct (vsat c hc); constructor; cbn in *. + 2:{ rewrite -(val_eq_levels_alg v v' _ v'eq l) //. + rewrite -(val_eq_levels_alg v v' _ v'eq l') //. } + rewrite -(val_eq_levels_alg v v' _ v'eq l) //. + rewrite -(val_eq_levels_alg v v' _ v'eq l') //. +Qed. *) + Lemma consistent_extension_on_union X cstrs + (wfX : forall c, CS.In c X.2 -> LS.In c.1.1 X.1 /\ LS.In c.2 X.1) : + consistent_extension_on X cstrs -> + consistent_extension_on X (CS.union cstrs X.2). + Proof. + move=> hext v /[dup] vsat /hext [v' [v'sat v'eq]]. + exists v'; split=> //. + apply/satisfies_union; split=> //. + move=> c hc. destruct (wfX c hc). + (* destruct (vsat c hc); constructor; cbn in *. + 2:{ rewrite -(val_eq_levels_alg v v' _ v'eq l) //. + rewrite -(val_eq_levels_alg v v' _ v'eq l') //. } + rewrite -(val_eq_levels_alg v v' _ v'eq l) //. + rewrite -(val_eq_levels_alg v v' _ v'eq l') //. *) + destruct (vsat c hc); constructor; rewrite -!v'eq //. + Qed. -Definition leq0_universe_n n φ (u u' : Universe.t) := - forall v, satisfies v φ -> (Z.of_nat (val v u) <= Z.of_nat (val v u') - n)%Z. + Definition leq0_universe_n n φ (u u' : Universe.t) := + forall v, satisfies v φ -> (Z.of_nat (val v u) <= Z.of_nat (val v u') - n)%Z. -Definition leq_universe_n {cf} n φ (u u' : Universe.t) := - if check_univs then leq0_universe_n n φ u u' else True. + Definition leq_universe_n n φ (u u' : Universe.t) := + if check_univs then leq0_universe_n n φ u u' else True. -Definition lt_universe {cf} := leq_universe_n 1. -Definition leq_universe {cf} := leq_universe_n 0. + Definition eq0_universe φ (u u' : Universe.t) := + forall v, satisfies v φ -> val v u = val v u'. -Definition eq0_universe φ (u u' : Universe.t) := - forall v, satisfies v φ -> val v u = val v u'. + Definition eq_universe {cf} φ (u u' : Universe.t) := + if check_univs then eq0_universe φ u u' else True. -Definition eq_universe {cf} φ (u u' : Universe.t) := - if check_univs then eq0_universe φ u u' else True. + Definition lt_universe := leq_universe_n 1. + Definition leq_universe := leq_universe_n 0. -(* ctrs are "enforced" by φ *) + Lemma leq_universe_leq_universe_n (φ : ConstraintSet.t) u u' : + leq_universe φ u u' <-> leq_universe_n 0 φ u u'. + Proof. intros. reflexivity. Qed. -Definition valid_constraints0 φ ctrs - := forall v, satisfies v φ -> satisfies v ctrs. + (* ctrs are "enforced" by φ *) -Definition valid_constraints {cf} φ ctrs - := if check_univs then valid_constraints0 φ ctrs else True. + Definition valid_constraints0 φ ctrs + := forall v, satisfies v φ -> satisfies v ctrs. -Definition compare_universe {cf} φ (pb : conv_pb) := - match pb with - | Conv => eq_universe φ - | Cumul => leq_universe φ - end. + Definition valid_constraints φ ctrs + := if check_univs then valid_constraints0 φ ctrs else True. + Definition compare_universe φ (pb : conv_pb) := + match pb with + | Conv => eq_universe φ + | Cumul => leq_universe φ + end. -Ltac unfold_univ_rel0 := - unfold eq0_universe, leq0_universe_n, valid_constraints0 in *; - try ( - match goal with |- forall v : valuation, _ -> _ => idtac end; - intros v Hv; - repeat match goal with H : forall v : valuation, _ -> _ |- _ => specialize (H v Hv) end; - cbnr - ). + Ltac unfold_univ_rel0 := + unfold eq0_universe, leq0_universe_n, valid_constraints0 in *; + try ( + match goal with |- forall v : valuation, _ -> _ => idtac end; + intros v Hv; + repeat match goal with H : forall v : valuation, _ -> _ |- _ => specialize (H v Hv) end; + cbnr + ). -Ltac unfold_univ_rel := - unfold eq_universe, leq_universe, lt_universe, leq_universe_n, valid_constraints in *; - destruct check_univs; [unfold_univ_rel0 | trivial]. - -Section Univ. - Context {cf}. + Ltac unfold_univ_rel := + unfold eq_universe, leq_universe, lt_universe, leq_universe_n, valid_constraints in *; + destruct check_univs; [unfold_univ_rel0 | trivial]. Lemma valid_subset φ φ' ctrs : ConstraintSet.Subset φ φ' -> valid_constraints φ ctrs @@ -1452,8 +1659,23 @@ Section Univ. -> leq_universe φ t u -> leq_universe φ' t u. Proof using Type. apply cmp_universe_subset with (pb := Cumul). Qed. + End Univ. +Ltac unfold_univ_rel0 := + unfold eq0_universe, leq0_universe_n, valid_constraints0 in *; + try ( + match goal with |- forall v : valuation, _ -> _ => idtac end; + intros v Hv; + repeat match goal with H : forall v : valuation, _ -> _ |- _ => specialize (H v Hv) end; + cbnr + ). + +Ltac unfold_univ_rel := + unfold eq_universe, leq_universe, lt_universe, leq_universe_n, valid_constraints in *; + destruct check_univs; [unfold_univ_rel0 | trivial]. + + Module Sort. Inductive t_ {univ} := sProp | sSProp | sType (_ : univ). @@ -2488,27 +2710,30 @@ Notation "x @[ u ]" := (subst_instance u x) (at level 3, | Level.lvar n => List.nth n u Level.lzero end. -#[global] Instance subst_instance_cstr : UnivSubst UnivConstraint.t := +#[global] Instance subst_instance_level_expr : UnivSubst LevelExpr.t := +fun u e => match e with + | (Level.lzero, _) + | (Level.level _, _) => e + | (Level.lvar n, b) => + match nth_error u n with + | Some l => (l,b) + | None => (Level.lzero, b) + end + end. + +#[global] Instance subst_instance_universe : UnivSubst Universe.t := + fun u => map (subst_instance_level_expr u). + +#[global] Instance subst_instance_cstr : UnivSubst LevelConstraint.t := fun u c => (subst_instance_level u c.1.1, c.1.2, subst_instance_level u c.2). +#[global] Instance subst_instance_univ_cstr : UnivSubst UnivConstraint.t := + fun u c => (subst_instance u c.1.1, c.1.2, subst_instance u c.2). + #[global] Instance subst_instance_cstrs : UnivSubst ConstraintSet.t := fun u ctrs => ConstraintSet.fold (fun c => ConstraintSet.add (subst_instance_cstr u c)) ctrs ConstraintSet.empty. -#[global] Instance subst_instance_level_expr : UnivSubst LevelExpr.t := - fun u e => match e with - | (Level.lzero, _) - | (Level.level _, _) => e - | (Level.lvar n, b) => - match nth_error u n with - | Some l => (l,b) - | None => (Level.lzero, b) - end - end. - -#[global] Instance subst_instance_universe : UnivSubst Universe.t := - fun u => map (subst_instance_level_expr u). - #[global] Instance subst_instance_sort : UnivSubst Sort.t := fun u e => match e with | sProp | sSProp => e @@ -2681,11 +2906,14 @@ Definition string_of_level (l : Level.t) : string := Definition string_of_level_expr (e : LevelExpr.t) : string := let '(l, n) := e in string_of_level l ^ (if n is 0 then "" else "+" ^ string_of_nat n). +Definition string_of_universe (e : LevelExprSet.t) : string := + string_of_list string_of_level_expr (LevelExprSet.elements e). + Definition string_of_sort (u : Sort.t) := match u with - | sSProp => "SProp" - | sProp => "Prop" - | sType l => "Type(" ^ string_of_list string_of_level_expr (LevelExprSet.elements l) ^ ")" + | Sort.sSProp => "SProp" + | Sort.sProp => "Prop" + | Sort.sType l => "Type(" ^ string_of_universe l ^ ")" end. Definition string_of_universe_instance u := @@ -2733,7 +2961,14 @@ Definition print_constraint_type d := | ConstraintType.Eq => "=" end. -Definition print_constraint_set t := - print_list (fun '(l1, d, l2) => string_of_level l1 ^ " " ^ - print_constraint_type d ^ " " ^ string_of_level l2) - " /\ " (ConstraintSet.elements t). +Definition print_level_constraint_set t := + print_list (fun '(l1, d, l2) => + string_of_level l1 ^ " " ^ + print_constraint_type d ^ " " ^ string_of_level l2) + " /\ " (ConstraintSet.elements t). + +Definition print_univ_constraint_set t := + print_list (fun '(l1, d, l2) => + string_of_universe (l1 : Universe.t) ^ " " ^ + print_constraint_type d ^ " " ^ string_of_universe (l2 : Universe.t)) + " /\ " (UnivConstraintSet.elements t). diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index c97822819..80ac4a138 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -357,7 +357,7 @@ Section GcOfConstraint. (* None -> not satisfiable *) (* Some empty -> useless *) (* else: singleton or two elements set (l = l' -> {l<=l', l'<=l}) *) - Definition gc_of_constraint `{checker_flags} (uc : UnivConstraint.t) + Definition gc_of_constraint `{checker_flags} (uc : LevelConstraint.t) : option GoodConstraintSet.t := let empty := Some GoodConstraintSet.empty in let singleton := fun x => Some (GoodConstraintSet.singleton x) in @@ -2922,7 +2922,7 @@ Section AddLevelsCstrs. - constructor. + intros. setoid_rewrite ConstraintSetFact.elements_iff. setoid_rewrite InA_In_eq. - transitivity ((exists (c : UnivConstraint.t) (gcs : GoodConstraintSet.t), + transitivity ((exists (c : LevelConstraint.t) (gcs : GoodConstraintSet.t), gc_of_constraint c = Some gcs /\ In c (ConstraintSet.elements s) /\ GoodConstraintSet.In gc gcs) \/ GCS.In gc GCS.empty). 2:gcsets. diff --git a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v index 4e443e15a..ee9456ac6 100644 --- a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v +++ b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v @@ -581,7 +581,7 @@ Proof. split; apply LS.union_spec; right; apply H. Qed. -Definition is_monomorphic_cstr (c : UnivConstraint.t) +Definition is_monomorphic_cstr (c : LevelConstraint.t) := negb (Level.is_var c.1.1) && negb (Level.is_var c.2). Lemma monomorphic_global_constraint {cf : checker_flags} Σ (hΣ : wf Σ) c : diff --git a/template-rocq/_PluginProject.in b/template-rocq/_PluginProject.in index 70dc3bb7c..86edb8194 100644 --- a/template-rocq/_PluginProject.in +++ b/template-rocq/_PluginProject.in @@ -152,8 +152,10 @@ gen-src/mSetFacts.ml gen-src/mSetFacts.mli gen-src/mSetInterface.ml gen-src/mSetInterface.mli -gen-src/mSetList.ml -gen-src/mSetList.mli +# gen-src/mSetList.ml +# gen-src/mSetList.mli +gen-src/mSetAVL.ml +gen-src/mSetAVL.mli gen-src/mSetProperties.ml gen-src/mSetProperties.mli gen-src/monad_utils.ml diff --git a/template-rocq/_RocqProject.in b/template-rocq/_RocqProject.in index 0c45ba02e..6cd5b754c 100644 --- a/template-rocq/_RocqProject.in +++ b/template-rocq/_RocqProject.in @@ -2,6 +2,10 @@ -R theories MetaRocq.Template -I . +# Generic loop checking algorithm +theories/LoopChecking.v +theories/TemplateLoopChecking.v + # Basic Ast files theories/Ast.v theories/AstUtils.v diff --git a/template-rocq/src/ast_denoter.ml b/template-rocq/src/ast_denoter.ml index f31e38694..3f7ed951c 100644 --- a/template-rocq/src/ast_denoter.ml +++ b/template-rocq/src/ast_denoter.ml @@ -27,7 +27,7 @@ struct type quoted_sort_family = Universes0.allowed_eliminations type quoted_constraint_type = Universes0.ConstraintType.t - type quoted_univ_constraint = Universes0.UnivConstraint.t + type quoted_univ_constraint = Universes0.LevelConstraint.t type quoted_univ_constraints = Universes0.ConstraintSet.t type quoted_univ_level = Universes0.Level.t type quoted_univ_instance = Universes0.Instance.t diff --git a/template-rocq/src/ast_quoter.ml b/template-rocq/src/ast_quoter.ml index b287cf827..5226cc9f1 100644 --- a/template-rocq/src/ast_quoter.ml +++ b/template-rocq/src/ast_quoter.ml @@ -28,7 +28,7 @@ struct type quoted_sort_family = Universes0.allowed_eliminations type quoted_constraint_type = Universes0.ConstraintType.t - type quoted_univ_constraint = Universes0.UnivConstraint.t + type quoted_univ_constraint = Universes0.LevelConstraint.t type quoted_univ_constraints = Universes0.ConstraintSet.t type quoted_univ_level = Universes0.Level.t type quoted_univ_instance = Universes0.Instance.t diff --git a/template-rocq/src/plugin_core.ml b/template-rocq/src/plugin_core.ml index 5823a50ff..74bfcb522 100644 --- a/template-rocq/src/plugin_core.ml +++ b/template-rocq/src/plugin_core.ml @@ -177,9 +177,11 @@ let tmQuoteInductive (kn : kername) : (Names.MutInd.t * mutual_inductive_body) o with Not_found -> success ~st env evm None -let tmQuoteUniverses : UGraph.t tm = +let tmQuoteUniverses : Univ.ContextSet.t tm = fun ~st env evm success _fail -> - success ~st env evm (Environ.universes env) + let graph = Environ.universes env in + let uctx = Tm_util.ugraph_contextset graph in + success ~st env evm uctx let quote_module ~(include_functor : bool) ~(include_submodule : bool) ~(include_submodtype : bool) (qualid : qualid) : global_reference list = let mp = Nametab.locate_module qualid in diff --git a/template-rocq/src/plugin_core.mli b/template-rocq/src/plugin_core.mli index eecefcf4c..c7cf9639c 100644 --- a/template-rocq/src/plugin_core.mli +++ b/template-rocq/src/plugin_core.mli @@ -62,7 +62,7 @@ val tmLocateModTypeString : string -> Names.ModPath.t list tm val tmCurrentModPath : Names.ModPath.t tm val tmQuoteInductive : kername -> (Names.MutInd.t * mutual_inductive_body) option tm -val tmQuoteUniverses : UGraph.t tm +val tmQuoteUniverses : Univ.ContextSet.t tm val tmQuoteConstant : kername -> bool -> constant_body tm val tmQuoteModule : qualid -> global_reference list tm val tmQuoteModFunctor : qualid -> global_reference list tm diff --git a/template-rocq/src/quoter.ml b/template-rocq/src/quoter.ml index d481253fd..201db962c 100644 --- a/template-rocq/src/quoter.ml +++ b/template-rocq/src/quoter.ml @@ -208,35 +208,9 @@ struct | Polymorphic ctx -> Q.mkPolymorphic_ctx (Q.quote_abstract_univ_context ctx) let quote_ugraph ?kept (g : UGraph.t) = - debug Pp.(fun () -> str"Quoting ugraph"); - let levels, cstrs, eqs = - match kept with - | None -> - let cstrs, eqs = UGraph.constraints_of_universes g in - UGraph.domain g, cstrs, eqs - | Some l -> - debug Pp.(fun () -> str"Quoting graph restricted to: " ++ Univ.Level.Set.pr Univ.Level.raw_pr l); - (* Feedback.msg_debug Pp.(str"Graph is: " ++ UGraph.pr_universes Univ.Level.raw_pr (UGraph.repr g)); *) - let dom = UGraph.domain g in - let kept = Univ.Level.Set.inter dom l in - let kept = Univ.Level.Set.remove Univ.Level.set kept in - let cstrs = time Pp.(str"Computing graph restriction") (UGraph.constraints_for ~kept) g in - l, cstrs, [] - in - let levels, cstrs = - List.fold_right (fun eqs acc -> - match Univ.Level.Set.elements eqs with - | [] -> acc - | x :: [] -> acc - | x :: rest -> - List.fold_right (fun p (levels, cstrs) -> - (Univ.Level.Set.add p levels, Univ.Constraints.add (x, Univ.Eq, p) cstrs)) rest acc) - eqs (levels, cstrs) - in - let levels = Univ.Level.Set.add Univ.Level.set levels in - debug Pp.(fun () -> str"Universe context: " ++ Univ.pr_universe_context_set Univ.Level.raw_pr (levels, cstrs)); + let uctx = ugraph_contextset ?kept g in time (Pp.str"Quoting universe context") - (fun uctx -> Q.quote_univ_contextset uctx) (levels, cstrs) + (fun uctx -> Q.quote_univ_contextset uctx) uctx let quote_inductive' (ind, i) : Q.quoted_inductive = Q.quote_inductive (Q.quote_kn (Names.MutInd.canonical ind), Q.quote_int i) diff --git a/template-rocq/src/run_extractable.ml b/template-rocq/src/run_extractable.ml index 9920cad49..7763406b7 100644 --- a/template-rocq/src/run_extractable.ml +++ b/template-rocq/src/run_extractable.ml @@ -41,7 +41,7 @@ let quote_rel_context env sigma ctx = quote_context decls (* todo(gmm): this definition adapted from quoter.ml (the body of quote_minductive_type) *) -let of_mib (env : Environ.env) (t : Names.MutInd.t) (mib : Plugin_core.mutual_inductive_body) +let of_mib (env : Environ.env) (t : Names.MutInd.t) (mib : Plugin_core.mutual_inductive_body) : Ast0.Env.mutual_inductive_body = match quote_mind_decl env (Evd.from_env env) t mib with | Ast0.Env.InductiveDecl mib -> mib @@ -73,9 +73,9 @@ let of_mib (env : Environ.env) (t : Names.MutInd.t) (mib : Plugin_core.mutual_in let ctx = oib.mind_arity_ctxt in CList.chop (List.length ctx - List.length mib.mind_params_ctxt) ctx in - let indices = quote_rel_context (push_rel_context pars env) indices in + let indices = quote_rel_context (push_rel_context pars env) indices in let indty = quote_term env indty in - let indsort = Q.quote_sort (inductive_sort oib) in + let indsort = Q.quote_sort (inductive_sort oib) in let (reified_ctors,acc) = List.fold_left (fun (ls,acc) (nm,ty,ar) -> let ty = quote_term acc ty in @@ -100,7 +100,7 @@ let of_mib (env : Environ.env) (t : Names.MutInd.t) (mib : Plugin_core.mutual_in in let relevance = quote_relevance oib.mind_relevance in let sf = quote_sort_family oib.mind_kelim in - (quote_ident oib.mind_typename, indty, indsort, indices, sf, + (quote_ident oib.mind_typename, indty, indsort, indices, sf, (List.rev reified_ctors), projs, relevance) :: ls, acc) ([],env) (Array.to_list mib.mind_packets) in @@ -120,7 +120,7 @@ let get_constant_body b = match b with | Def b -> Some b | Undef inline -> None - | OpaqueDef pr -> + | OpaqueDef pr -> let proof, _ = Global.force_proof Library.indirect_accessor pr in (* FIXME delayed univs skipped *) Some proof @@ -234,7 +234,7 @@ let rec interp_tm (t : 'a coq_TM) : 'a tm = None -> Obj.magic (tmFail Pp.(str "inductive does not exist")) | Some (mi, mib) -> Obj.magic (tmOfMib mi mib)) | Coq_tmQuoteUniverses -> - tmMap (fun x -> failwith "tmQuoteUniverses") tmQuoteUniverses + tmMap (fun x -> Obj.magic (quote_univ_contextset x)) tmQuoteUniverses | Coq_tmQuoteModule id -> tmMap (fun x -> Obj.magic (List.map quote_global_reference x)) (tmQuoteModule (to_qualid id)) | Coq_tmQuoteModFunctor id -> diff --git a/template-rocq/src/tm_util.ml b/template-rocq/src/tm_util.ml index ee1acfdfd..9d250ddbb 100644 --- a/template-rocq/src/tm_util.ml +++ b/template-rocq/src/tm_util.ml @@ -292,6 +292,39 @@ module RetypeMindEntry = in ctx, mind end +let ugraph_contextset ?kept (g : UGraph.t) = + debug Pp.(fun () -> str"Turning universe graph into universe context set"); + let levels, cstrs, eqs = + match kept with + | None -> + let cstrs, eqs = UGraph.constraints_of_universes g in + UGraph.domain g, cstrs, eqs + | Some l -> + debug Pp.(fun () -> str"Graph restricted to: " ++ Univ.Level.Set.pr Univ.Level.pr l); + (* Feedback.msg_debug Pp.(str"Graph is: " ++ UGraph.pr_universes Univ.Level.pr (UGraph.repr g)); *) + let dom = UGraph.domain g in + let kept = Univ.Level.Set.inter dom l in + let kept = Univ.Level.Set.remove Univ.Level.set kept in + let cstrs = time Pp.(str"Computing graph restriction") (UGraph.constraints_for ~kept) g in + l, cstrs, [] + in + let levels, cstrs = + List.fold_right (fun eqs acc -> + match Univ.Level.Set.elements eqs with + | [] -> acc + | x :: [] -> acc + | x :: rest -> + List.fold_right (fun p (levels, cstrs) -> + (Univ.Level.Set.add p levels, Univ.Constraint.add (x, Univ.Eq, p) cstrs)) rest acc) + eqs (levels, cstrs) + in + let levels = Univ.Level.Set.add Univ.Level.set levels in + let levels = Univ.Level.Set.remove Univ.Level.prop levels in + let levels = Univ.Level.Set.remove Univ.Level.sprop levels in + let cstrs = Univ.Constraint.remove (Univ.Level.prop, Univ.Lt, Univ.Level.set) cstrs in + debug Pp.(fun () -> str"Universe context: " ++ Univ.pr_universe_context_set Univ.Level.pr (levels, cstrs)); + (levels, cstrs) + type ('term, 'name, 'nat) adef = { adname : 'name; adtype : 'term; adbody : 'term; rarg : 'nat } type ('term, 'name, 'nat) amfixpoint = ('term, 'name, 'nat) adef list diff --git a/template-rocq/theories/Constants.v b/template-rocq/theories/Constants.v index 8186b690d..33e0b1be3 100644 --- a/template-rocq/theories/Constants.v +++ b/template-rocq/theories/Constants.v @@ -119,7 +119,7 @@ Register MetaRocq.Common.Universes.Level.lzero as metarocq.ast.level.lzero. Register MetaRocq.Common.Universes.Level.lvar as metarocq.ast.level.Var. Register MetaRocq.Common.Universes.LevelExprSet.Mkt as metarocq.ast.levelexprset.mkt. -Register MetaRocq.Common.Universes.Build_nonEmptyLevelExprSet as metarocq.ast.universe.build0. +Register MetaRocq.Common.Universes.LevelExprSet.Build_nonEmptyLevelExprSet as metarocq.ast.universe.build0. Register MetaRocq.Common.Universes.Sort.sSProp as metarocq.ast.sort.sprop. Register MetaRocq.Common.Universes.Sort.sProp as metarocq.ast.sort.prop. Register MetaRocq.Common.Universes.Sort.sType as metarocq.ast.sort.type. diff --git a/template-rocq/theories/ExtractLoopChecking.v b/template-rocq/theories/ExtractLoopChecking.v new file mode 100644 index 000000000..5d197983b --- /dev/null +++ b/template-rocq/theories/ExtractLoopChecking.v @@ -0,0 +1,17 @@ +From Equations Require Import Equations. +From Coq Require Import ExtrOcamlBasic ExtrOcamlNatInt ExtrOcamlZInt. +From MetaCoq.Template Require Import LoopChecking. + +Extract Constant BinInt.Z.of_nat => "(fun x -> x)". +Extract Constant BinInt.Z.to_nat => "(fun x -> x)". +Extract Constant pr1 => "fst". +Extract Constant pr2 => "snd". + +Extraction Inline inspect. +Extraction Inline ReflectEq.eqb ReflectEq.reflect_prod ReflectEq.eq_prod. + +Cd "extraction_clauses". + +Extraction "loop_checking.ml" LoopChecking. + +Cd "..". \ No newline at end of file diff --git a/template-rocq/theories/LoopChecking.v b/template-rocq/theories/LoopChecking.v new file mode 100644 index 000000000..2dc573540 --- /dev/null +++ b/template-rocq/theories/LoopChecking.v @@ -0,0 +1,2823 @@ +(* Distributed under the terms of the MIT license. *) +From Stdlib Require Import ssreflect ssrbool. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils. +From MetaRocq.Common Require Universes. +From Equations Require Import Equations. +Set Equations Transparent. + +(* TODO move *) +Arguments exist {A P}. +Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. + +Module FMapOrderedType_from_UsualOrderedType (O : UsualOrderedType). + Import O. + Definition t := O.t. + Definition eq : O.t -> O.t -> Prop := O.eq. + Definition lt : O.t -> O.t -> Prop := O.lt. + Definition eq_refl : forall x : O.t, eq x x := reflexivity. + Definition eq_sym : forall x y : O.t, eq x y -> eq y x := fun x y H => symmetry H. + + Lemma eq_trans : forall x y z, O.eq x y -> O.eq y z -> O.eq x z. + Proof. intros x y z. unfold O.eq. apply transitivity. Qed. + Lemma lt_trans : forall x y z, O.lt x y -> O.lt y z -> O.lt x z. + Proof. intros. eapply O.lt_strorder; tea. Qed. + + Lemma lt_not_eq : forall x y : O.t, lt x y -> ~ eq x y. + Proof. + intros x y H eq. do 2 red in eq. subst x. now eapply lt_strorder in H. + Qed. + + Definition compare : forall x y : O.t, Compare lt eq x y. + Proof. + intros. + case_eq (compare x y); intros. + apply EQ. abstract (destruct (compare_spec x y) => //). + apply LT. abstract (destruct (compare_spec x y) => //). + apply GT. abstract (destruct (compare_spec x y) => //). + Defined. + + Definition eq_dec : forall x y : O.t, {eq x y} + {~ eq x y} := eq_dec. +End FMapOrderedType_from_UsualOrderedType. + +Module Type LevelOrderedType. + Include UsualOrderedType. + + Parameter reflect_eq : ReflectEq t. + #[local] Existing Instance reflect_eq. + + Parameter to_string : t -> string. + +End LevelOrderedType. + +Module Type FMapOTInterface (E : UsualOrderedType). + Module OT := FMapOrderedType_from_UsualOrderedType E. + Include FMapInterface.Sfun OT. +End FMapOTInterface. + +Module Type LevelExprItf (Level : LevelOrderedType). + Include UsualOrderedType with Definition t := (Level.t * nat)%type. + Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. +End LevelExprItf. + +Module Type LevelExprSet_fun (Level : LevelOrderedType) (LevelExpr : LevelExprItf Level). + Include SWithLeibniz with Module E := LevelExpr. + + Record nonEmptyLevelExprSet + := { t_set : t ; + t_ne : is_empty t_set = false }. + +End LevelExprSet_fun. + +Module Type LoopCheckingItf (Level : LevelOrderedType) + (LevelSet : MSetInterface.SetsOn Level) + (LevelExpr : LevelExprItf Level) + (LevelExprSet : LevelExprSet_fun Level LevelExpr) + (LevelMap : FMapOTInterface Level). + + Definition model := LevelMap.t nat. + Definition valuation := LevelMap.t nat. + + Definition clause : Type := LevelExprSet.nonEmptyLevelExprSet × LevelExpr.t. + + Parameter clauses : Type. + Parameter clauses_of_list : list clause -> clauses. + Parameter list_of_clauses : clauses -> list clause. + + Inductive constraint_type := UnivEq | UnivLe. + Notation constraint := (LevelExprSet.nonEmptyLevelExprSet * constraint_type * LevelExprSet.nonEmptyLevelExprSet). + + Parameter enforce_constraint : forall (cstr : constraint) (cls : clauses), clauses. + + Parameter valid_model : forall (V : LevelSet.t) (m : model) (cls : clauses), Type. + + Parameter model_model : forall V m cls, valid_model V m cls -> model. + + (* { model_model : model; + model_of_V :> model_of V model_model; + model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; + model_ok :> is_model cls model_model; + model_extends : model_extension V m model_model; + }. *) + + Infix "⊂_lset" := LevelSet.Subset (at level 70). + + Parameter enforce_clauses : forall {V init cls} (m : valid_model V init cls) (cls' : clauses), option model. + + Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := + | Loop + | Model (w : LevelSet.t) (m : valid_model V m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). + + Parameter init_model : clauses -> model. + Parameter clauses_levels : clauses -> LevelSet.t. + + Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). + + Parameter infer : forall (cls : clauses), infer_result (clauses_levels cls) cls. + +End LoopCheckingItf. + +Module LoopChecking + (* Signature of levels: decidable, ordered type *) + (Level : LevelOrderedType) + (LevelSet : MSetInterface.SetsOn Level) + (LevelExpr : LevelExprItf Level) + (LevelExprSet : LevelExprSet_fun Level LevelExpr) + (LevelMap : FMapOTInterface Level) <: LoopCheckingItf Level LevelSet LevelExpr LevelExprSet LevelMap. + +Definition level (e : LevelExpr.t) : Level.t := fst e. +Definition levels (e : LevelExprSet.t) := + LevelExprSet.fold (fun le => LevelSet.add (level le)) e LevelSet.empty. + +Import LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). + +Local Existing Instance Level.reflect_eq. + +Module LevelSetFact := WFactsOn Level LevelSet. +Module LevelSetProp := WPropertiesOn Level LevelSet. +Module LevelSetDecide := LevelSetProp.Dec. +Module LevelMapFact := FMapFacts.WProperties_fun LevelMap.OT LevelMap. + +Ltac lsets := LevelSetDecide.fsetdec. +Notation "(=_lset)" := LevelSet.Equal (at level 0). +Infix "=_lset" := LevelSet.Equal (at level 30). +Infix "⊂_lset" := LevelSet.Subset (at level 70). +Infix "∪" := LevelSet.union (at level 70). + +Definition print_level_nat_map (m : LevelMap.t nat) := + let list := LevelMap.elements m in + print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_nat w) nl list. + +Definition print_lset (l : LevelSet.t) := + let list := LevelSet.elements l in + print_list Level.to_string " " list. + +Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. +Module LevelExprSetProp := WPropertiesOn LevelExpr LevelExprSet. + +(* We have decidable equality w.r.t leibniz equality for sets of levels. *) +#[global, program] Instance levelexprset_reflect : ReflectEq LevelExprSet.t := + { eqb := LevelExprSet.equal }. +Next Obligation. + destruct (LevelExprSet.equal x y) eqn:e; constructor. + eapply LevelExprSet.equal_spec in e. + now eapply LevelExprSet.eq_leibniz. + intros e'. + subst y. + pose proof (@LevelExprSetFact.equal_1 x x). + forward H. reflexivity. congruence. +Qed. + +#[global] Instance levelexprset_eq_dec : Classes.EqDec LevelExprSet.t := Classes.eq_dec. + +Derive NoConfusion for LevelExprSet.nonEmptyLevelExprSet. + +(* We use uip on the is_empty condition *) +#[global, program] Instance nonEmptyLevelExprSet_reflect : ReflectEq nonEmptyLevelExprSet := + { eqb x y := eqb x.(t_set) y.(t_set) }. +Next Obligation. + destruct (eqb_spec (t_set x) (t_set y)); constructor. + destruct x, y; cbn in *. subst. + now rewrite (uip t_ne0 t_ne1). + intros e; subst x; apply H. + reflexivity. +Qed. + +(** This coercion allows to see the non-empty set as a regular [LevelExprSet.t] *) +Coercion t_set : nonEmptyLevelExprSet >-> LevelExprSet.t. +Module LevelExprSetDecide := WDecide (LevelExprSet). +Ltac lesets := LevelExprSetDecide.fsetdec. +Infix "⊂_leset" := LevelExprSet.Subset (at level 70). + +Module NonEmptySetFacts. + #[program] Definition singleton (e : LevelExpr.t) : nonEmptyLevelExprSet + := {| t_set := LevelExprSet.singleton e |}. + Next Obligation. + apply negbTE. + eapply (contra_notN (P := LevelExprSet.Empty (LevelExprSet.singleton e))). + apply LevelExprSetFact.is_empty_2. intros ne. red in ne. specialize (ne e). lesets. + Qed. + + Lemma not_Empty_is_empty s : + ~ LevelExprSet.Empty s -> LevelExprSet.is_empty s = false. + Proof. + intro H. apply not_true_is_false. intro H'. + apply H. now apply LevelExprSetFact.is_empty_2 in H'. + Qed. + + Program Definition add (e : LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet + := {| t_set := LevelExprSet.add e u |}. + Next Obligation. + apply not_Empty_is_empty; intro H. + eapply H. eapply LevelExprSet.add_spec. + left; reflexivity. + Qed. + + Lemma add_spec e u e' : + LevelExprSet.In e' (add e u) <-> e' = e \/ LevelExprSet.In e' u. + Proof. + apply LevelExprSet.add_spec. + Qed. + + Definition add_list : list LevelExpr.t -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet + := List.fold_left (fun u e => add e u). + + Lemma add_list_spec l u e : + LevelExprSet.In e (add_list l u) <-> In e l \/ LevelExprSet.In e u. + Proof. + unfold add_list. rewrite <- fold_left_rev_right. + etransitivity. 2:{ eapply or_iff_compat_r. etransitivity. + 2: apply @InA_In_eq with (A:=LevelExpr.t). + eapply InA_rev. } + induction (List.rev l); cbn. + - split. intuition. intros [H|H]; tas. invs H. + - split. + + intro H. apply add_spec in H. destruct H as [H|H]. + * left. now constructor. + * apply IHl0 in H. destruct H as [H|H]; [left|now right]. + now constructor 2. + + intros [H|H]. inv H. + * apply add_spec; now left. + * apply add_spec; right. apply IHl0. now left. + * apply add_spec; right. apply IHl0. now right. + Qed. + + Lemma elements_not_empty {u : nonEmptyLevelExprSet} : LevelExprSet.elements u <> []. + Proof. + rewrite -LevelExprSetProp.elements_Empty. + move/LevelExprSetFact.is_empty_1. + destruct u as [u1 u2]; cbn in *. congruence. + Qed. + + Equations to_nonempty_list (u : nonEmptyLevelExprSet) : LevelExpr.t * list LevelExpr.t := + | u with inspect (LevelExprSet.elements u) := { + | exist [] eqel => False_rect _ (elements_not_empty eqel) + | exist (e :: l) _ => (e, l) }. + + Lemma singleton_to_nonempty_list e : to_nonempty_list (singleton e) = (e, []). + Proof. + funelim (to_nonempty_list (singleton e)). bang. + clear H. + pose proof (LevelExprSet.singleton_spec e1 e). + rewrite LevelExprSetFact.elements_iff in H. + rewrite InA_In_eq in H. rewrite e0 in H. + destruct H. forward H. now left. noconf H. f_equal. + pose proof (LevelExprSet.cardinal_spec (LevelExprSet.singleton e1)). rewrite e0 in H. cbn in H. + rewrite LevelExprSetProp.singleton_cardinal in H. + destruct l => //. + Qed. + + Lemma to_nonempty_list_spec u : + let '(e, u') := to_nonempty_list u in + e :: u' = LevelExprSet.elements u. + Proof. + funelim (to_nonempty_list u). bang. now rewrite e0. + Qed. + + Lemma to_nonempty_list_spec' u : + (to_nonempty_list u).1 :: (to_nonempty_list u).2 = LevelExprSet.elements u. + Proof. + pose proof (to_nonempty_list_spec u). + now destruct (to_nonempty_list u). + Qed. + + Lemma In_to_nonempty_list (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : + LevelExprSet.In e u + <-> e = (to_nonempty_list u).1 \/ In e (to_nonempty_list u).2. + Proof. + etransitivity. symmetry. apply LevelExprSet.elements_spec1. + pose proof (to_nonempty_list_spec' u) as H. + destruct (to_nonempty_list u) as [e' l]; cbn in *. + rewrite <- H; clear. etransitivity. apply InA_cons. + eapply or_iff_compat_l. apply InA_In_eq. + Qed. + + Lemma In_to_nonempty_list_rev (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : + LevelExprSet.In e u + <-> e = (to_nonempty_list u).1 \/ In e (List.rev (to_nonempty_list u).2). + Proof. + etransitivity. eapply In_to_nonempty_list. + apply or_iff_compat_l. apply in_rev. + Qed. + + Definition map (f : LevelExpr.t -> LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + let '(e, l) := to_nonempty_list u in + add_list (List.map f l) (singleton (f e)). + + Lemma map_spec f u e : + LevelExprSet.In e (map f u) <-> exists e0, LevelExprSet.In e0 u /\ e = (f e0). + Proof. + unfold map. symmetry. etransitivity. + { eapply iff_ex; intro. eapply and_iff_compat_r. eapply In_to_nonempty_list. } + destruct (to_nonempty_list u) as [e' l]; cbn in *. + symmetry. etransitivity. eapply add_list_spec. + etransitivity. eapply or_iff_compat_l. apply LevelExprSet.singleton_spec. + etransitivity. eapply or_iff_compat_r. + apply in_map_iff. clear u. split. + - intros [[e0 []]|H]. + + exists e0. split. right; tas. congruence. + + exists e'. split; tas. left; reflexivity. + - intros [xx [[H|H] ?]]. + + right. congruence. + + left. exists xx. split; tas; congruence. + Qed. + + Program Definition non_empty_union (u v : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + {| t_set := LevelExprSet.union u v |}. + Next Obligation. + apply not_Empty_is_empty; intro H. + assert (HH: LevelExprSet.Empty u). { + intros x Hx. apply (H x). + eapply LevelExprSet.union_spec. now left. } + apply LevelExprSetFact.is_empty_1 in HH. + rewrite t_ne in HH; discriminate. + Qed. + + + Lemma eq_univ (u v : nonEmptyLevelExprSet) : + u = v :> LevelExprSet.t -> u = v. + Proof. + destruct u as [u1 u2], v as [v1 v2]; cbn. intros X; destruct X. + now rewrite (uip_bool _ _ u2 v2). + Qed. + + Lemma eq_univ' (u v : nonEmptyLevelExprSet) : + LevelExprSet.Equal u v -> u = v. + Proof. + intro H. now apply eq_univ, LevelExprSet.eq_leibniz. + Qed. + + Lemma eq_univ'' (u v : nonEmptyLevelExprSet) : + LevelExprSet.elements u = LevelExprSet.elements v -> u = v. + Proof. + intro H. apply eq_univ. + destruct u as [u1 u2], v as [v1 v2]; cbn in *; clear u2 v2. + eapply LevelExprSet.eq_leibniz. red. + intros x. rewrite -!LevelExprSet.elements_spec1 H //. + Qed. + + Lemma univ_expr_eqb_true_iff (u v : nonEmptyLevelExprSet) : + LevelExprSet.equal u v <-> u = v. + Proof. + split. + - intros. + apply eq_univ'. now apply LevelExprSet.equal_spec. + - intros ->. now apply LevelExprSet.equal_spec. + Qed. + + Lemma univ_expr_eqb_comm (u v : nonEmptyLevelExprSet) : + LevelExprSet.equal u v <-> LevelExprSet.equal v u. + Proof. + transitivity (u = v). 2: transitivity (v = u). + - apply univ_expr_eqb_true_iff. + - split; apply eq_sym. + - split; apply univ_expr_eqb_true_iff. + Qed. + + + Lemma LevelExprSet_for_all_false f u : + LevelExprSet.for_all f u = false -> LevelExprSet.exists_ (negb ∘ f) u. + Proof. + intro H. rewrite LevelExprSetFact.exists_b. + rewrite LevelExprSetFact.for_all_b in H. + all: try now intros x y []. + induction (LevelExprSet.elements u); cbn in *; [discriminate|]. + apply andb_false_iff in H; apply orb_true_iff; destruct H as [H|H]. + left; now rewrite H. + right; now rewrite IHl. + Qed. + + Lemma LevelExprSet_For_all_exprs (P : LevelExpr.t -> Prop) (u : nonEmptyLevelExprSet) + : LevelExprSet.For_all P u + <-> P (to_nonempty_list u).1 /\ Forall P (to_nonempty_list u).2. + Proof. + etransitivity. + - eapply iff_forall; intro e. eapply imp_iff_compat_r. + apply In_to_nonempty_list. + - cbn; split. + + intro H. split. apply H. now left. + apply Forall_forall. intros x H0. apply H; now right. + + intros [H1 H2] e [He|He]. subst e; tas. + eapply Forall_forall in H2; tea. + Qed. + +End NonEmptySetFacts. +Import NonEmptySetFacts. + +Definition clause : Type := nonEmptyLevelExprSet × LevelExpr.t. + +Module Clause. + Definition t := clause. + + Definition eq : t -> t -> Prop := eq. + + Definition eq_equiv : RelationClasses.Equivalence eq := _. + + Inductive lt_ : t -> t -> Prop := + | lt_clause1 l e e' : LevelExpr.lt e e' -> lt_ (l, e) (l, e') + | lt_clause2 l l' b b' : LevelExprSet.lt l.(t_set) l'.(t_set) -> lt_ (l, b) (l', b'). + + Definition lt := lt_. + + Global Instance lt_strorder : RelationClasses.StrictOrder lt. + Proof. + constructor. + - intros x X; inversion X; subst. now eapply LevelExpr.lt_strorder in H1. + eapply LevelExprSet.lt_strorder; eassumption. + - intros x y z X1 X2; invs X1; invs X2; constructor; tea. + etransitivity; tea. + etransitivity; tea. + Qed. + + Definition lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt. + intros x x' H1 y y' H2. unfold lt. subst. reflexivity. + Qed. + + Definition compare (x y : t) : comparison := + match x, y with + | (l1, b1), (l2, b2) => + match LevelExprSet.compare l1.(t_set) l2.(t_set) with + | Eq => LevelExpr.compare b1 b2 + | x => x + end + end. + + Definition compare_spec : + forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y). + Proof. + intros [? ?] [? ?]; cbn; repeat constructor. + destruct (LevelExprSet.compare_spec n n0); repeat constructor; tas. + eapply LevelExprSet.eq_leibniz in H. apply NonEmptySetFacts.eq_univ in H. + subst. cbn in *. + destruct (LevelExpr.compare_spec t0 t1); repeat constructor; tas. now subst. + Qed. + + Global Instance reflect_t : ReflectEq t := reflect_prod _ _ . + + Definition eq_dec : forall (l1 l2 : t), {l1 = l2} + {l1 <> l2} := Classes.eq_dec. + + Definition eq_leibniz (x y : t) : eq x y -> x = y := id. +End Clause. + +Module Clauses := MSetAVL.Make Clause. +Module ClausesFact := WFactsOn Clause Clauses. +Module ClausesProp := WPropertiesOn Clause Clauses. +Module ClausesDecide := WDecide (Clauses). +Ltac clsets := ClausesDecide.fsetdec. + +Definition clauses := Clauses.t. + +Lemma filter_add {p x s} : Clauses.Equal (Clauses.filter p (Clauses.add x s)) (if p x then Clauses.add x (Clauses.filter p s) else Clauses.filter p s). +Proof. + intros i. + rewrite Clauses.filter_spec. + destruct (eqb_spec i x); subst; + destruct (p x) eqn:px; rewrite !Clauses.add_spec !Clauses.filter_spec; intuition auto || congruence. +Qed. + +Local Instance proper_fold_transpose {A} (f : Clauses.elt -> A -> A) : + transpose eq f -> + Proper (Clauses.Equal ==> eq ==> eq) (Clauses.fold f). +Proof. + intros hf s s' Hss' x ? <-. + eapply ClausesProp.fold_equal; tc; tea. +Qed. +Existing Class transpose. + +Lemma clauses_fold_filter {A} (f : Clauses.elt -> A -> A) (p : Clauses.elt -> bool) cls acc : + transpose Logic.eq f -> + Clauses.fold f (Clauses.filter p cls) acc = + Clauses.fold (fun elt acc => if p elt then f elt acc else acc) cls acc. +Proof. + intros hf. + symmetry. eapply ClausesProp.fold_rec_bis. + - intros s s' a eq. intros ->. + eapply ClausesProp.fold_equal; tc. auto. + intros x. + rewrite !Clauses.filter_spec. + now rewrite eq. + - now cbn. + - intros. + rewrite H1. + rewrite filter_add. + destruct (p x) eqn:px => //. + rewrite ClausesProp.fold_add //. + rewrite Clauses.filter_spec. intuition auto. +Qed. + +Definition levelexpr_level : LevelExpr.t -> Level.t := fst. +Coercion levelexpr_level : LevelExpr.t >-> Level.t. +Extraction Inline levelexpr_level. + +Definition strict_subset (s s' : LevelSet.t) := + LevelSet.Subset s s' /\ ~ LevelSet.Equal s s'. + +Lemma strict_subset_incl (x y z : LevelSet.t) : LevelSet.Subset x y -> strict_subset y z -> strict_subset x z. +Proof. + intros hs []. split => //. lsets. + intros heq. apply H0. lsets. +Qed. + +Lemma strict_subset_cardinal s s' : strict_subset s s' -> LevelSet.cardinal s < LevelSet.cardinal s'. +Proof. + intros []. + assert (LevelSet.cardinal s <> LevelSet.cardinal s'). + { intros heq. apply H0. + intros x. split; intros. now apply H. + destruct (LevelSet.mem x s) eqn:hin. + eapply LevelSet.mem_spec in hin. + auto. eapply LevelSetProp.FM.not_mem_iff in hin. + exfalso. + eapply LevelSetProp.subset_cardinal_lt in hin; tea. + lia. } + enough (LevelSet.cardinal s <= LevelSet.cardinal s') by lia. + now eapply LevelSetProp.subset_cardinal. +Qed. + +Definition premise (cl : clause) := fst cl. +Definition concl (cl : clause) := snd cl. +Extraction Inline premise concl. + +Definition clause_levels cl := + LevelSet.union (levels (premise cl)) (LevelSet.singleton (levelexpr_level (concl cl))). + +Definition clauses_levels (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls LevelSet.empty. + +Lemma Clauses_In_elements l s : + In l (Clauses.elements s) <-> Clauses.In l s. +Proof. + rewrite ClausesFact.elements_iff. + now rewrite InA_In_eq. +Qed. + +Lemma clauses_levels_spec_aux l cls acc : + LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls acc) <-> + (exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl)) \/ LevelSet.In l acc. +Proof. + eapply ClausesProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k [hin hl]]. clsets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.union_spec. + split. + * intros [hin'|]. + left. exists x. split => //. + apply hadd. now left. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. + * intros [[k [ins'' ?]]|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma clauses_levels_spec l cls : + LevelSet.In l (clauses_levels cls) <-> + exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl). +Proof. + unfold clauses_levels. + rewrite clauses_levels_spec_aux. + intuition auto. lsets. +Qed. + +Lemma clause_levels_spec l cl : + LevelSet.In l (clause_levels cl) <-> + LevelSet.In l (levels (premise cl)) \/ l = levelexpr_level (concl cl). +Proof. + unfold clause_levels. + now rewrite LevelSet.union_spec LevelSet.singleton_spec. +Qed. + +Definition model := LevelMap.t nat. + +Definition level_value (m : model) (level : Level.t) : nat := + match LevelMap.find level m with + | Some val => val + | None => 0 + end. + +Definition levelexpr_value (m : model) (atom : LevelExpr.t) := + level_value m (levelexpr_level atom). + +Extraction Inline levelexpr_value. + +Definition min_atom_value (m : model) (atom : LevelExpr.t) := + let '(l, k) := atom in + (Z.of_nat (level_value m l) - Z.of_nat k)%Z. + +Definition min_premise (m : model) (l : nonEmptyLevelExprSet) : Z := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (fun min atom => Z.min (min_atom_value m atom) min) tl (min_atom_value m hd). + +Definition satisfiable_atom (m : model) (atom : Level.t * nat) : bool := + let '(l, k) := atom in + match LevelMap.find l m with + | Some val => k <=? val + | None => false + end. + +Definition satisfiable_premise (m : model) (l : nonEmptyLevelExprSet) := + LevelExprSet.for_all (satisfiable_atom m) l. + +(* Definition valid_clause (m : model) (cl : clause) := *) + (* implb (satisfiable_premise m (premise cl)) (satisfiable_atom m (concl cl)). *) + +Definition valid_clause (m : model) (cl : clause) := + let k0 := min_premise m (premise cl) in + if (k0 (modified, wm) + | DoesntHold wm' => (true, wm') + | Holds => (modified, wm) + end. + +Definition check_model_aux (cls : clauses) (wm : LevelSet.t × model) : bool × (LevelSet.t × model) := + Clauses.fold check_clause_model cls (false, wm). + +(* If check_model = None then we have a model of all clauses, + othewise, we return Some (W', m') where W ⊂ W' and the model has + been updated for at least one atom l ∈ W'. *) +Definition check_model (cls : clauses) (wm : LevelSet.t × model) := + let '(modified, wm) := check_model_aux cls wm in + if modified then Some wm else None. + +Lemma check_model_aux_subset {cls w v} : + forall b w' v', check_model_aux cls (w, v) = (b, (w', v')) -> LevelSet.Subset w w'. +Proof. + intros w' v'. + unfold check_model, check_model_aux, check_clause_model. revert w' v'. + eapply ClausesProp.fold_rec => //. + { intros. noconf H0. reflexivity. } + intros x a s' s'' hin nin hadd IH. + intros b w' v'. destruct a. + destruct p as []. + unfold update_value. + destruct Z.ltb. intros [= -> -> ->] => //. + now eapply IH. + destruct x as [prem [l k]]; cbn. + destruct Nat.leb. intros [= -> -> ->] => //. now eapply IH. + intros [= <- <- <-]. intros x inx. + eapply LevelSet.add_spec. + specialize (IH _ _ _ eq_refl). + now right. +Qed. + +Lemma check_model_subset {cls w v} : + forall w' v', check_model cls (w, v) = Some (w', v') -> LevelSet.Subset w w'. +Proof. + intros w' v'. unfold check_model. + destruct check_model_aux eqn:cm. + destruct p as [W m]. + eapply check_model_aux_subset in cm. + destruct b => //. now intros [= <- <-]. +Qed. + +Definition premise_restricted_to W cl := + LevelSet.subset (levels (premise cl)) W. + +Definition clause_restricted_to W cl := + LevelSet.subset (levels (premise cl)) W && + LevelSet.mem (level (concl cl)) W. + +Definition restrict_clauses (cls : clauses) (W : LevelSet.t) := + Clauses.filter (clause_restricted_to W) cls. + +Lemma in_restrict_clauses (cls : clauses) (concls : LevelSet.t) cl : + Clauses.In cl (restrict_clauses cls concls) <-> + [/\ LevelSet.In (level (concl cl)) concls, + LevelSet.Subset (levels (premise cl)) concls & + Clauses.In cl cls]. +Proof. + unfold restrict_clauses. + rewrite Clauses.filter_spec. + destruct cl. cbn. + rewrite andb_true_iff LevelSet.subset_spec LevelSet.mem_spec. + firstorder auto. +Qed. + +Definition clauses_with_concl (cls : clauses) (concl : LevelSet.t) := + Clauses.filter (fun '(prem, concla) => LevelSet.mem (level concla) concl) cls. + +Lemma in_clauses_with_concl (cls : clauses) (concls : LevelSet.t) cl : + Clauses.In cl (clauses_with_concl cls concls) <-> + LevelSet.In (level (concl cl)) concls /\ Clauses.In cl cls. +Proof. + unfold clauses_with_concl. + rewrite Clauses.filter_spec. + destruct cl. rewrite LevelSet.mem_spec. cbn. firstorder eauto. +Qed. + +Definition clauses_conclusions (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.add (level (concl cl)) acc) cls LevelSet.empty. + +Lemma clauses_conclusions_spec a cls : + LevelSet.In a (clauses_conclusions cls) <-> + exists cl, Clauses.In cl cls /\ level (concl cl) = a. +Proof. + unfold clauses_conclusions. + eapply ClausesProp.fold_rec; clear. + - move=> s' he /=. rewrite LevelSetFact.empty_iff. + firstorder auto. + - move=> cl ls cls' cls'' hin hnin hadd ih. + rewrite LevelSet.add_spec. firstorder eauto. + specialize (H0 x). cbn in H0. + apply hadd in H1. firstorder eauto. + subst. left. now destruct x. +Qed. + +Lemma clauses_conclusions_clauses_with_concl cls concl : + LevelSet.Subset (clauses_conclusions (clauses_with_concl cls concl)) concl. +Proof. + intros x [cl []] % clauses_conclusions_spec. + eapply in_clauses_with_concl in H as []. + now rewrite H0 in H. +Qed. + +Lemma clauses_conclusions_restrict_clauses cls W : + LevelSet.Subset (clauses_conclusions (restrict_clauses cls W)) W. +Proof. + intros x [cl []] % clauses_conclusions_spec. + eapply in_restrict_clauses in H as []. + now rewrite H0 in H. +Qed. + +Definition in_clauses_conclusions (cls : clauses) (x : Level.t): Prop := + exists cl, Clauses.In cl cls /\ (level cl.2) = x. + +Definition v_minus_w_bound (W : LevelSet.t) (m : model) := + LevelMap.fold (fun w v acc => Nat.max v acc) + (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0. + +Definition levelexpr_k : LevelExpr.t -> nat := snd. +Coercion levelexpr_k : LevelExpr.t >-> nat. + +Definition level_expr_elt : LevelExprSet.elt -> LevelExpr.t := fun x => x. +Coercion level_expr_elt : LevelExprSet.elt >-> LevelExpr.t. + +Definition premise_min (l : nonEmptyLevelExprSet) : nat := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (B:=LevelExpr.t) (fun min atom => Nat.min atom min) tl hd. + +Definition gain (cl : clause) : Z := + Z.of_nat (levelexpr_k (concl cl)) - Z.of_nat (premise_min (premise cl)). + +Definition max_gain (cls : clauses) := + Clauses.fold (fun cl acc => Nat.max (Z.to_nat (gain cl)) acc) cls 0. + +Definition model_same_domain (m m' : model) := + forall l, LevelMap.In l m <-> LevelMap.In l m'. + +#[local] Instance model_same_domain_refl : Reflexive model_same_domain. +Proof. intros m l. reflexivity. Qed. + +#[local] Instance model_same_domain_trans : Transitive model_same_domain. +Proof. intros m m' m'' h h' l. rewrite (h l). apply h'. Qed. + +Definition model_le (m m' : model) := + forall l k, LevelMap.MapsTo l k m -> + exists k', LevelMap.MapsTo l k' m' /\ k <= k'. + +Infix "⩽" := model_le (at level 70). (* \leqslant *) + +Definition model_map_outside V (m m' : model) := + forall l, ~ LevelSet.In l V -> + forall k, LevelMap.MapsTo l k m <-> LevelMap.MapsTo l k m'. + +#[local] Instance model_map_outside_refl V : Reflexive (model_map_outside V). +Proof. intros m l. reflexivity. Qed. + +#[local] Instance model_map_outside_trans V : Transitive (model_map_outside V). +Proof. + intros m m' m'' h h' l hnin k. + rewrite (h l hnin k). now apply h'. +Qed. + +(** The termination proof relies on the correctness of check_model: + it does strictly increase a value but not above [max_gain cls]. +*) + +Lemma clauses_conclusions_diff cls s : + clauses_conclusions (Clauses.diff cls (clauses_with_concl cls s)) ⊂_lset + LevelSet.diff (clauses_conclusions cls) s. +Proof. + intros a. rewrite LevelSet.diff_spec !clauses_conclusions_spec. + firstorder eauto. + exists x; split => //. + now rewrite Clauses.diff_spec in H. + intros ha. + rewrite Clauses.diff_spec in H; destruct H as []. + apply H1. + rewrite in_clauses_with_concl. split => //. + now rewrite H0. +Qed. + +Lemma diff_eq U V : LevelSet.diff V U =_lset V <-> LevelSet.inter V U =_lset LevelSet.empty. +Proof. split. lsets. lsets. Qed. + +Lemma levelset_neq U V : LevelSet.equal U V = false -> ~ LevelSet.Equal U V. +Proof. intros eq heq % LevelSet.equal_spec. congruence. Qed. + +Lemma levelset_union_same U : LevelSet.union U U =_lset U. +Proof. lsets. Qed. + +Lemma fold_left_comm {A B} (f : B -> A -> B) (l : list A) (x : A) (acc : B) : + (forall x y z, f (f z x) y = f (f z y) x) -> + fold_left f l (f acc x) = f (fold_left f l acc) x. +Proof. + intros. + induction l in acc, x |- *; cbn. auto. + rewrite -IHl. f_equal. now rewrite H. +Qed. + +Lemma fold_left_le (f g : nat -> LevelSet.elt -> nat) l : + (forall acc acc' x, In x l -> acc <= acc' -> f acc x <= g acc' x) -> + forall acc acc', acc <= acc' -> + fold_left f l acc <= fold_left g l acc'. +Proof. + intros hfg. + induction l => //. cbn. intros. + apply IHl. intros. apply hfg => //. now right. apply hfg => //. now left. +Qed. + +Lemma fold_left_ne_lt (f g : nat -> LevelSet.elt -> nat) l acc : + (forall (x y : LevelSet.elt) z, f (f z x) y = f (f z y) x) -> + (forall (x y : LevelSet.elt) z, g (g z x) y = g (g z y) x) -> + l <> [] -> + (forall acc acc' x, In x l -> (acc <= acc') -> (f acc x <= g acc' x)) -> + (forall acc acc' x, In x l -> (acc < acc') -> (f acc x < g acc' x)) -> + (exists x, In x l /\ forall acc acc', (acc <= acc') -> (f acc x < g acc' x)) -> + fold_left f l acc < fold_left g l acc. +Proof. + intros hf hg. + generalize (Nat.le_refl acc). + generalize acc at 2 4. + induction l in acc |- * => //. + intros. + destruct l; cbn. + { destruct H3 as [x []]. cbn in H3. destruct H3; subst => //. + now eapply (H4 acc acc0). } + cbn in IHl. + rewrite hf hg. + rewrite fold_left_comm //. rewrite (fold_left_comm g) //. + destruct H3 as [min [hmin hfg]]. + destruct hmin as [<-|hel]. + - apply hfg. apply fold_left_le => //. intros; eapply H1 => //. now right; right. + apply H1 => //. now right; left. + - apply H2. now left. eapply IHl => //. + * intros acc1 acc' x hin. apply (H1 acc1 acc' x). now right. + * intros acc1 acc' x hin. apply (H2 acc1 acc' x). now right. + * exists min. split => //. +Qed. + +Infix "↓" := clauses_with_concl (at level 70). (* \downarrow *) +Infix "⇂" := restrict_clauses (at level 70). (* \downharpoonright *) + +Lemma clauses_conclusions_diff_left cls W cls' : + clauses_conclusions (Clauses.diff (cls ↓ W) cls') ⊂_lset W. +Proof. + intros l. + rewrite clauses_conclusions_spec. + move=> [] cl. rewrite Clauses.diff_spec => [] [] []. + move/in_clauses_with_concl => [] hin ? ? eq. + now rewrite eq in hin. +Qed. + +Lemma clauses_conclusions_diff_restrict cls W cls' : + clauses_conclusions (Clauses.diff (cls ⇂ W) cls') ⊂_lset W. +Proof. + intros l. + rewrite clauses_conclusions_spec. + move=> [] cl. rewrite Clauses.diff_spec => [] [] []. + move/in_restrict_clauses => [] hin ? ? ? eq. + now rewrite eq in hin. +Qed. + +Lemma LevelSet_In_elements l s : + In l (LevelSet.elements s) <-> LevelSet.In l s. +Proof. + rewrite LevelSetFact.elements_iff. + now rewrite InA_In_eq. +Qed. + +Lemma clauses_empty_eq {s} : Clauses.Empty s -> Clauses.Equal s Clauses.empty. +Proof. clsets. Qed. + +Lemma update_value_valid {W m cl} : + match update_value (W, m) cl with + | VacuouslyTrue | Holds => valid_clause m cl + | DoesntHold _ => ~~ valid_clause m cl + end. +Proof. + unfold update_value, valid_clause. + destruct Z.ltb => //. + destruct cl as [prem [l k]]; cbn. + destruct Nat.leb => //. +Qed. + +Lemma valid_update_value {W m cl} : + valid_clause m cl -> + match update_value (W, m) cl with + | VacuouslyTrue | Holds => true + | DoesntHold _ => false + end. +Proof. + unfold update_value, valid_clause. + destruct Z.ltb => //. + destruct cl as [prem [l k]]; cbn. + destruct Nat.leb => //. +Qed. + +Lemma check_model_aux_false {cls acc acc'} : check_model_aux cls acc = (false, acc') -> acc = acc'. +Proof. + unfold check_model_aux, check_clause_model. + eapply ClausesProp.fold_rec. + - intros s emp [=] => //. + - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. + intros IH. + destruct update_value eqn:upd => //. +Qed. + +(* Lemma check_model_aux_true {cls acc acc'} : check_model_aux cls acc = (true, acc') -> acc = acc'. +Proof. + unfold check_model_aux. + eapply ClausesProp.fold_rec. + - intros s emp [=] => //. + - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. + intros IH. + destruct update_value eqn:upd => //. +Qed. *) + +Lemma check_model_aux_model {cls acc} : + check_model_aux cls acc = (false, acc) <-> is_model cls acc.2. +Proof. + unfold check_model_aux, check_clause_model. + unfold is_model. + unfold is_true; rewrite -ClausesFact.for_all_iff. + eapply ClausesProp.fold_rec. + - intros s emp. + split => //. + intros [=] x hx. clsets. + - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. + intros IH. + split. + * move: (@update_value_valid w' m' cl). + destruct update_value eqn:upd => //; intros vcl [= -> <-] ; + destruct IH as [IH _]; specialize (IH eq_refl). + intros x hx; apply incls'' in hx as []; subst. exact vcl. now apply IH. + intros x hx; apply incls'' in hx as []; subst. exact vcl. now apply IH. + * intros hf. + assert (valid_clause acc.2 cl). + { apply hf. apply incls''. intuition auto. } + destruct IH as [_ IH]. forward IH. + { intros x hx. apply hf. apply incls''. now right. } + noconf IH. + move: (@valid_update_value w' m' cl H). + destruct update_value eqn:upd => //. +Qed. + +Lemma clauses_for_all_neg {p s}: + ~~ Clauses.for_all p s <-> ~ Clauses.For_all p s. +Proof. + intuition auto. + rewrite ClausesFact.for_all_iff in H0. red in H. now rewrite H0 in H. + revert H. apply contra_notN. + rewrite ClausesFact.for_all_iff //. +Qed. + +Lemma clauses_for_all_exists {p s}: + ~~ Clauses.for_all p s <-> Clauses.exists_ (fun x => ~~ p x) s. +Proof. + rewrite ClausesFact.for_all_b ClausesFact.exists_b. + induction (Clauses.elements s). + - cbn; auto. reflexivity. + - cbn. rewrite negb_and. intuition auto. + move/orP: H1 => [->|] //. move/H. intros ->. now rewrite orb_true_r. + move/orP: H1 => [->|] //. move/H0. intros ->. now rewrite orb_true_r. +Qed. +#[local] Instance model_le_refl : Reflexive model_le. +Proof. intros x l k map. exists k; split => //. Qed. + +#[local] Instance model_le_trans : Transitive model_le. +Proof. intros m m' m'' mm' m'm'' l k map. + apply mm' in map as [k' [map ?]]. + apply m'm'' in map as [k'' [map ?]]. exists k''. split => //. lia. +Qed. + +Lemma update_model_monotone m l k : level_value m l <= k -> m ⩽ update_model m l k. +Proof. + intros hl. + intros l' k' maps. + unfold update_model. cbn. + destruct (eqb_spec l l'). + - exists k. move: hl. subst l'. + unfold level_value. + rewrite (LevelMap.find_1 maps). + intros hle. + split => //. eapply LevelMap.add_1. eapply LevelMap.OT.eq_refl. + - exists k'. split => //. apply LevelMap.add_2 => //. +Qed. + +Lemma check_clause_model_inv {cl modified w m b wm'} : + check_clause_model cl (modified, (w, m)) = (b, wm') -> + m ⩽ wm'.2. +Proof. + unfold check_clause_model. + destruct (update_value (w, m) cl) eqn:upd. + * now intros [= <- <-]. + * now intros [= <- <-]. + * intros [= <- <-]. + move: upd. + unfold update_value. + case: Z.ltb_spec => //. + destruct cl as [prem [l k]] => /=. + intros hprem. + case: Nat.leb_spec => // hlt. + intros [= <-]. cbn. + eapply update_model_monotone. lia. +Qed. + +Lemma check_clause_model_intact {cl modified w m wm'} : + check_clause_model cl (modified, (w, m)) = (false, wm') -> valid_clause m cl /\ wm' = (w, m). +Proof. + unfold check_clause_model. + move: (@update_value_valid w m cl). + destruct (update_value (w, m) cl) eqn:upd. + * intros valid [= -> <-]. split => //. + * intros valid [= -> <-]. split => //. + * intros _ [=]. +Qed. + +Lemma check_clause_model_modify {cl w m wm'} : + check_clause_model cl (false, (w, m)) = (true, wm') -> ~~ valid_clause m cl. +Proof. + unfold check_clause_model. + destruct (update_value (w, m) cl) eqn:upd. + * now intros [= <- <-]. + * now intros [= <- <-]. + * intros [= <-]. + move: upd. + unfold update_value, valid_clause. + case: Z.ltb_spec => //. + destruct cl as [prem [l k]] => /=. + intros hprem. + case: Nat.leb_spec => // hlt. +Qed. + +Lemma check_model_aux_model_le {cls acc acc' b} : + check_model_aux cls acc = (b, acc') -> acc.2 ⩽ acc'.2. +Proof. + unfold check_model_aux. + revert b acc'. + eapply ClausesProp.fold_rec. + - intros s emp b acc'. intros [=]. subst. reflexivity. + - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. + intros IH b acc'. + move/check_clause_model_inv. + specialize (IH _ _ eq_refl). cbn in IH. now intros; transitivity m'. +Qed. + +Lemma level_value_update_model m l k : + level_value (update_model m l k) l = k. +Proof. + unfold level_value, update_model. + cbn -[LevelMap.find LevelMap.add]. + rewrite LevelMapFact.F.add_o. + destruct LevelMap.OT.eq_dec => //. + exfalso. now apply n. +Qed. + + +Lemma model_map_outside_weaken {W W'} {m m' : model} : + model_map_outside W m m' -> + W ⊂_lset W' -> + model_map_outside W' m m'. +Proof. + intros hm sub x hin k. + apply hm. intros hin'. apply sub in hin'. now apply hin. +Qed. + +Lemma is_model_union {cls cls' m} : + is_model cls m -> is_model cls' m -> is_model (Clauses.union cls cls') m. +Proof. + rewrite /is_model. rewrite /is_true -!ClausesFact.for_all_iff. + now move=> ism ism' x /Clauses.union_spec []. +Qed. + +#[local] Instance Clauses_For_All_proper : Proper (eq ==> Clauses.Equal ==> iff) Clauses.For_all. +Proof. + intros x y -> cl cl' eqcl. + unfold Clauses.For_all. now setoid_rewrite eqcl. +Qed. + +#[local] Instance Clauses_for_all_proper : Proper (eq ==> Clauses.Equal ==> eq) Clauses.for_all. +Proof. + intros x y -> cl cl' eqcl. + apply iff_is_true_eq_bool. + rewrite /is_true -!ClausesFact.for_all_iff. now rewrite eqcl. +Qed. + +#[local] Instance is_model_proper : Proper (Clauses.Equal ==> eq ==> eq) is_model. +Proof. + intros cl cl' eqcl x y ->. unfold is_model. now rewrite eqcl. +Qed. + +Lemma model_le_values {m m' : model} x : m ⩽ m' -> level_value m x <= level_value m' x. +Proof. + intros lem. specialize (lem x). + unfold level_value. + destruct LevelMap.find eqn:hl => //. 2:lia. + apply LevelMap.find_2 in hl. specialize (lem _ hl) as [k' [mapsto leq]]. + now rewrite (LevelMap.find_1 mapsto). +Qed. + +Lemma level_value_MapsTo {k e} {m : model} : + LevelMap.MapsTo k e m -> level_value m k = e. +Proof. + unfold level_value. + move=> mapto; rewrite (LevelMap.find_1 mapto) //. +Qed. + +Infix "⊂_clset" := Clauses.Subset (at level 70). + +Lemma max_gain_in cl cls : + Clauses.In cl cls -> + Z.to_nat (gain cl) <= max_gain cls. +Proof. + intros hin. + unfold max_gain. revert cl hin. + eapply ClausesProp.fold_rec. + - intros s' ise hin. firstorder eauto. + - intros x a s' s'' xs nxs' hadd IH cl' hin'. + eapply hadd in hin' as []. + * subst x. lia. + * specialize (IH _ H). lia. +Qed. + +Definition max_gain_subset (cls cls' : Clauses.t) : + cls ⊂_clset cls' -> + max_gain cls <= max_gain cls'. +Proof. + unfold max_gain at 1. + revert cls'. + eapply ClausesProp.fold_rec. + - intros s' ise sub. lia. + - intros x a s' s'' xs nxs' hadd IH cls'' hs. + specialize (IH cls''). forward IH. transitivity s'' => //. + intros ??. now apply hadd. + assert (incls'' : Clauses.In x cls''). + { now apply hs, hadd. } + apply max_gain_in in incls''. lia. +Qed. + +Notation cls_diff cls W := (Clauses.diff (cls ↓ W) (cls ⇂ W)) (only parsing). + +(* + Equations? extend_model {W cls} (m : valid_model W (cls ⇂ W)) + (r : result W (Clauses.diff (cls ↓ W) (cls ⇂ W))) + : result W (cls ↓ W) := + extend_model _ Loop := Loop; + extend_model m (Model w m' sub) := + Model w {| model_model := m'.(model_model) |} _. + Proof. + - apply LevelSet.subset_spec in sub. now apply clauses_conclusions_clauses_with_concl in H. + - eapply sub. now eapply m.(model_clauses_conclusions). + - apply m. + - eapply LevelSet.subset_spec. eapply LevelSet.subset_spec in sub. + now transitivity V. + Qed. + + *) + +Lemma not_mem l s : ~~ LevelSet.mem l s <-> ~ LevelSet.In l s. +Proof. + split. apply contraNnot. apply LevelSet.mem_spec. + eapply contra_notN; tea. now move/LevelSet.mem_spec. +Qed. + +Lemma v_minus_w_bound_irrel {W} m m' : + model_map_outside W m m' -> + v_minus_w_bound W m = v_minus_w_bound W m'. +Proof. + unfold v_minus_w_bound. + intros out. eapply LevelMapFact.fold_Equal. tc. cbn. + { intros x y eq. cbn. solve_proper. } + { intros x y. cbn. intros e e' a neq. lia. } + apply LevelMapFact.F.Equal_mapsto_iff. + intros k e. rewrite -> LevelMapFact.filter_iff. + 2:{ intros x y eq. red in eq. subst; solve_proper. } + rewrite -> LevelMapFact.filter_iff. + 2:{ move=> x y ->. solve_proper. } + rewrite [_ = true]not_mem. intuition auto. + - now apply out. + - now apply out. +Qed. + +Definition max_premise_value (m : model) (l : nonEmptyLevelExprSet) : nat := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (fun min atom => Nat.max (levelexpr_value m atom) min) tl (levelexpr_value m hd). + +Definition non_W_atoms W (l : LevelExprSet.t) := + LevelExprSet.filter (fun lk => ~~ LevelSet.mem lk.1 W) l. + +Lemma non_W_atoms_spec W l : forall x, LevelExprSet.In x (non_W_atoms W l) <-> LevelExprSet.In x l /\ ~ LevelSet.In x.1 W. +Proof. + intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec -not_mem. +Qed. + +Lemma non_W_atoms_subset W l : non_W_atoms W l ⊂_leset l. +Proof. intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec. Qed. + +Lemma levelexprset_levels_spec_aux l (e : LevelExprSet.t) acc : + LevelSet.In l (LevelExprSet.fold (fun le : LevelExprSet.elt => LevelSet.add (level le)) e acc) <-> + (exists k, LevelExprSet.In (l, k) e) \/ LevelSet.In l acc. +Proof. + eapply LevelExprSetProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k hin]. lesets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.add_spec. + split. + * intros [->|]. + left. exists (levelexpr_k x). + apply hadd. cbn. left. now destruct x. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. apply hadd. now right. + * intros [[k ins'']|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma levelexprset_levels_spec l (e : LevelExprSet.t) : + LevelSet.In l (levels e) <-> exists k, LevelExprSet.In (l, k) e. +Proof. + rewrite levelexprset_levels_spec_aux. intuition auto. lsets. +Qed. + +Lemma levels_exprs_non_W_atoms {W prem} : + LevelSet.Equal (levels (non_W_atoms W prem)) (LevelSet.diff (levels prem) W). +Proof. + intros e. unfold non_W_atoms. + rewrite levelexprset_levels_spec LevelSet.diff_spec levelexprset_levels_spec. + firstorder eauto. + rewrite LevelExprSet.filter_spec in H. now exists x. + rewrite LevelExprSet.filter_spec in H. destruct H. + rewrite LevelSetFact.not_mem_iff. + destruct LevelSet.mem => //. + exists x. + rewrite LevelExprSet.filter_spec. split => //. + rewrite LevelSetFact.not_mem_iff in H0. now rewrite H0. +Qed. + +Lemma levelexprset_empty_levels x : LevelExprSet.Empty x <-> LevelSet.Empty (levels x). +Proof. + split. + - intros he. + intros l hin. + eapply levelexprset_levels_spec in hin as [k hin]. lesets. + - intros emp l hin. eapply emp. eapply (levelexprset_levels_spec l.1). exists l.2. + now destruct l. +Qed. + +Lemma non_W_atoms_ne W cl cls : + Clauses.In cl (cls_diff cls W) -> + LevelExprSet.is_empty (non_W_atoms W (premise cl)) = false. +Proof. + intros x. + apply Clauses.diff_spec in x as [clw clr]. + eapply in_clauses_with_concl in clw as [clw incls]. + apply/negbTE. + apply/(contra_notN _ clr). + intros he. rewrite in_restrict_clauses. split => //. + epose proof (@levels_exprs_non_W_atoms W (premise cl)). + eapply LevelExprSetFact.is_empty_2 in he. + intros x hin. eapply levelexprset_empty_levels in he. rewrite H in he. + specialize (he x). rewrite LevelSet.diff_spec in he. intuition auto. + rewrite -LevelSet.mem_spec in H1 |- *. destruct LevelSet.mem; intuition auto. +Qed. + +Section MoreNonEmpty. + + Import LevelExprSet. + Import NonEmptySetFacts. + + Lemma In_elements {x} {s : nonEmptyLevelExprSet} : In x s <-> List.In x (elements s). + Proof. + split. now move/LevelExprSetFact.elements_1/InA_In_eq. + now move/InA_In_eq/LevelExprSetFact.elements_2. + Qed. + + Lemma min_premise_spec_aux (m : model) s k : + min_premise m s = k -> + (forall x, LevelExprSet.In x s -> (k <= min_atom_value m x)%Z) /\ + (exists x, LevelExprSet.In x s /\ k = min_atom_value m x). + Proof. + unfold min_premise. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. reflexivity. + now exists t0; split => //. + - destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [t0]) in H as [<-|inih]. + cbn. rewrite fold_left_comm. lia. lia. + specialize (ha _ inih). + cbn. rewrite fold_left_comm. lia. lia. + destruct hex as [minval [inmin ih]]. + cbn. rewrite fold_left_comm. lia. + destruct (Z.leb_spec (min_atom_value m a) (min_atom_value m minval)). + exists a. split; [intuition|]. lia. exists minval. + cbn in inmin; split; [intuition auto|]. lia. + Qed. + + Lemma min_premise_spec (m : model) (s : nonEmptyLevelExprSet) : + (forall x, LevelExprSet.In x s -> (min_premise m s <= min_atom_value m x)%Z) /\ + (exists x, LevelExprSet.In x s /\ min_premise m s = min_atom_value m x). + Proof. + now apply min_premise_spec_aux. + Qed. + + Lemma min_premise_subset (m : model) (s s' : nonEmptyLevelExprSet) : + LevelExprSet.Subset s s' -> + (min_premise m s' <= min_premise m s)%Z. + Proof. + intros sub. + have [has [mins [ins eqs]]] := min_premise_spec m s. + have [has' [mins' [ins' eqs']]] := min_premise_spec m s'. + specialize (sub _ ins). specialize (has' _ sub). + lia. + Qed. + + Lemma premise_min_spec_aux s k : + premise_min s = k -> + (forall x, LevelExprSet.In x s -> (k <= x)) /\ + (exists x, LevelExprSet.In x s /\ k = x). + Proof. + unfold premise_min. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. + now exists t0; split => //. + - destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [t0]) in H as [<-|inih]. + cbn. rewrite fold_left_comm. unfold level_expr_elt in *; lia. unfold level_expr_elt in *; lia. + specialize (ha _ inih). + cbn. rewrite fold_left_comm. lia. lia. + destruct hex as [minval [inmin ih]]. + cbn. rewrite fold_left_comm. lia. + destruct (Nat.leb_spec a minval). + exists a. split; [intuition|]. rewrite -ih in H. unfold level_expr_elt in *; lia. + exists minval. + cbn in inmin; split; [intuition auto|]. lia. + Qed. + + Lemma premise_min_spec (s : nonEmptyLevelExprSet) : + (forall x, LevelExprSet.In x s -> premise_min s <= x) /\ + (exists x, LevelExprSet.In x s /\ premise_min s = x). + Proof. + now apply premise_min_spec_aux. + Qed. + + Lemma premise_min_subset (s s' : nonEmptyLevelExprSet) : + LevelExprSet.Subset s s' -> + premise_min s' <= premise_min s. + Proof. + intros sub. + have [has [mins [ins eqs]]] := premise_min_spec s. + have [has' [mins' [ins' eqs']]] := premise_min_spec s'. + specialize (sub _ ins). specialize (has' _ sub). + lia. + Qed. + + Lemma max_premise_value_spec_aux (m : model) s k : + max_premise_value m s = k -> + (forall x, LevelExprSet.In x s -> levelexpr_value m x <= k) /\ + (exists x, LevelExprSet.In x s /\ k = levelexpr_value m x). + Proof. + unfold max_premise_value. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. + now exists t0; split => //. + - destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [t0]) in H as [<-|inih]. + cbn. rewrite fold_left_comm. lia. lia. + specialize (ha _ inih). + cbn. rewrite fold_left_comm. lia. lia. + destruct hex as [maxval [inmax ih]]. + cbn. rewrite fold_left_comm. lia. + destruct (Nat.leb_spec (levelexpr_value m maxval) (levelexpr_value m a)). + exists a. split; [intuition|]. lia. exists maxval. + cbn in inmax; split; [intuition auto|]. lia. + Qed. + + Lemma max_premise_value_spec (m : model) (s : nonEmptyLevelExprSet) : + (forall x, LevelExprSet.In x s -> levelexpr_value m x <= max_premise_value m s) /\ + (exists x, LevelExprSet.In x s /\ max_premise_value m s = levelexpr_value m x). + Proof. + now apply max_premise_value_spec_aux. + Qed. +End MoreNonEmpty. + +Lemma min_premise_pos_spec {m prem} : + (0 <= min_premise m prem)%Z -> + forall x, LevelExprSet.In x prem -> levelexpr_k x <= levelexpr_value m x. +Proof. + pose proof (min_premise_spec m prem) as [amin [exmin [inminpre eqminpre]]]. + intros hprem x hin. + specialize (amin _ hin). + unfold min_atom_value in amin. + destruct x as [l k]; cbn in *. unfold levelexpr_value; cbn. + lia. +Qed. + +Definition equal_model (m m' : model) := LevelMap.Equal m m'. + +#[local] Instance equal_model_equiv : Equivalence equal_model. +Proof. unfold equal_model. + split; try econstructor; eauto. + red. intros. now symmetry. + red; intros. now transitivity y. +Qed. + +#[local] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. +Proof. + intros x y eqm l ? <-. unfold level_value. + unfold equal_model in eqm. + destruct LevelMap.find eqn:hl. + - eapply LevelMap.find_2 in hl. + rewrite eqm in hl. + eapply LevelMap.find_1 in hl. now rewrite hl. + - eapply LevelMapFact.F.not_find_in_iff in hl. + rewrite eqm in hl. + eapply LevelMapFact.F.not_find_in_iff in hl. + now rewrite hl. +Qed. + +Lemma v_minus_w_bound_spec W m : + forall x, ~ LevelSet.In x W -> level_value m x <= v_minus_w_bound W m. +Proof. + intros x him. + unfold v_minus_w_bound. + set (fm := LevelMapFact.filter _ _). + replace (level_value m x) with (level_value fm x). + 2:{ unfold level_value. + destruct LevelMap.find eqn:hl => //. + eapply LevelMap.find_2 in hl. + subst fm. cbn in hl. + eapply LevelMapFact.filter_iff in hl as []. 2:tc. + rewrite (LevelMap.find_1 H) //. + destruct (LevelMap.find _ m) eqn:hl' => //. + eapply LevelMap.find_2 in hl'. + assert (LevelMap.MapsTo x n fm). + eapply LevelMapFact.filter_iff. tc. + split => //. now rewrite [_ = true]not_mem. + now rewrite (LevelMap.find_1 H) in hl. } + clearbody fm. + eapply LevelMapFact.fold_rec. + - intros m' em. unfold level_value. + destruct LevelMap.find eqn:hl => //. + eapply LevelMap.find_2 in hl. + now apply em in hl. + - intros k e a m' m'' map nin hadd. + red in hadd. + unfold level_value. cbn. + rewrite hadd LevelMapFact.F.add_o. + destruct LevelMap.OT.eq_dec. do 2 red in e0. subst x. lia. + destruct LevelMap.find; lia. +Qed. + +Lemma clauses_levels_restrict_clauses cls W : + LevelSet.Subset (clauses_levels (cls ⇂ W)) W. +Proof. + intros x [cl []] % clauses_levels_spec. + eapply in_restrict_clauses in H as [hconc hprem incl]. + eapply clause_levels_spec in H0 as []. apply hprem, H. now subst x. +Qed. + +Lemma clauses_conclusions_levels cls : + clauses_conclusions cls ⊂_lset clauses_levels cls. +Proof. + intros x. + rewrite clauses_conclusions_spec clauses_levels_spec. + setoid_rewrite clause_levels_spec. + firstorder auto. +Qed. + +Record model_extension W m m' := + { model_ext_le : m ⩽ m'; + model_ext_same_domain : model_same_domain m m'; + model_ext_same_outside : model_map_outside W m m' }. + +#[local] Instance model_ext_reflexive W : Reflexive (model_extension W). +Proof. + intros m; split; reflexivity. +Qed. + +#[local] Instance model_ext_transitive W : Transitive (model_extension W). +Proof. + intros m m' m'' h h'; split; (etransitivity; [apply h|apply h']). +Qed. + +Lemma model_extension_weaken W W' m m' : + W ⊂_lset W' -> + model_extension W m m' -> + model_extension W' m m'. +Proof. + intros leW []; split => //. + eapply model_map_outside_weaken; tea. +Qed. + +Lemma model_ext_trans_weaken W W' m m' m'' : + W ⊂_lset W' -> + model_extension W m m' -> + model_extension W' m' m'' -> + model_extension W' m m''. +Proof. + intros leW mext mext'. eapply model_extension_weaken in mext; tea. + now etransitivity; tea. +Qed. + +Definition check_model_invariants cls w m w' m' (modified : bool) := + if modified then + [/\ w ⊂_lset w', + w' ⊂_lset (LevelSet.union w (clauses_conclusions cls)), + exists cl, + let cll := (levelexpr_level (concl cl)) in + [/\ Clauses.In cl cls, ~~ valid_clause m cl, + LevelSet.In cll w' & + level_value m cll < level_value m' cll] & + model_extension w' m m'] + else (w, m) = (w', m'). + +#[local] Instance clauses_conclusions_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_conclusions. +Proof. + intros cls cls' eq x. + rewrite !clauses_conclusions_spec. now setoid_rewrite eq. +Qed. + +#[local] Instance And3P_proper : Proper (iff ==> iff ==> iff ==> iff) ssrbool.and3. +Proof. + repeat intro. split; intros []; split; intuition auto. +Qed. + +#[local] Instance And4P_proper : Proper (iff ==> iff ==> iff ==> iff ==> iff) ssrbool.and4. +Proof. + repeat intro. split; intros []; split; intuition auto. +Qed. + +#[local] Instance check_model_invariants_proper : + Proper (Clauses.Equal ==> eq ==> eq ==> eq ==> eq ==> eq ==> iff) check_model_invariants. +Proof. + intros cls cls' eqcls. + repeat intro; subst. + unfold check_model_invariants. + destruct y3 => //. + now setoid_rewrite <-eqcls. +Qed. + +Lemma min_atom_value_levelexpr_value m l : Z.to_nat (min_atom_value m l) <= levelexpr_value m l - l. +Proof. + destruct l as [l k]; cbn. unfold levelexpr_value. cbn. lia. +Qed. + +Lemma clauses_conclusions_add cl cls : + clauses_conclusions (Clauses.add cl cls) =_lset + (LevelSet.singleton (level (concl cl)) ∪ + clauses_conclusions cls). +Proof. + intros x. + rewrite LevelSet.union_spec !clauses_conclusions_spec. + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.singleton_spec. + firstorder eauto. subst. now left. +Qed. + +Definition declared_model_level (m : model) l := LevelMap.In l m. + +Definition clause_conclusion cl := levelexpr_level (concl cl). + +Definition update_model_same_domain {m l k} : + declared_model_level m l -> + model_same_domain m (update_model m l k). +Proof. + unfold update_model, declared_model_level. + intros hin x. + rewrite LevelMapFact.F.add_in_iff. intuition auto. now subst. +Qed. + +Definition update_model_outside {m w l k} : + model_map_outside (LevelSet.add l w) m (update_model m l k). +Proof. + unfold update_model, model_map_outside. + intros l'. rewrite LevelSet.add_spec. + intros hin k'. + rewrite LevelMapFact.F.add_neq_mapsto_iff //. + intros heq. red in heq; subst l'. apply hin. now left. +Qed. + +Lemma check_clause_model_modify' {cl cls w m w' m' w'' m'' modified modified'} : + check_model_invariants cls w m w' m' modified -> + declared_model_level m (clause_conclusion cl) -> + check_clause_model cl (modified, (w', m')) = (modified', (w'', m'')) -> + check_model_invariants (Clauses.add cl cls) w m w'' m'' modified'. +Proof. + intros inv declcl. + unfold check_clause_model. + destruct (update_value (w', m') cl) eqn:upd. + * intros [= <- <-]. subst. + destruct modified. 2:{ noconf inv. reflexivity. } + destruct inv. + split => //. + + rewrite clauses_conclusions_add; lsets. + + destruct H1 as [cl' []]. + exists cl'; split => //. now rewrite Clauses.add_spec. + * intros [= <- <-]. subst. + destruct modified. 2:{ noconf inv. reflexivity. } + destruct inv. + split => //. + + rewrite clauses_conclusions_add; lsets. + + destruct H1 as [cl' []]. + exists cl'; split => //. now rewrite Clauses.add_spec. + * intros [= <- ->]. + move: upd. + unfold update_value. + case: Z.ltb_spec => //. + destruct cl as [prem [l k]] => /=. + intros hprem. + case: Nat.leb_spec => // hlt. + intros [= <- <-]. + destruct modified; noconf inv. + { destruct inv. + split => //. + + lsets. + + rewrite clauses_conclusions_add. + intros x. rewrite LevelSet.add_spec !LevelSet.union_spec LevelSet.singleton_spec. + intuition eauto. cbn. apply H0 in H4. lsets. + + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. + destruct H1 as [cl []]; exists cl; split => //. eauto. eauto. + eapply Nat.lt_le_trans; tea. + eapply model_le_values. + now eapply update_model_monotone. + + transitivity m'. + { eapply model_extension_weaken; tea. lsets. } + split. + { now eapply update_model_monotone. } + { eapply update_model_same_domain. + eapply H2, declcl. } + { eapply update_model_outside. } } + { split => //. + + lsets. + + rewrite clauses_conclusions_add. + intros x. rewrite LevelSet.add_spec !LevelSet.union_spec LevelSet.singleton_spec. + intuition eauto. + + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. + exists (prem, (l, k)). + split; tea; eauto. + - unfold valid_clause. cbn. + case: Z.ltb_spec => //. cbn. lia. intros _. + rewrite -Nat.ltb_antisym. apply Nat.ltb_lt; lia. + - cbn. now rewrite level_value_update_model. + + split. + { now eapply update_model_monotone. } + { eapply update_model_same_domain. + eapply declcl. } + { eapply update_model_outside. } } +Qed. + +Definition model_of V (m : model) := + forall k, LevelSet.In k V -> LevelMap.In k m. + +Lemma model_of_subset V V' m : + model_of V m -> V' ⊂_lset V -> model_of V' m. +Proof. + rewrite /model_of. intros ih hv k. specialize (ih k). + now move/hv. +Qed. + +Lemma clauses_conclusions_subset {cls cls'} : + Clauses.Subset cls cls' -> + clauses_conclusions cls ⊂_lset clauses_conclusions cls'. +Proof. + intros hsub x. rewrite !clauses_conclusions_spec. + intuition eauto. destruct H as [cl []]; exists cl; split; try clsets; auto. +Qed. + +Lemma check_model_aux_spec {cls w m w' m' modified} : + model_of (clauses_conclusions cls) m -> + check_model_aux cls (w, m) = (modified, (w', m')) -> + check_model_invariants cls w m w' m' modified. +Proof. + rewrite /check_model_aux /is_model. + revert modified w' m'. + eapply ClausesProp.fold_rec. + - intros s' e modified w' m' mof [= <- <- <-]. + split. + - intros x ? s' s'' inx nins' hadd ih modified w' m' mof. + destruct a as [modified'' [w'' m'']]. + assert (ms' : model_of (clauses_conclusions s') m). + { eapply model_of_subset; tea. + eapply clauses_conclusions_subset. red in hadd. intros ?. + specialize (hadd a). intuition auto. } + specialize (ih _ _ _ ms' eq_refl). + apply ClausesProp.Add_Equal in hadd. rewrite hadd. + eapply check_clause_model_modify' => //. + red. apply mof. + apply clauses_conclusions_spec. exists x; split => //. + apply hadd. clsets. +Qed. + +Lemma check_model_spec {cls w m w' m'} : + model_of (clauses_conclusions cls) m -> + check_model cls (w, m) = Some (w', m') -> + check_model_invariants cls w m w' m' true. +Proof. + intros mof. + unfold check_model. + destruct check_model_aux eqn:cm. + destruct p as []. + eapply check_model_aux_spec in cm => //. + destruct b => //. now intros [= <- <-]. +Qed. + +Lemma check_model_aux_not_model {cls w m w' m'} : + model_of (clauses_conclusions cls) m -> + check_model_aux cls (w, m) = (true, (w', m')) -> + ~~ is_model cls m. +Proof. + intros mof. + move/(check_model_aux_spec mof) => [] _ _ [cl [incl inval]] _ _ _. + unfold is_model. + apply clauses_for_all_neg. + intros hf. specialize (hf cl incl). cbn in hf. + rewrite /is_true hf in inval => //. +Qed. + +Lemma check_model_is_model {W cls m} : + model_of (clauses_conclusions cls) m -> + check_model cls (W, m) = None <-> is_model cls m. +Proof. + intros mof; unfold check_model, is_model. + destruct check_model_aux eqn:caux. + destruct b => //. intuition auto. congruence. + { destruct p; eapply check_model_aux_not_model in caux => //. + rewrite /is_model /= // in caux. now rewrite H in caux. } + intuition auto. + pose proof (check_model_aux_false caux). subst p. + now rewrite check_model_aux_model in caux. +Qed. + +Lemma check_model_update {W cls m wm'} : + model_of (clauses_conclusions cls) m -> + check_model cls (W, m) = Some wm' -> ~~ is_model cls m /\ m ⩽ wm'.2. +Proof. + intros mof; unfold check_model, is_model. + destruct check_model_aux eqn:caux. + destruct b => //. intros [= <-]. intuition auto. + destruct p. + now eapply check_model_aux_not_model in caux. + now eapply check_model_aux_model_le in caux. +Qed. + +Definition measure_w W cls m w := + let bound := v_minus_w_bound W m in + let maxgain := max_gain (cls_diff cls W) in + (Z.of_nat bound + Z.of_nat maxgain - Z.of_nat (level_value m w))%Z. + +Lemma invalid_clause_measure W cls cl m : + ~~ valid_clause m cl -> + Clauses.In cl (cls_diff cls W) -> + (0 < measure_w W cls m (concl cl))%Z. +Proof. + unfold valid_clause. + case: Z.ltb_spec => // hprem. + destruct cl as [prem [l k]]; cbn. + case: Nat.leb_spec => // hlt. intros _ hin. + have hne := (non_W_atoms_ne _ _ _ hin). + cbn. unfold measure_w. unfold gain. + set (clsdiff := Clauses.diff _ _). + set (bound := v_minus_w_bound W m). + enough (Z.of_nat (level_value m l) < Z.of_nat bound + Z.of_nat (max_gain clsdiff))%Z. lia. + set (prem' := non_W_atoms W prem). + set (preml := {| t_set := prem'; t_ne := hne |}). + assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff). + { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. + unfold gain. cbn. + pose proof (premise_min_subset preml prem). + rewrite !Z2Nat.inj_sub //; try lia. rewrite !Nat2Z.id. + forward H. eapply non_W_atoms_subset. lia. } + eapply Z.lt_le_trans with (Z.of_nat bound + Z.of_nat (Z.to_nat (gain (preml, (l, k)))))%Z; try lia. + rewrite -Nat2Z.inj_add. + unfold gain; cbn. + enough (level_value m l < v_minus_w_bound W m + (k - premise_min preml)). lia. + enough (k + Z.to_nat (min_premise m prem) <= v_minus_w_bound W m + (k - premise_min preml)). lia. + assert (min_premise m prem <= min_premise m preml)%Z. + { eapply min_premise_subset. eapply non_W_atoms_subset. } + transitivity (k + Z.to_nat (min_premise m preml)). lia. + pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. + pose proof (max_premise_value_spec m preml) as [amax [exmax [inmaxpre eqmaxpre]]]. + pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. + assert (premise_min prem <= premise_min preml). + { eapply premise_min_subset. eapply non_W_atoms_subset. } + transitivity (v_minus_w_bound W m + (k - premise_min preml)). 2:lia. + assert (Z.to_nat (min_premise m preml) <= max_premise_value m preml - premise_min preml). + { rewrite eqpminpre eqmaxpre eqminpre. + pose proof (min_atom_value_levelexpr_value m exmin). etransitivity; tea. + specialize (amax _ inminpre). rewrite eqmaxpre in amax. + assert (expmin <= exmin). specialize (apmin _ inminpre). lia. + unfold level_expr_elt in *. lia. } + transitivity (k + (max_premise_value m preml - premise_min preml)). lia. + assert (premise_min preml <= max_premise_value m preml). + { rewrite eqmaxpre. + move/min_premise_pos_spec: hprem => hprem. + transitivity exmax. apply apmin => //. eapply hprem. + now apply (non_W_atoms_subset W prem). } + assert (k + (max_premise_value m preml - premise_min preml) = + (max_premise_value m preml + k - premise_min preml)) as ->. lia. + enough (max_premise_value m preml <= v_minus_w_bound W m). lia. + { rewrite eqmaxpre. + apply v_minus_w_bound_spec. + intros hin'. + have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). + rewrite levelexprset_levels_spec in hlevels. + forward hlevels. + exists exmax.2. now destruct exmax. + rewrite LevelSet.diff_spec in hlevels. + now destruct hlevels. } +Qed. + +Definition levelset_m_eq : LevelSet.t × model -> LevelSet.t × model -> Prop := + fun x y => LevelSet.Equal x.1 y.1 /\ LevelMap.Equal x.2 y.2. + +#[local] Instance lmeq_eq : Equivalence levelset_m_eq. +Proof. + split. intros x. split => //. + intros x y []; split => //. now rewrite H. + intros x y z [] []; split => //. + all:etransitivity; tea. +Qed. + +Definition modified_levelset_m_eq : bool × LevelSet.t × model -> bool × LevelSet.t × model -> Prop := + fun x y => x.1 = y.1 /\ levelset_m_eq x.2 y.2. + +#[local] Instance mlm_eq : Equivalence modified_levelset_m_eq. +Proof. + split. intros x. split => //. + intros x y []; split => //. now symmetry. + intros x y z [] []; split => //. all:etransitivity; tea. +Qed. + +#[local] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. +Proof. + intros m m' eqm ? ? ->. unfold min_atom_value. + destruct y => //. + now rewrite eqm. +Qed. + +#[local] Instance fold_left_ext {A B} : Proper (`=2` ==> eq ==> eq ==> eq) (@fold_left A B). +Proof. + intros f g hfg ? ? -> ? ? ->. + induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). +Qed. + +#[local] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. +Proof. + intros m m' eq ? ? ->. + unfold min_premise. + destruct to_nonempty_list. + now setoid_rewrite eq. +Qed. + +#[local] Instance update_model_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> LevelMap.Equal) update_model. +Proof. + intros m m' hm ? ? -> ? ? ->. + unfold update_model. + now rewrite hm. +Qed. + +#[local] Instance check_clause_model_proper : Proper (eq ==> modified_levelset_m_eq ==> modified_levelset_m_eq) check_clause_model. +Proof. + intros x y eq [? []] [? []] []; cbn in *; subst. + unfold levelset_m_eq in H0. destruct H0; cbn in *; subst. + replace (min_premise m (premise y)) with (min_premise m0 (premise y)). + 2: now rewrite H0. + destruct Z.ltb => //. + destruct concl => //. + replace (level_value m t1) with (level_value m0 t1). + 2:now rewrite H0. + destruct Nat.leb => //. + red. cbn. split => //. + red. cbn; split => //. now rewrite H. now rewrite H0. +Qed. + +Module ClausesOrd := OrdProperties Clauses. + + +#[local] Instance check_model_aux_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model_aux. +Proof. + intros cls cls' eq. + intros wm wm' eq'. subst wm'. + unfold check_model_aux. + now eapply ClausesOrd.fold_equal; tc. +Qed. + +#[local] Instance check_model_aux_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> modified_levelset_m_eq) check_model_aux. +Proof. + intros cls cls' eq. + intros wm wm' eq'. + transitivity (check_model_aux cls' wm). + 2:{ unfold check_model_aux. + eapply (ClausesProp.fold_init (eqA := modified_levelset_m_eq)); tc. + red. cbn => //. } + unfold check_model_aux. + now eapply ClausesOrd.fold_equal; tc. +Qed. + +#[local] Instance check_model_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> R_opt levelset_m_eq) check_model. +Proof. + intros cls cls' eq. + intros wm wm' eq'. + unfold check_model. + destruct (check_model_aux cls wm) eqn:eqc. + destruct (check_model_aux cls' wm') eqn:eqc' => //. + pose proof (check_model_aux_proper cls cls' eq wm wm' eq'). + rewrite eqc eqc' in H. destruct H; cbn in *; subst. + red in H0. destruct H0. + destruct b0 => //. +Qed. + +#[local] Instance check_model_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model. +Proof. + intros cls cls' eq. + intros wm wm' eq'. + unfold check_model. + now subst wm'; rewrite eq. +Qed. + +Record valid_model_def (V : LevelSet.t) (m : model) (cls : clauses) := + { model_model : model; + model_of_V :> model_of V model_model; + model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; + model_ok :> is_model cls model_model; + model_extends : model_extension V m model_model; + }. +Arguments model_model {V m cls}. +Arguments model_of_V {V m cls}. +Arguments model_clauses_conclusions {V m cls}. +Arguments model_ok {V m cls}. +Arguments model_extends {V m cls}. +Extraction Inline model_model. + +Definition valid_model := valid_model_def. + +Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := + | Loop + | Model (w : LevelSet.t) (m : valid_model V m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). +Arguments Loop {V U cls m}. +Arguments Model {V U cls m}. +Arguments lexprod {A B}. + +Definition option_of_result {V U m cls} (r : result V U m cls) : option model := + match r with + | Loop => None + | Model w m sub => Some m.(model_model) + end. + +Definition extends_model {W U cls m m'} : + m' ⩽ m -> + model_same_domain m' m -> + model_map_outside W m' m -> + result W U cls m -> result W U cls m'. +Proof. + intros leq ldom lout []. exact Loop. + econstructor 2; tea. + destruct m0. econstructor; tea. + - now transitivity m. +Qed. + +(* #[tactic="idtac"] +Equations? result_inclusion {V U m cls V'} (r : result V U cls m) + (prf : LevelSet.Subset V V') : result V' U cls m := + result_inclusion Loop _ := Loop; + result_inclusion (Model w m' sub) sub' := + Model w {| model_model := m'.(model_model) |} _. +Proof. + - + - transitivity V => //. now eapply m'.(model_clauses_conclusions). + - apply m'. + - apply m'. + - apply m'. + - intros x hin. apply m'. intros hv. + apply sub' in hv. now apply hin. + - intuition lsets. +Qed. *) + +Notation "#| V |" := (LevelSet.cardinal V). + +Notation loop_measure V W := (#|V|, #|V| - #|W|). + +Definition lexprod_rel := lexprod lt lt. + +#[local] Instance lexprod_rel_wf : WellFounded lexprod_rel. +Proof. + eapply (Acc_intro_generator 1000). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. +Defined. + +Section InnerLoop. + Context (V : LevelSet.t) (U : LevelSet.t) + (loop : forall (V' U' : LevelSet.t) (cls : clauses) (m : model) + (prf : [/\ clauses_conclusions cls ⊂_lset V', U' ⊂_lset V' & model_of V' m]), + lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls m). + + Definition sum_W W (f : LevelSet.elt -> nat) := + LevelSet.fold (fun w acc => acc + f w) W 0. + + Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := + sum_W W (fun w => Z.to_nat (measure_w W cls m w)). + + Lemma measure_model W cls m : + let clsdiff := cls_diff cls W in + measure W cls m = 0 -> is_model clsdiff m. + Proof using. + clear loop V U. + unfold measure, sum_W, measure_w, is_model. + set (clsdiff := Clauses.diff _ _). + intros hm. + assert (LevelSet.For_all (fun w => v_minus_w_bound W m + max_gain clsdiff <= level_value m w) W). + { move: hm. + generalize (v_minus_w_bound W m) => vbound. + eapply LevelSetProp.fold_rec. + intros. intros x hin. firstorder eauto. + intros x a s' s'' inw nins' hadd ih heq. + forward ih by lia. + intros l hin. + apply hadd in hin as []. + * subst x. lia. + * now apply ih. } + clear hm. + eapply ClausesFact.for_all_iff. tc. + intros cl hl. + unfold valid_clause. + case: Z.ltb_spec => // hk0. + destruct cl as [prem [l k]] => /=. + eapply Nat.leb_le. cbn in hk0. + rewrite /clsdiff in hl. + destruct (proj1 (Clauses.diff_spec _ _ _) hl) as [hlcls hl']. + eapply in_clauses_with_concl in hlcls as [lW incls]. + specialize (H _ lW). cbn -[clsdiff] in H. cbn in lW. + etransitivity; tea. + set (prem' := non_W_atoms W prem). + assert (ne : LevelExprSet.is_empty prem' = false). + { now eapply (non_W_atoms_ne W (prem, (l, k)) cls). } + set (preml := {| t_set := prem'; t_ne := ne |}). + assert (min_premise m prem <= min_premise m preml)%Z. + { eapply min_premise_subset. eapply non_W_atoms_subset. } + (* min_i (f(x_i)-k_i) <= max_i(f(x_i)) - min(k_i) *) + pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. + pose proof (max_premise_value_spec m preml) as [amax [exmax [inmaxpre eqmaxpre]]]. + pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. + assert (Z.to_nat (min_premise m preml) <= + (max_premise_value m preml) - premise_min preml). + { rewrite eqpminpre eqmaxpre eqminpre. + pose proof (min_atom_value_levelexpr_value m exmin). etransitivity; tea. + specialize (amax _ inminpre). rewrite eqmaxpre in amax. + assert (expmin <= exmin). specialize (apmin _ inminpre). lia. + unfold level_expr_elt in *. lia. } + transitivity (k + (max_premise_value m preml - premise_min preml)). lia. + assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff). + { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. + unfold gain. cbn. + pose proof (premise_min_subset preml prem). + rewrite !Z2Nat.inj_sub //; try lia. rewrite !Nat2Z.id. + forward H2. eapply non_W_atoms_subset. lia. } + transitivity (v_minus_w_bound W m + Z.to_nat (gain (preml, (l, k)))). + 2:lia. + unfold gain. cbn -[max_premise_value premise_min]. + assert (premise_min preml <= max_premise_value m preml). + { rewrite eqmaxpre. + move/min_premise_pos_spec: hk0 => hprem. + transitivity exmax. apply apmin => //. eapply hprem. + now apply (non_W_atoms_subset W prem). } + assert (k + (max_premise_value m preml - premise_min preml) = + (max_premise_value m preml + k - premise_min preml)) as ->. lia. + rewrite Z2Nat.inj_sub. lia. + rewrite !Nat2Z.id. + assert (max_premise_value m preml <= v_minus_w_bound W m). + { rewrite eqmaxpre. + apply v_minus_w_bound_spec. + intros hin. + have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). + rewrite levelexprset_levels_spec in hlevels. + forward hlevels. + exists exmax.2. now destruct exmax. + rewrite LevelSet.diff_spec in hlevels. + now destruct hlevels. } + lia. + Qed. + + Lemma measure_le {W cls m m'} : + model_map_outside W m m' -> + m ⩽ m' -> + (measure W cls m' <= measure W cls m). + Proof. + intros hout hle. + unfold measure, measure_w, sum_W. + rewrite (v_minus_w_bound_irrel _ _ hout). + rewrite !LevelSet.fold_spec. unfold flip. + eapply fold_left_le; unfold flip. 2:lia. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + lia. + Qed. + + Lemma measure_lt {W cls m m'} : + model_map_outside W m m' -> + m ⩽ m' -> + (exists l, [/\ LevelSet.In l W, (0 < measure_w W cls m l)%Z & level_value m l < level_value m' l]) -> + (measure W cls m' < measure W cls m). + Proof. + intros hout hle. + unfold measure, measure_w, sum_W. + rewrite (v_minus_w_bound_irrel _ _ hout). + intros hlt. + rewrite !LevelSet.fold_spec. unfold flip. + eapply fold_left_ne_lt; unfold flip. + - unfold flip. intros; lia. + - unfold flip; intros; lia. + - destruct hlt as [l [hin _]]. intros he. rewrite -LevelSetProp.elements_Empty in he. lsets. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + lia. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + lia. + - destruct hlt as [l [hinl hbound hlev]]. + exists l. rewrite LevelSet_In_elements. split => //. + intros acc acc' accle. + eapply Nat.add_le_lt_mono => //. lia. + Qed. + + Lemma is_model_equal {cls cls' m} : Clauses.Equal cls cls' -> is_model cls m -> is_model cls' m. + Proof. now intros ->. Qed. + + Lemma union_diff_eq {cls cls'} : Clauses.Equal (Clauses.union cls (Clauses.diff cls' cls)) + (Clauses.union cls cls'). + Proof. clsets. Qed. + + Lemma union_restrict_with_concl {cls W} : + Clauses.Equal (Clauses.union (cls ⇂ W) (cls ↓ W)) (cls ↓ W). + Proof. + intros cl. rewrite Clauses.union_spec. + intuition auto. + eapply in_clauses_with_concl. + now eapply in_restrict_clauses in H0 as []. + Qed. + + Lemma maps_to_level_value x (m m' : model) : + (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> + level_value m x = level_value m' x. + Proof. + intros heq. + unfold level_value. + destruct LevelMap.find eqn:hl. + apply LevelMap.find_2 in hl. rewrite heq in hl. + rewrite (LevelMap.find_1 hl) //. + destruct (LevelMap.find x m') eqn:hl' => //. + apply LevelMap.find_2 in hl'. rewrite -heq in hl'. + now rewrite (LevelMap.find_1 hl') in hl. + Qed. + + Lemma measure_Z_lt x y : + (x < y)%Z -> + (0 < y)%Z -> + Z.to_nat x < Z.to_nat y. + Proof. intros. lia. Qed. + + Lemma sum_pos W f : + (0 < sum_W W f) -> + exists w, LevelSet.In w W /\ (0 < f w). + Proof. + unfold sum_W. + eapply LevelSetProp.fold_rec => //. + intros. lia. + intros. + destruct (Nat.ltb_spec 0 a). + - destruct (H2 H4) as [w [hin hlt]]. exists w. split => //. apply H1. now right. + - exists x. split => //. apply H1. now left. lia. + Qed. + + Lemma measure_pos {W cls m} : + (0 < measure W cls m) -> + exists l, LevelSet.In l W /\ (0 < measure_w W cls m l)%Z. + Proof. + unfold measure. + move/sum_pos => [w [hin hlt]]. + exists w. split => //. lia. + Qed. + + Lemma model_of_diff cls W m : + model_of W m -> model_of (clauses_conclusions (cls_diff cls W)) m. + Proof. + intros; eapply model_of_subset; tea. + eapply clauses_conclusions_diff_left. + Qed. + Hint Resolve model_of_diff : core. + + Lemma check_model_spec_diff {cls w m w' m' w''} : + model_of w m -> + let cls := (cls_diff cls w) in + check_model cls (w'', m) = Some (w', m') -> + [/\ w'' ⊂_lset w', w' ⊂_lset (w'' ∪ w), + exists cl : clause, + let cll := levelexpr_level (concl cl) in + [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' + & level_value m cll < level_value m' cll] + & model_extension w' m m']. + Proof. + cbn; intros mof cm. + pose proof (clauses_conclusions_diff_left cls w (cls ⇂ w)). + apply check_model_spec in cm as []. + split => //. lsets. + eapply model_of_subset; tea. + Qed. + + Lemma model_of_ext {W W' m m'} : + model_of W m -> model_extension W' m m' -> model_of W m'. + Proof. + intros mof [_ dom _]. + intros k hin. apply dom. now apply mof. + Qed. + + Lemma clauses_partition_spec {cls W allW conclW} : + clauses_conclusions cls ⊂_lset W -> + Clauses.partition (premise_restricted_to W) cls = (allW, conclW) -> + (Clauses.Equal allW (cls ⇂ W)) /\ + (Clauses.Equal conclW (Clauses.diff cls (cls ⇂ W))). + Proof. + intros clW. + destruct Clauses.partition eqn:eqp. + intros [= <- <-]. + change t with (t, t0).1. + change t0 with (t, t0).2 at 2. + rewrite -eqp. clear t t0 eqp. + split. + - intros cl. rewrite Clauses.partition_spec1. + rewrite in_restrict_clauses Clauses.filter_spec. + rewrite /premise_restricted_to LevelSet.subset_spec. firstorder eauto. + apply clW, clauses_conclusions_spec. now exists cl. + - intros cl. rewrite Clauses.partition_spec2. + rewrite Clauses.filter_spec Clauses.diff_spec. + rewrite /premise_restricted_to. intuition auto. + move/negbTE: H1. eapply eq_true_false_abs. + eapply LevelSet.subset_spec. + now eapply in_restrict_clauses in H as []. + apply eq_true_not_negb. move/LevelSet.subset_spec => he. + apply H1. apply in_restrict_clauses. split => //. + apply clW, clauses_conclusions_spec. now exists cl. + Qed. + + Lemma clauses_conclusions_eq cls W : + clauses_conclusions cls ⊂_lset W -> + Clauses.Equal cls (cls ↓ W). + Proof. + intros cl x. + rewrite in_clauses_with_concl. intuition auto. + apply cl, clauses_conclusions_spec. now exists x. + Qed. + + Section innerloop_partition. + Context (W : LevelSet.t) (cls : clauses). + Context (premconclW conclW : clauses). + Context (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W, + Clauses.Equal premconclW (cls ⇂ W) & Clauses.Equal conclW (Clauses.diff (cls ↓ W) (cls ⇂ W))]). + + #[tactic="idtac"] + Equations? inner_loop_partition (m : model) (mW : model_of W m) : result W U cls m + by wf (measure W cls m) lt := + inner_loop_partition m mW with loop W LevelSet.empty premconclW m _ _ := { + (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) + | Loop => Loop + (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). + By invariant Wr ⊂ W *) + | Model Wr mr hsub with inspect (check_model conclW (Wr, model_model mr)) := { + | exist None eqm => Model W {| model_model := model_model mr |} _ + | exist (Some (Wconcl, mconcl)) eqm with inner_loop_partition mconcl _ := { + (* Here Wconcl ⊂ Wr by invariant *) + | Loop => Loop + | Model Wr' mr' hsub' => Model Wr' {| model_model := model_model mr' |} hsub' } + (* Here Wr' ⊂ W by invariant *) + (* We check if the new model [mr] for (cls ⇂ W) extends to a model of (cls ↓ W). *) + (* We're entitled to recursively compute a better model starting with mconcl, + as we have made the measure decrease: + some atom in W has been strictly updated in Wconcl. *) + } }. + Proof. + all:cbn [model_model]; clear loop inner_loop_partition. + all:try solve [try apply LevelSet.subset_spec; try reflexivity]. + all:try apply LevelSet.subset_spec in hsub. + all:auto. + all:try destruct prf as [WV neW UW clsW eqprem eqconcl]. + all:try solve [intuition auto]. + all:try rewrite eqconcl in eqm. + - split => //. rewrite eqprem. apply clauses_conclusions_restrict_clauses. lsets. + - left. now eapply strict_subset_cardinal. + - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. + eapply model_of_ext. 2:tea. apply mr. + - eapply (check_model_spec_diff mr) in eqm as [subwwconcl subwconcl hm hext] => //. + pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). + destruct hm as [cll [hind nvalid inwconcl hl]]. + eapply Nat.lt_le_trans. + 2:{ eapply measure_le; eapply mr. } + eapply measure_lt. + { eapply model_map_outside_weaken. eapply hext. lsets. } + { apply hext. } + eapply invalid_clause_measure in nvalid; tea. + exists (levelexpr_level (concl cll)). + split => //. + eapply clauses_conclusions_diff_left; tea. + eapply clauses_conclusions_spec. exists cll; split => //. exact hind. + - apply mr'. + (* - apply clauses_conclusions_clauses_with_concl. *) + - apply mr'. + - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. + eapply model_ext_trans_weaken. 2:apply mr. lsets. + transitivity mconcl. eapply model_extension_weaken. 2:tea. lsets. apply mr'. + - apply mr. + (* - eapply clauses_conclusions_clauses_with_concl. *) + - rewrite check_model_is_model in eqm. + 1:{ eapply model_of_diff, mr. } + have okm := (model_ok mr). + have mu := is_model_union okm eqm. + rewrite {1}eqprem in mu. + rewrite union_diff_eq in mu. + rewrite union_restrict_with_concl in mu. + now rewrite (clauses_conclusions_eq _ _ clsW). + - apply mr. + - split; lsets. + Qed. + End innerloop_partition. + + (* We first partition the clauses among those that mention only W and the ones that can mention other atoms. + We then call the loop on these two sets of clauses, which not need to change during the recursive calls. + *) + #[tactic="idtac"] + Equations? inner_loop (W : LevelSet.t) (cls : clauses) (m : model) + (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & model_of W m]) : + result W U cls m := + inner_loop W cls m prf with inspect (Clauses.partition (premise_restricted_to W) cls) := + | exist (premconclW, conclW) eqp => inner_loop_partition W cls premconclW conclW _ m _. + Proof. + - destruct prf as [subWV neW UW clsW mW]. + eapply (clauses_partition_spec clsW) in eqp as [eqprem eqconcl]. + split => //. now rewrite -(clauses_conclusions_eq _ _ clsW). + - apply prf. + Qed. + +End InnerLoop. + +Lemma diff_cardinal_inter V W : #|LevelSet.diff V W| = #|V| - #|LevelSet.inter V W|. +Proof. + pose proof (LevelSetProp.diff_inter_cardinal V W). lia. +Qed. + +Lemma diff_cardinal V W : W ⊂_lset V -> #|LevelSet.diff V W| = #|V| - #|W|. +Proof. + intros hsub. + rewrite diff_cardinal_inter LevelSetProp.inter_sym LevelSetProp.inter_subset_equal //. +Qed. + +Lemma is_modelP m cls : reflect (Clauses.For_all (valid_clause m) cls) (is_model cls m). +Proof. + case E: is_model; constructor. + - now move: E; rewrite /is_model -ClausesFact.for_all_iff. + - intros hf. apply ClausesFact.for_all_iff in hf; tc. unfold is_model in E; congruence. +Qed. + +Lemma is_model_invalid_clause cl cls m : is_model cls m -> ~~ valid_clause m cl -> ~ Clauses.In cl cls. +Proof. + move/is_modelP => ism /negP valid hin. + now specialize (ism _ hin). +Qed. + +Lemma strict_subset_leq_right U V W : + strict_subset U V -> V ⊂_lset W -> strict_subset U W. +Proof. + intros [] le. split. lsets. intros eq. rewrite -eq in le. + apply H0. lsets. +Qed. + +Lemma strict_subset_diff_incl V W W' : + strict_subset W' W -> + W ⊂_lset V -> + W' ⊂_lset V -> + strict_subset (LevelSet.diff V W) (LevelSet.diff V W'). +Proof. + intros [] lew lew'. + split. lsets. + intros eq. + apply H0. lsets. +Qed. + +(* To help equations *) +Opaque lexprod_rel_wf. + +Lemma check_model_spec_V {V cls w m w' m'} : + model_of V m -> clauses_conclusions cls ⊂_lset V -> + check_model cls (w, m) = Some (w', m') -> + check_model_invariants cls w m w' m' true. +Proof. + cbn; intros mof incl cm. + apply check_model_spec in cm => //. + eapply model_of_subset; tea. +Qed. + +Lemma valid_model_of {V W m cls} (m' : valid_model W m cls) : + model_of V m -> model_of V (model_model m'). +Proof. + intros mof. eapply model_of_ext; tea. eapply m'. +Qed. + +#[tactic="idtac"] +Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (m : model) + (prf : [/\ clauses_conclusions cls ⊂_lset V, U ⊂_lset V & model_of V m]) : result V U cls m + by wf (loop_measure V U) lexprod_rel := + loop V U cls m prf with inspect (check_model cls (U, m)) := + | exist None eqm => Model U {| model_model := m |} _ + | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { + | exist true eq := Loop + (* Loop on cls ↓ W, with |W| < |V| *) + | exist false neq with inner_loop V U loop W (cls ↓ W) m' _ := + { | Loop := Loop + | Model Wc mwc hsub' + (* We get a model for (cls ↓ W), we check if it extends to all clauses. + By invariant |Wc| cannot be larger than |W|. *) + with inspect (check_model cls (Wc, mwc.(model_model))) := + { | exist None eqm' => Model Wc {| model_model := mwc.(model_model) |} _ + | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { + | exist true _ := Loop + | exist false neq' with loop V Wcls cls mcls _ := { + (* Here Wcls < V, we've found a model for all of the clauses with conclusion + in W, which can now be fixed. We concentrate on the clauses whose + conclusion is different. Clearly |W| < |V|, but |Wcls| is not + necessarily < |V| *) + | Loop := Loop + | Model Wvw mcls' hsub'' := Model Wvw {| model_model := model_model mcls' |} _ } } } + } + } + . +Proof. + all:clear loop. + all:try solve [intuition auto]. + all:try eapply levelset_neq in neq. + all:have cls_sub := clauses_conclusions_levels cls. + all:destruct prf as [clsV UV mof]. + - apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. + split => //. split => //. lsets. + destruct hcl as [l [hl _]]. intros he. lsets. + apply clauses_conclusions_clauses_with_concl. + eapply model_of_ext; tea. eapply model_of_subset; tea. lsets. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply check_model_spec in eqm' as []. + 2:{ eapply model_of_subset. 2:exact clsV. + exact (valid_model_of mwc (model_of_ext mof ext)). } + split. lsets. lsets. + exact (model_of_ext (valid_model_of mwc (model_of_ext mof ext)) H2). + - right. + eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply check_model_spec in eqm' as []. + 2:{ eapply model_of_subset. 2:exact clsV. + exact (valid_model_of mwc (model_of_ext mof ext)). } + destruct hsub' as [UWc WcW]. + assert (Wcls ⊂_lset V). lsets. + rewrite -!diff_cardinal //. + eapply strict_subset_cardinal. + assert (strict_subset Wc Wcls). + { split => //. + destruct H1 as [cl [clcls nvalid hcll hv]]. + pose proof (model_ok mwc). + eapply is_model_invalid_clause in H1; tea. + assert (~ LevelSet.In (levelexpr_level (concl cl)) W). + { intros hin. rewrite in_clauses_with_concl in H1. intuition auto. } + move/(_ (levelexpr_level (concl cl))) => [] wcwcls wclswc. + now apply H4, WcW, wclswc. } + eapply (strict_subset_leq_right _ (LevelSet.diff V Wc)). + 2:{ clear -UWc WcW UW WU H3 H4. lsets. } + apply strict_subset_diff_incl => //. clear -H H3; lsets. + - eapply mcls'. + - auto. + - exact mcls'. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply check_model_spec in eqm' as []. + 2:{ eapply model_of_subset. 2:exact clsV. + exact (valid_model_of mwc (model_of_ext mof ext)). } + assert (WV : W ⊂_lset V). + { clear -UV clsV WU; lsets. } + eapply model_ext_trans_weaken => //. 2:tea. auto. + transitivity mcls; [|apply mcls']. + transitivity (model_model mwc). 2:{ eapply model_extension_weaken; [|tea]. lsets. } + eapply model_extension_weaken. 2:apply mwc. auto. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply check_model_spec in eqm' as []. + 2:{ eapply model_of_subset. 2:exact clsV. + exact (valid_model_of mwc (model_of_ext mof ext)). } + split. lsets. lsets. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + refine (valid_model_of mwc _). + refine (model_of_ext mof ext). + - auto. + - rewrite check_model_is_model // in eqm'. + eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + refine (valid_model_of mwc _). + eapply model_of_subset. + refine (model_of_ext mof ext). auto. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + transitivity m'. eapply model_extension_weaken; [|tea]. lsets. + eapply model_extension_weaken. 2:apply mwc. lsets. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + split; lsets. + - exact mof. + - exact clsV. + - apply check_model_is_model in eqm; eauto. + eapply model_of_subset; tea. + - reflexivity. + - split; lsets. +Qed. + +Transparent lexprod_rel_wf. + +Definition zero_model levels := + LevelSet.fold (fun l acc => LevelMap.add l 0 acc) levels (LevelMap.empty _). + +Definition add_max l k m := + match LevelMap.find l m with + | Some k' => + if k' LevelMap.add l k m + end. + +#[local] Instance proper_levelexprset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) + levels. +Proof. + intros s s' eq l. + rewrite !levelexprset_levels_spec. + firstorder eauto. +Qed. + +Lemma In_add_max l l' k acc : + LevelMap.In (elt:=nat) l (add_max l' k acc) <-> + (l = l' \/ LevelMap.In l acc). +Proof. + unfold add_max. + destruct LevelMap.find eqn:hl. + case: Nat.ltb_spec. + - rewrite LevelMapFact.F.add_in_iff /Level.eq. + firstorder eauto. + - intros. intuition auto. subst. + now rewrite LevelMapFact.F.in_find_iff hl. + - LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. +Qed. + +Lemma In_fold_add_max k n a : + LevelMap.In (elt:=nat) k + (LevelExprSet.fold + (fun '(l, k0) (acc : LevelMap.t nat) => add_max l k0 acc) n a) <-> + (LevelSet.In k (levels n)) \/ LevelMap.In k a. +Proof. + eapply LevelExprSetProp.fold_rec. + - intros s' he. + rewrite (LevelExprSetProp.empty_is_empty_1 he). + cbn. unfold levels. rewrite LevelExprSetProp.fold_empty. rewrite LevelSetFact.empty_iff. intuition auto. + - intros. + destruct x as [l k']. + rewrite In_add_max. + rewrite H2 !levelexprset_levels_spec. + split. + * intros []; subst. + left. exists k'. apply H1. now left. + destruct H3 as [[k'' ?]|?]. left; exists k''. apply H1. now right. + now right. + * red in H1. setoid_rewrite H1. + intros [[k'' []]|]. noconf H3. now left. + right. now left; exists k''. right; right. apply H3. +Qed. + + +(* To handle the constraint checking decision problem, + we must start with a model where all atoms [l + k] + appearing in premises are true. Otherwise the + [l := 0] model is minimal for [l+1-> l+2]. + Starting with [l := 1], we see that the minimal model above it + has [l := ∞]. + We also ensure that all levels in the conclusions are in the model. + + *) + +Definition min_model_map (m : LevelMap.t nat) cls : LevelMap.t nat := + Clauses.fold (fun '(cl, concl) acc => + LevelExprSet.fold (fun '(l, k) acc => + add_max l k acc) cl (add_max (levelexpr_level concl) 0 acc)) cls m. + +Lemma min_model_map_levels m cls k : + LevelMap.In k (min_model_map m cls) <-> + LevelSet.In k (clauses_levels cls) \/ LevelMap.In k m. +Proof. + rewrite /min_model_map. + rewrite clauses_levels_spec. + eapply ClausesProp.fold_rec. + - intros s' he. intuition auto. + destruct H0 as [cl []]. + clsets. + - intros x a s' s'' inx ninx hadd ih. + destruct x as [cl k']. + rewrite In_fold_add_max In_add_max. rewrite ih. + intuition auto. left. exists (cl, k'); intuition auto. + apply hadd. now left. + rewrite clause_levels_spec. now left. + subst. left. exists (cl, k'). split. apply hadd; now left. + rewrite clause_levels_spec. now right. + destruct H as [cl'' []]. left. exists cl''. + intuition auto. apply hadd. now right. + destruct H3 as [cl'' []]. + apply hadd in H0 as []; subst. + rewrite clause_levels_spec in H3. destruct H3; subst. + cbn in H0. now left. right. now left. + right. right. left; exists cl''. split => //. +Qed. + +Definition min_model m cls : model := min_model_map m cls. + +Definition init_model cls := min_model (LevelMap.empty _) cls. + +Lemma init_model_levels cls k : + LevelMap.In k (init_model cls) <-> LevelSet.In k (clauses_levels cls). +Proof. + rewrite min_model_map_levels. intuition auto. + now rewrite LevelMapFact.F.empty_in_iff in H0. +Qed. + +Definition init_w (levels : LevelSet.t) : LevelSet.t := LevelSet.empty. + +(* We don't need predecessor clauses as they are trivially satisfied *) +(* Definition add_predecessors (V : LevelSet.t) cls := + LevelSet.fold (fun l acc => + Clauses.add (NonEmptySetFacts.singleton (l, 1), (l, 0)) acc) V cls. *) + +Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). + +Equations? infer (cls : clauses) : infer_result (clauses_levels cls) cls := + infer cls := loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (And3 _ _ _). +Proof. + - now eapply clauses_conclusions_levels. + - lsets. + - now eapply init_model_levels. +Qed. + +Definition valuation_of_model (m : model) : LevelMap.t nat := + let max := LevelMap.fold (fun l k acc => Nat.max k acc) m 0 in + LevelMap.fold (fun l k acc => LevelMap.add l (max - k) acc) m (LevelMap.empty _). + +Definition print_result {V cls} (m : infer_result V cls) := + match m with + | Loop => "looping" + | Model w m _ => "satisfiable with model: " ^ print_level_nat_map m.(model_model) ^ nl ^ " W = " ^ + print_lset w + ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model m.(model_model)) + end. + +Definition valuation_of_result {V cls} (m : infer_result V cls) := + match m with + | Loop => "looping" + | Model w m _ => print_level_nat_map (valuation_of_model m.(model_model)) + end. + +Definition to_string_expr (e : LevelExpr.t) : string := + let '(l, n) := e in Level.to_string l ^ (if n is 0 then "" else "+" ^ string_of_nat n). + +Definition print_premise (l : nonEmptyLevelExprSet) : string := + let (e, exprs) := NonEmptySetFacts.to_nonempty_list l in + to_string_expr e ^ + match exprs with + | [] => "" + | l => ", " ^ print_list to_string_expr ", " exprs + end. + +Definition print_clauses (cls : clauses) := + let list := Clauses.elements cls in + print_list (fun '(l, r) => + print_premise l ^ " → " ^ to_string_expr r) nl list. + +Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) + (prf : clauses_conclusions cls ⊂_lset V /\ clauses_conclusions cls' ⊂_lset V /\ model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := + | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m _. +Proof. + split. 2:lsets. + intros x. rewrite clauses_conclusions_spec. + intros [cl [hcl hl]]. + rewrite Clauses.union_spec in hcl. destruct hcl. + - apply H, clauses_conclusions_spec. exists cl => //. + - apply H0, clauses_conclusions_spec. exists cl => //. + - exact H1. +Qed. + +(* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by + setting a minimal value for the new atoms in [clauses_levels cls \ V] + such that the new clauses [cls] do not hold vacuously. +*) +Equations? infer_extension {V init cls} (m : valid_model V init cls) (cls' : clauses) : + result (LevelSet.union (clauses_levels cls') V) LevelSet.empty (Clauses.union cls cls') (min_model m.(model_model) cls') := + infer_extension m cls' := + infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model m.(model_model) cls') cls cls' _. +Proof. + repeat split. + - pose proof (model_clauses_conclusions m). lsets. + - pose proof (clauses_conclusions_levels cls'). lsets. + - red. intros. + unfold min_model. rewrite min_model_map_levels. + pose proof (model_of_V m k). + apply LevelSet.union_spec in H as []; auto. +Qed. + +Definition enforce_clauses {V init cls} (m : valid_model V init cls) cls' : option model := + match infer_extension m cls' with + | Loop => None + | Model w m _ => Some m.(model_model) + end. + +Definition enforce_clause {V init cls} (m : valid_model V init cls) cl : option model := + enforce_clauses m (Clauses.singleton cl). + +Inductive constraint_type := UnivEq | UnivLe. + +Notation constraint := (nonEmptyLevelExprSet * constraint_type * nonEmptyLevelExprSet). + +Definition enforce_constraint (cstr : constraint) (cls : clauses) : clauses := + let '(l, d, r) := cstr in + match d with + | UnivLe => + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) l cls + | UnivEq => + let cls := + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) l cls + in + let cls' := + LevelExprSet.fold (fun rk acc => Clauses.add (l, rk) acc) r cls + in cls' + end. + +Definition clauses_of_list := ClausesProp.of_list. +Definition list_of_clauses := Clauses.elements. +Definition valuation := LevelMap.t nat. + +End LoopChecking. diff --git a/template-rocq/theories/TemplateLoopChecking.v b/template-rocq/theories/TemplateLoopChecking.v new file mode 100644 index 000000000..5a962391e --- /dev/null +++ b/template-rocq/theories/TemplateLoopChecking.v @@ -0,0 +1,101 @@ +(* Distributed under the terms of the MIT license. *) + +From Stdlib Require Import ssreflect ssrbool. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils. +From MetaRocq.Common Require Import Universes. +From MetaRocq.Template Require Import LoopChecking. +From Equations Require Import Equations. +Set Equations Transparent. + +Import Universes. + +Module MoreLevel. + Import Universes. + Include Level. + + Definition reflect_eq : ReflectEq t := reflect_level. + Definition to_string := string_of_level. + +End MoreLevel. + +Module LevelMap. + Module OT := FMapOrderedType_from_UsualOrderedType Level. + Include FMapAVL.Make OT. +End LevelMap. + +Module UnivLoopChecking. + Module LoopCheck := LoopChecking MoreLevel LevelSet LevelExpr LevelExprSet LevelMap. + Include LoopCheck. +End UnivLoopChecking. + +Import UnivLoopChecking. + +Definition to_constraint (x : UnivConstraint.t) : constraint := + let '(l, d, r) := x in + let '(l, d, r) := match d with + | ConstraintType.Eq => (l, UnivEq, r) + | ConstraintType.Le k => + if (k (Universe.make' l, UnivEq, Universe.make' r) + | ConstraintType.Le k => + if (k enforce_constraint (to_constraint cstr) acc) cstrs (clauses_of_list []). + +Definition enforce_level_constraints (cstrs : ConstraintSet.t) : clauses := + ConstraintSet.fold (fun cstr acc => enforce_constraint (level_constraint_to_constraint cstr) acc) cstrs (clauses_of_list []). + +Declare Scope levelnat_scope. +Delimit Scope levelnat_scope with levelnat. +Module LevelNatMapNotation. + Import LevelMap.Raw. + Notation levelmap := (tree nat) (only parsing). + Definition parse_levelnat_map (l : list Byte.byte) : option levelmap := + None. + Definition print_levelnat_map (m : levelmap) := + let list := LevelMap.Raw.elements m in + print_list (fun '(l, w) => MoreLevel.to_string l ^ " -> " ^ string_of_nat w) nl list. + + Definition print_levelmap (l : levelmap) : list Byte.byte := + to_bytes (print_levelnat_map l). + + String Notation levelmap parse_levelnat_map print_levelmap + : levelnat_scope. +End LevelNatMapNotation. +Import LevelNatMapNotation. +Arguments LevelMap.Bst {elt} this%levelnat {is_bst}. + +Definition valuation_of_model (m : model) : LevelMap.t nat := + let max := LevelMap.fold (fun l k acc => Nat.max k acc) m 0 in + LevelMap.fold (fun l k acc => LevelMap.add l (max - k) acc) m (LevelMap.empty _). + +Definition print_level_nat_map (m : LevelMap.t nat) := + let list := LevelMap.elements m in + print_list (fun '(l, w) => string_of_level l ^ " -> " ^ string_of_nat w) nl list. + +Definition print_lset (l : LevelSet.t) := + let list := LevelSet.elements l in + print_list string_of_level " " list. + +Arguments model_model {V m cls}. + +Definition print_result {V cls} (m : infer_result V cls) := + match m with + | Loop => "looping" + | Model w m _ => "satisfiable with model: " ^ print_level_nat_map (model_model m) ^ nl ^ " W = " ^ + print_lset w + ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model (model_model m)) + end. diff --git a/template-rocq/theories/TemplateMonad/Common.v b/template-rocq/theories/TemplateMonad/Common.v index 223bc52f9..68266fe75 100644 --- a/template-rocq/theories/TemplateMonad/Common.v +++ b/template-rocq/theories/TemplateMonad/Common.v @@ -42,7 +42,7 @@ Record TMInstance@{t u r} := (* Quote the body of a definition or inductive. Its name need not be fully quaified *) ; tmQuoteInductive : kername -> TemplateMonad mutual_inductive_body -; tmQuoteUniverses : TemplateMonad ConstraintSet.t +; tmQuoteUniverses : TemplateMonad ContextSet.t ; tmQuoteConstant : kername -> bool (* bypass opacity? *) -> TemplateMonad constant_body (* unquote before making the definition *) (* FIXME take an optional universe context as well *) diff --git a/template-rocq/theories/TemplateMonad/Core.v b/template-rocq/theories/TemplateMonad/Core.v index 85e453ecb..a50ecdb28 100644 --- a/template-rocq/theories/TemplateMonad/Core.v +++ b/template-rocq/theories/TemplateMonad/Core.v @@ -53,7 +53,7 @@ Cumulative Inductive TemplateMonad@{t u} : Type@{t} -> Prop := | tmQuoteRecTransp : forall {A:Type@{t}}, A -> bool(* bypass opacity? *) -> TemplateMonad program (* Quote the body of a definition or inductive. Its name need not be fully qualified *) | tmQuoteInductive : kername -> TemplateMonad mutual_inductive_body -| tmQuoteUniverses : TemplateMonad ConstraintSet.t +| tmQuoteUniverses : TemplateMonad ContextSet.t | tmQuoteConstant : kername -> bool (* bypass opacity? *) -> TemplateMonad constant_body | tmQuoteModule : qualid -> TemplateMonad (list global_reference) | tmQuoteModFunctor : qualid -> TemplateMonad (list global_reference) diff --git a/template-rocq/theories/TemplateMonad/Extractable.v b/template-rocq/theories/TemplateMonad/Extractable.v index 1cbf07cba..4ad3433b0 100644 --- a/template-rocq/theories/TemplateMonad/Extractable.v +++ b/template-rocq/theories/TemplateMonad/Extractable.v @@ -51,7 +51,7 @@ Cumulative Inductive TM@{t} : Type@{t} -> Type := : TM mutual_inductive_body | tmQuoteConstant (nm : kername) (bypass_opacity : bool) : TM constant_body -| tmQuoteUniverses : TM ConstraintSet.t +| tmQuoteUniverses : TM ContextSet.t | tmQuoteModule : qualid -> TM (list global_reference) | tmQuoteModFunctor : qualid -> TM (list global_reference) | tmQuoteModType : qualid -> TM (list global_reference) diff --git a/test-suite/loop-checking/.gitignore b/test-suite/loop-checking/.gitignore new file mode 100644 index 000000000..19a859672 --- /dev/null +++ b/test-suite/loop-checking/.gitignore @@ -0,0 +1,7 @@ +gen-src/*.ml* +Makefile.plugin.conf +src/g_demo_plugin.ml +Makefile.plugin +Makefile.coq +Makefile.coq.conf +src/g_metacoq_loop_checking_plugin.ml \ No newline at end of file diff --git a/test-suite/loop-checking/Makefile b/test-suite/loop-checking/Makefile new file mode 100644 index 000000000..42c55bbfd --- /dev/null +++ b/test-suite/loop-checking/Makefile @@ -0,0 +1,26 @@ +all: coq plugin + +coq: Makefile.coq + $(MAKE) -f Makefile.coq + cd gen-src && ./to-lower.sh + +Makefile.coq: _CoqProject + coq_makefile -f _CoqProject -o Makefile.coq + +Makefile.plugin: _PluginProject + coq_makefile -f _PluginProject -o Makefile.plugin + +plugin: Makefile.plugin coq + $(MAKE) -f Makefile.plugin + +.PHONY: plugin + +clean: Makefile.coq Makefile.plugin + $(MAKE) -f Makefile.coq clean + $(MAKE) -f Makefile.plugin clean + +.merlin: + make -f Makefile.plugin .merlin + +cleanplugin: Makefile.plugin + make -f Makefile.plugin clean diff --git a/test-suite/loop-checking/Makefile.plugin.local b/test-suite/loop-checking/Makefile.plugin.local new file mode 100644 index 000000000..6638cb1b7 --- /dev/null +++ b/test-suite/loop-checking/Makefile.plugin.local @@ -0,0 +1,10 @@ +CAMLFLAGS+=-w -20 # Unused argument (produced by extraction) +CAMLFLAGS+=-w -33 # Unused opens +CAMLFLAGS+=-w -32 # Unused value +CAMLFLAGS+=-w -39 # Unused rec flag +CAMLFLAGS+=-w -26 # Unused variable +CAMLFLAGS+=-w -34 # Unused type +CAMLFLAGS+=-w -60 # Unused module +CAMLFLAGS+=-w -8 # Non-exhaustive pattern-matchings (BEWARE, just for extracted code) +CAMLFLAGS+=-bin-annot # For merlin +CAMLFLAGS+=-open Metacoq_template_plugin diff --git a/test-suite/loop-checking/README.md b/test-suite/loop-checking/README.md new file mode 100644 index 000000000..c1e81b9a5 --- /dev/null +++ b/test-suite/loop-checking/README.md @@ -0,0 +1,16 @@ +# Plugin to run universe checking using Bezem & Coquand's loop-checking algorithm + +This is directly based on the plugin-demo, see that plugin for documentation on how to use +the extractable template monad. + +# Universe checking + +The plugin adds a new command: + +`MetaCoq Check Universes` + +This can be used at any point in a file to launch a check that the universe constraints declared +at this point do not imply a loop and hence have a model in natural numbers. The model is printed +as output (along with timing information if `MetaCoq Set Timing` is set). + +The `theories/test.v` file performs this check on all files in the Coq Standard Library. \ No newline at end of file diff --git a/test-suite/loop-checking/_CoqProject b/test-suite/loop-checking/_CoqProject new file mode 100644 index 000000000..efa2df823 --- /dev/null +++ b/test-suite/loop-checking/_CoqProject @@ -0,0 +1,9 @@ +-R ../../template-coq/theories MetaCoq.Template +-I ../../template-coq/build +-R theories MetaCoq.LoopChecking + +theories/LoopCheckingPlugin.v +theories/Extraction.v + +# For testing +theories/all_stdlib.v \ No newline at end of file diff --git a/test-suite/loop-checking/_PluginProject b/test-suite/loop-checking/_PluginProject new file mode 100644 index 000000000..07f6e92c3 --- /dev/null +++ b/test-suite/loop-checking/_PluginProject @@ -0,0 +1,20 @@ +-R ../../template-coq/theories MetaCoq.Template +-I ../../template-coq/build + +-I src +-I gen-src +-R theories MetaCoq.LoopChecking + +src/g_metacoq_loop_checking_plugin.mlg +src/metacoq_loop_checking_plugin.mlpack + +theories/Loader.v +test/test.v + +# given by [ls -1 gen-src/*.ml gen-src/*.mli] +gen-src/loopChecking.ml +gen-src/loopChecking.mli +gen-src/templateLoopChecking.ml +gen-src/templateLoopChecking.mli +gen-src/loopCheckingPlugin.mli +gen-src/loopCheckingPlugin.ml diff --git a/test-suite/loop-checking/gen-src/to-lower.sh b/test-suite/loop-checking/gen-src/to-lower.sh new file mode 100755 index 000000000..ad8e3c9eb --- /dev/null +++ b/test-suite/loop-checking/gen-src/to-lower.sh @@ -0,0 +1,10 @@ +for i in *.ml* +do + newi=`echo $i | cut -b 1 | tr '[:upper:]' '[:lower:]'``echo $i | cut -b 2-`; + if [ $i != $newi ] + then + echo "Moving " $i "to" $newi; + mv $i tmp; + mv tmp $newi; + fi +done diff --git a/test-suite/loop-checking/src/g_metacoq_loop_checking_plugin.mlg b/test-suite/loop-checking/src/g_metacoq_loop_checking_plugin.mlg new file mode 100644 index 000000000..31e6228d9 --- /dev/null +++ b/test-suite/loop-checking/src/g_metacoq_loop_checking_plugin.mlg @@ -0,0 +1,11 @@ +{ +open Stdarg +open LoopCheckingPlugin +} + +DECLARE PLUGIN "metacoq_loop_checking_plugin" + +VERNAC COMMAND EXTEND Check_universes CLASSIFIED AS QUERY STATE program + | [ "MetaCoq" "Check" "Universes" ] -> + { Run_extractable.run_vernac check_universes } +END diff --git a/test-suite/loop-checking/src/metacoq_loop_checking_plugin.mlpack b/test-suite/loop-checking/src/metacoq_loop_checking_plugin.mlpack new file mode 100644 index 000000000..6343fc0c0 --- /dev/null +++ b/test-suite/loop-checking/src/metacoq_loop_checking_plugin.mlpack @@ -0,0 +1,4 @@ +LoopChecking +TemplateLoopChecking +LoopCheckingPlugin +G_metacoq_loop_checking_plugin diff --git a/test-suite/loop-checking/test/test.v b/test-suite/loop-checking/test/test.v new file mode 100644 index 000000000..5d6f624fe --- /dev/null +++ b/test-suite/loop-checking/test/test.v @@ -0,0 +1,7 @@ +Require Import Coq.Strings.String. +Require Import MetaCoq.LoopChecking.Loader. +Require Import MetaCoq.LoopChecking.all_stdlib. + +Set MetaCoq Timing. + +Time MetaCoq Check Universes. diff --git a/test-suite/loop-checking/theories/Extraction.v b/test-suite/loop-checking/theories/Extraction.v new file mode 100644 index 000000000..32cd0d80d --- /dev/null +++ b/test-suite/loop-checking/theories/Extraction.v @@ -0,0 +1,13 @@ +Require Import Template.Extraction. +From MetaCoq.LoopChecking Require Import LoopCheckingPlugin. + +Extract Constant BinInt.Z.of_nat => "(fun x -> x)". +Extract Constant BinInt.Z.to_nat => "(fun x -> x)". + +Cd "gen-src". + +Extraction Library LoopChecking. +Extraction Library TemplateLoopChecking. +Extraction Library LoopCheckingPlugin. + +Cd "..". diff --git a/test-suite/loop-checking/theories/Loader.v b/test-suite/loop-checking/theories/Loader.v new file mode 100644 index 000000000..390de9d74 --- /dev/null +++ b/test-suite/loop-checking/theories/Loader.v @@ -0,0 +1,2 @@ +From MetaCoq.Template Require ExtractableLoader. +Declare ML Module "metacoq_loop_checking_plugin". diff --git a/test-suite/loop-checking/theories/LoopCheckingPlugin.v b/test-suite/loop-checking/theories/LoopCheckingPlugin.v new file mode 100644 index 000000000..12a517202 --- /dev/null +++ b/test-suite/loop-checking/theories/LoopCheckingPlugin.v @@ -0,0 +1,28 @@ +Require Import Coq.Lists.List. +From MetaCoq.Template Require Import + bytestring Ast + Loader + TemplateMonad.Extractable. +Import TemplateMonad.Extractable. +From MetaCoq Require Import utils Template.BasicAst Template.AstUtils Ast TemplateLoopChecking. + +Definition time : forall {A} {B : A -> Type}, string -> (forall x : A, B x) -> forall x : A, B x := + fun A B s f x => f x. + +Extract Constant time => + "(fun c f x -> let s = Caml_bytestring.caml_string_of_bytestring c in Tm_util.time (Pp.str s) f x)". + +Open Scope bs_scope. + +Import MCMonadNotation. +Local Open Scope monad_scope. + +Global Instance TemplateMonad_Monad@{t u} : Monad@{t u} TM@{t} := + {| ret := @tmReturn ; bind := @tmBind |}. + +Definition check_universes : TM unit := + tmQuoteUniverses >>= fun ctx => + let clauses := time "building clauses" enforce_level_constraints (snd ctx) in + tmMsg (string_of_nat (LevelSet.cardinal (fst ctx)) ++ " universes and " ++ string_of_nat (ConstraintSet.cardinal (snd ctx)) ++ " constraints") ;; + let result := time "loop-checking" TemplateLoopChecking.UnivLoopChecking.infer clauses in + tmMsg (print_result result). diff --git a/test-suite/loop-checking/theories/all_stdlib.v b/test-suite/loop-checking/theories/all_stdlib.v new file mode 100644 index 000000000..90864a94f --- /dev/null +++ b/test-suite/loop-checking/theories/all_stdlib.v @@ -0,0 +1,559 @@ +Require Strings.Ascii +Strings.String +Strings.BinaryString +Strings.OctalString +Strings.ByteVector +Strings.Byte +Strings.HexString +ssrmatching.ssrmatching +ZArith.Zhints +ZArith.Zdigits +ZArith.Zorder +ZArith.Zminmax +ZArith.ZArith +ZArith.Wf_Z +ZArith.Zcompare +ZArith.Zabs +ZArith.Zeven +ZArith.Zmin +ZArith.Znumtheory +ZArith.Znat +ZArith.Zmisc +ZArith.Zbool +ZArith.Zpow_alt +ZArith.Zeuclid +ZArith.Zwf +ZArith.Zpower +ZArith.Zdiv +ZArith.ZArith_dec +ZArith.BinIntDef +ZArith.Zcomplements +ZArith.Int +ZArith.BinInt +ZArith.Zpow_def +ZArith.Zpow_facts +ZArith.Zgcd_alt +ZArith.ZArith_base +ZArith.Zmax +ZArith.auxiliary +ZArith.Zquot +setoid_ring.Field_tac +setoid_ring.Algebra_syntax +setoid_ring.Field_theory +setoid_ring.Ncring +setoid_ring.BinList +setoid_ring.Cring +setoid_ring.ArithRing +setoid_ring.ZArithRing +setoid_ring.Ncring_tac +setoid_ring.RealField +setoid_ring.Ring +setoid_ring.Ring_base +setoid_ring.Ncring_initial +setoid_ring.Rings_Z +setoid_ring.Ring_tac +setoid_ring.NArithRing +setoid_ring.InitialRing +setoid_ring.Rings_Q +setoid_ring.Integral_domain +setoid_ring.Field +setoid_ring.Ncring_polynom +setoid_ring.Ring_polynom +setoid_ring.Rings_R +setoid_ring.Ring_theory +NArith.NArith +NArith.Nsqrt_def +NArith.Ndigits +NArith.Ngcd_def +NArith.Nnat +NArith.Ndec +NArith.Ndist +NArith.BinNat +NArith.BinNatDef +NArith.Ndiv_def +Unicode.Utf8 +Unicode.Utf8_core +Setoids.Setoid +Init.Decimal +Init.Specif +Init.Number +Init.Logic +Init.Tauto +Init.Peano +Init.Notations +Init.Tactics +Init.Wf +Init.Byte +Init.Ltac +Init.Prelude +Init.Datatypes +Init.Hexadecimal +Init.Nat +Numbers.AltBinNotations +Numbers.NatInt.NZDomain +Numbers.NatInt.NZBits +Numbers.NatInt.NZBase +Numbers.NatInt.NZAdd +Numbers.NatInt.NZAddOrder +Numbers.NatInt.NZLog +Numbers.NatInt.NZAxioms +Numbers.NatInt.NZProperties +Numbers.NatInt.NZGcd +Numbers.NatInt.NZMul +Numbers.NatInt.NZOrder +Numbers.NatInt.NZParity +Numbers.NatInt.NZMulOrder +Numbers.NatInt.NZSqrt +Numbers.NatInt.NZDiv +Numbers.NatInt.NZPow +Numbers.DecimalPos +Numbers.Natural.Binary.NBinary +Numbers.Natural.Abstract.NIso +Numbers.Natural.Abstract.NOrder +Numbers.Natural.Abstract.NLcm +Numbers.Natural.Abstract.NAddOrder +Numbers.Natural.Abstract.NStrongRec +Numbers.Natural.Abstract.NAdd +Numbers.Natural.Abstract.NSub +Numbers.Natural.Abstract.NSqrt +Numbers.Natural.Abstract.NProperties +Numbers.Natural.Abstract.NMulOrder +Numbers.Natural.Abstract.NBase +Numbers.Natural.Abstract.NMaxMin +Numbers.Natural.Abstract.NParity +Numbers.Natural.Abstract.NBits +Numbers.Natural.Abstract.NLog +Numbers.Natural.Abstract.NGcd +Numbers.Natural.Abstract.NAxioms +Numbers.Natural.Abstract.NDiv +Numbers.Natural.Abstract.NPow +Numbers.Natural.Abstract.NDefOps +Numbers.Natural.Peano.NPeano +Numbers.DecimalQ +Numbers.DecimalN +Numbers.HexadecimalNat +Numbers.DecimalR +Numbers.HexadecimalZ +Numbers.DecimalFacts +Numbers.HexadecimalPos +Numbers.DecimalString +Numbers.BinNums +Numbers.Integer.Binary.ZBinary +Numbers.Integer.NatPairs.ZNatPairs +Numbers.Integer.Abstract.ZDivEucl +Numbers.Integer.Abstract.ZAddOrder +Numbers.Integer.Abstract.ZLcm +Numbers.Integer.Abstract.ZBase +Numbers.Integer.Abstract.ZBits +Numbers.Integer.Abstract.ZDivFloor +Numbers.Integer.Abstract.ZAdd +Numbers.Integer.Abstract.ZSgnAbs +Numbers.Integer.Abstract.ZProperties +Numbers.Integer.Abstract.ZLt +Numbers.Integer.Abstract.ZDivTrunc +Numbers.Integer.Abstract.ZMul +Numbers.Integer.Abstract.ZGcd +Numbers.Integer.Abstract.ZAxioms +Numbers.Integer.Abstract.ZParity +Numbers.Integer.Abstract.ZMaxMin +Numbers.Integer.Abstract.ZMulOrder +Numbers.Integer.Abstract.ZPow +Numbers.HexadecimalQ +Numbers.NumPrelude +Numbers.HexadecimalFacts +Numbers.HexadecimalN +Numbers.HexadecimalString +Numbers.NaryFunctions +Numbers.Cyclic.Abstract.NZCyclic +Numbers.Cyclic.Abstract.CyclicAxioms +Numbers.Cyclic.Abstract.DoubleType +Numbers.Cyclic.Abstract.CarryType +Numbers.Cyclic.Int63.Sint63 +Numbers.Cyclic.Int63.Cyclic63 +Numbers.Cyclic.Int63.Uint63 +Numbers.Cyclic.Int63.PrimInt63 +Numbers.Cyclic.Int63.Ring63 +Numbers.Cyclic.Int31.Ring31 +Numbers.Cyclic.Int31.Int31 +Numbers.Cyclic.Int31.Cyclic31 +Numbers.Cyclic.ZModulo.ZModulo +Numbers.DecimalNat +Numbers.DecimalZ +Numbers.HexadecimalR +Reals.Rfunctions +Reals.Rgeom +Reals.SeqSeries +Reals.Rbase +Reals.Runcountable +Reals.Ranalysis4 +Reals.RiemannInt +Reals.Rregisternames +Reals.Alembert +Reals.RiemannInt_SF +Reals.Sqrt_reg +Reals.R_sqrt +Reals.R_Ifp +Reals.Rminmax +Reals.Rlimit +Reals.Rtrigo_def +Reals.Rtrigo_fun +Reals.AltSeries +Reals.Ranalysis3 +Reals.Rtopology +Reals.Rlogic +Reals.Cos_plus +Reals.DiscrR +Reals.SplitAbsolu +Reals.ROrderedType +Reals.Cauchy.ConstructiveCauchyAbs +Reals.Cauchy.ConstructiveCauchyRealsMult +Reals.Cauchy.ConstructiveExtra +Reals.Cauchy.ConstructiveCauchyReals +Reals.Cauchy.PosExtra +Reals.Cauchy.QExtra +Reals.Cauchy.ConstructiveRcomplete +Reals.Ratan +Reals.Rpow_def +Reals.Rdefinitions +Reals.Ranalysis +Reals.R_sqr +Reals.Abstract.ConstructiveReals +Reals.Abstract.ConstructiveLUB +Reals.Abstract.ConstructivePower +Reals.Abstract.ConstructiveSum +Reals.Abstract.ConstructiveAbs +Reals.Abstract.ConstructiveLimits +Reals.Abstract.ConstructiveRealsMorphisms +Reals.Abstract.ConstructiveMinMax +Reals.Machin +Reals.Rcomplete +Reals.Cos_rel +Reals.Ranalysis2 +Reals.Rprod +Reals.Rtrigo_alt +Reals.ClassicalConstructiveReals +Reals.RList +Reals.RIneq +Reals.Rtrigo1 +Reals.Rderiv +Reals.Rtrigo +Reals.Rsqrt_def +Reals.Integration +Reals.Rtrigo_facts +Reals.Reals +Reals.SeqProp +Reals.Rsigma +Reals.Exp_prop +Reals.PSeries_reg +Reals.Rbasic_fun +Reals.Binomial +Reals.Rseries +Reals.Ranalysis1 +Reals.Ranalysis5 +Reals.Rtrigo_calc +Reals.Cauchy_prod +Reals.PartSum +Reals.Raxioms +Reals.SplitRmult +Reals.ClassicalDedekindReals +Reals.ArithProp +Reals.NewtonInt +Reals.MVT +Reals.Rpower +Reals.Rtrigo_reg +Reals.Ranalysis_reg +Logic.FinFun +Logic.WKL +Logic.Classical +Logic.ClassicalUniqueChoice +Logic.HLevels +Logic.Decidable +Logic.FunctionalExtensionality +Logic.JMeq +Logic.Hurkens +Logic.EqdepFacts +Logic.StrictProp +Logic.ProofIrrelevance +Logic.Classical_Prop +Logic.WeakFan +Logic.SetIsType +Logic.ChoiceFacts +Logic.PropExtensionality +Logic.PropFacts +Logic.ProofIrrelevanceFacts +Logic.ClassicalFacts +Logic.Description +Logic.ClassicalChoice +Logic.ClassicalEpsilon +Logic.IndefiniteDescription +Logic.PropExtensionalityFacts +Logic.Eqdep +Logic.Classical_Pred_Type +Logic.Berardi +Logic.ClassicalDescription +Logic.Eqdep_dec +Logic.ExtensionalityFacts +Logic.ConstructiveEpsilon +Logic.ExtensionalFunctionRepresentative +Logic.Diaconescu +Logic.Epsilon +Logic.RelationalChoice +Logic.SetoidChoice +funind.FunInd +funind.Recdef +Wellfounded.Disjoint_Union +Wellfounded.Wellfounded +Wellfounded.Transitive_Closure +Wellfounded.Well_Ordering +Wellfounded.Union +Wellfounded.Lexicographic_Product +Wellfounded.Inclusion +Wellfounded.Lexicographic_Exponentiation +Wellfounded.Inverse_Image +PArith.BinPosDef +PArith.Pnat +PArith.PArith +PArith.BinPos +PArith.POrderedType +Classes.RelationPairs +Classes.CRelationClasses +Classes.EquivDec +Classes.Equivalence +Classes.Init +Classes.Morphisms_Relations +Classes.Morphisms_Prop +Classes.Morphisms +Classes.RelationClasses +Classes.CMorphisms +Classes.SetoidDec +Classes.SetoidTactics +Classes.SetoidClass +Classes.CEquivalence +Classes.DecidableClass +Array.PArray +QArith.Qfield +QArith.QArith_base +QArith.Qround +QArith.Qabs +QArith.Qpower +QArith.Qreals +QArith.Qminmax +QArith.Qring +QArith.QOrderedType +QArith.Qreduction +QArith.Qcanon +QArith.QArith +QArith.Qcabs +Lists.Streams +Lists.ListDec +Lists.ListSet +Lists.ListTactics +Lists.SetoidPermutation +Lists.StreamMemo +Lists.SetoidList +Lists.List +micromega.Lia +micromega.Lqa +micromega.ZifyPow +micromega.Psatz +micromega.ZCoeff +micromega.ZifyBool +micromega.DeclConstant +micromega.Tauto +micromega.RingMicromega +micromega.OrderedRing +micromega.ZifyN +micromega.ZifyClasses +micromega.Ztac +micromega.QMicromega +micromega.ZifyInst +micromega.RMicromega +micromega.ZifyComparison +micromega.ZifyUint63 +micromega.ZMicromega +micromega.ZArith_hints +micromega.EnvRing +micromega.Fourier_util +micromega.MExtraction +micromega.Env +micromega.ZifySint63 +micromega.Fourier +micromega.ZifyNat +micromega.Zify +micromega.Refl +micromega.Lra +micromega.VarMap +Vectors.Fin +Vectors.Vector +Vectors.VectorSpec +Vectors.VectorEq +Vectors.VectorDef +FSets.FSetEqProperties +FSets.FMapList +FSets.FSetWeakList +FSets.FMapInterface +FSets.FSetFacts +FSets.FSetList +FSets.FSets +FSets.FSetInterface +FSets.FSetAVL +FSets.FMaps +FSets.FMapPositive +FSets.FSetBridge +FSets.FSetDecide +FSets.FMapWeakList +FSets.FMapFullAVL +FSets.FSetProperties +FSets.FMapFacts +FSets.FMapAVL +FSets.FSetToFiniteSet +FSets.FSetPositive +FSets.FSetCompat +rtauto.Bintree +rtauto.Rtauto +Structures.OrdersLists +Structures.DecidableType +Structures.EqualitiesFacts +Structures.OrderedTypeEx +Structures.GenericMinMax +Structures.OrderedTypeAlt +Structures.OrderedType +Structures.OrdersFacts +Structures.OrdersEx +Structures.OrdersTac +Structures.OrdersAlt +Structures.DecidableTypeEx +Structures.Equalities +Structures.Orders +ssr.ssreflect +ssr.ssrclasses +ssr.ssrbool +ssr.ssrunder +ssr.ssrfun +ssr.ssrsetoid +derive.Derive +Sets.Integers +Sets.Powerset_facts +Sets.Relations_3 +Sets.Permut +Sets.Constructive_sets +Sets.Infinite_sets +Sets.Image +Sets.Finite_sets_facts +Sets.Powerset_Classical_facts +Sets.Multiset +Sets.Relations_1_facts +Sets.Relations_1 +Sets.Finite_sets +Sets.Ensembles +Sets.Uniset +Sets.Cpo +Sets.Relations_2_facts +Sets.Relations_2 +Sets.Classical_sets +Sets.Relations_3_facts +Sets.Powerset +Sets.Partial_Order +Bool.Bvector +Bool.BoolEq +Bool.Bool +Bool.BoolOrder +Bool.IfProp +Bool.Zerob +Bool.Sumbool +Bool.DecBool +Floats.FloatOps +Floats.FloatAxioms +Floats.SpecFloat +Floats.FloatClass +Floats.FloatLemmas +Floats.Floats +Floats.PrimFloat +Program.Basics +Program.Combinators +Program.Tactics +Program.Utils +Program.Wf +Program.Subset +Program.Program +Program.Equality +Program.Syntax +Sorting.PermutEq +Sorting.Mergesort +Sorting.Permutation +Sorting.PermutSetoid +Sorting.Heap +Sorting.CPermutation +Sorting.Sorted +Sorting.Sorting +MSets.MSetEqProperties +MSets.MSetFacts +MSets.MSetList +MSets.MSetAVL +MSets.MSetDecide +MSets.MSetWeakList +MSets.MSetToFiniteSet +MSets.MSetInterface +MSets.MSets +MSets.MSetGenTree +MSets.MSetPositive +MSets.MSetRBT +MSets.MSetProperties +Relations.Relations +Relations.Operators_Properties +Relations.Relation_Definitions +Relations.Relation_Operators +omega.OmegaLemmas +omega.PreOmega +nsatz.Nsatz +nsatz.NsatzTactic +btauto.Btauto +btauto.Reflect +btauto.Algebra +Arith.PeanoNat +Arith.Arith +Arith.Le +Arith.Gt +Arith.EqNat +Arith.Bool_nat +Arith.Lt +Arith.Factorial +Arith.Div2 +Arith.Minus +Arith.Euclid +Arith.Between +Arith.Max +Arith.Even +Arith.Wf_nat +Arith.Cantor +Arith.Arith_base +Arith.Min +Arith.Plus +Arith.Mult +Arith.Compare_dec +Arith.Peano_dec +Arith.Compare +extraction.ExtrHaskellNatNum +extraction.Extraction +extraction.ExtrOCamlInt63 +extraction.ExtrOcamlNatInt +extraction.ExtrHaskellNatInt +extraction.ExtrOcamlBasic +extraction.ExtrHaskellBasic +extraction.ExtrOcamlIntConv +extraction.ExtrOcamlChar +extraction.ExtrOCamlFloats +extraction.ExtrHaskellZNum +extraction.ExtrOcamlZBigInt +extraction.ExtrHaskellZInt +extraction.ExtrHaskellZInteger +extraction.ExtrOcamlZInt +extraction.ExtrOcamlNativeString +extraction.ExtrOcamlNatBigInt +extraction.ExtrOCamlPArray +extraction.ExtrHaskellString +extraction.ExtrOcamlString +extraction.ExtrHaskellNatInteger +Compat.Coq813 +Compat.AdmitAxiom +Compat.Coq814. diff --git a/test-suite/loop-checking/theories/loop_checking_live_test.v b/test-suite/loop-checking/theories/loop_checking_live_test.v new file mode 100644 index 000000000..0fefd2644 --- /dev/null +++ b/test-suite/loop-checking/theories/loop_checking_live_test.v @@ -0,0 +1,353 @@ +From MetaCoq.Template Require Import utils Universes TemplateLoopChecking. + +Import UnivLoopChecking. + +(* bytestring scope *) +Open Scope bs. +(* Tests using Coq's evaluation (does not scale to large examples as the loop function is producing proofs) *) + +Definition mk_level x := LevelExpr.make (Level.Level x). +Definition levela := mk_level "a". +Definition levelb := mk_level "b". +Definition levelc := mk_level "c". +Definition leveld := mk_level "d". +Definition levele := mk_level "e". + +Definition ex_levels : LevelSet.t := + LevelSetProp.of_list (List.map (LevelExpr.get_level) [levela; levelb; levelc; leveld; levele]). + +Definition mk_clause (hd : LevelExpr.t) (premise : list LevelExpr.t) (e : LevelExpr.t) : clause := + (NonEmptySetFacts.add_list premise (NonEmptySetFacts.singleton hd), e). + +(* Example from the paper *) +Definition clause1 : clause := mk_clause levela [levelb] (LevelExpr.succ levelb). +Definition clause2 : clause := mk_clause levelb [] (LevelExpr.add 3 levelc). +Definition clause3 := mk_clause (LevelExpr.add 1 levelc) [] leveld. +Definition clause4 := mk_clause levelb [LevelExpr.add 2 leveld] levele. +Definition clause5 := mk_clause levele [] levela. + +Definition ex_clauses := + clauses_of_list [clause1; clause2; clause3; clause4]. + +Definition ex_loop_clauses := + clauses_of_list [clause1; clause2; clause3; clause4; clause5]. + + +Example test := infer ex_clauses. +Example test_loop := infer ex_loop_clauses. + +Eval compute in print_result test. +Eval compute in print_result test_loop. + +(* Testing the unfolding of the loop function "by hand" *) +Definition hasFiniteModel {V U cls m} (m : result V U cls m) := + match m with + | Loop => false + | Model _ _ _ => true + end. + +Ltac hnf_eq_left := + match goal with + | |- ?x = ?y => let x' := eval hnf in x in change (x' = y) + end. + +(* Goal hasFiniteModel test. + hnf. hnf_eq_left. exact eq_refl. + unfold test. + unfold infer. + rewrite /check. + simp loop. + set (f := check_model _ _). + hnf in f. simpl in f. + unfold f. unfold inspect. + simp loop. + set (eq := LevelSet.equal _ _). + hnf in eq. unfold eq, inspect. + simp loop. + set (f' := check_model _ _). + hnf in f'. unfold f', inspect. + simp loop. + set (f'' := check_model _ _). + hnf in f''. simpl in f''. + unfold inspect, f''. simp loop. + set (eq' := LevelSet.equal _ _). + hnf in eq'. unfold eq', inspect. + simp loop. + set (cm := check_model _ _). + hnf in cm. simpl in cm. + unfold inspect, cm. simp loop. + exact eq_refl. +Qed. *) + +Eval lazy in print_result test. +Eval compute in print_result test_loop. + +Definition add_cstr (x : Universe.t) d (y : Universe.t) cstrs := + UnivConstraintSet.add (x, d, y) cstrs. + +Coercion Universe.make : LevelExpr.t >-> Universe.t. +Import ConstraintType. +Definition test_cstrs := + (add_cstr levela Eq (LevelExpr.add 1 levelb) + (add_cstr (Universe.sup levela levelc) Eq (LevelExpr.add 1 levelb) + (add_cstr levelb (ConstraintType.Le 0) levela + (add_cstr levelc (ConstraintType.Le 0) levelb + UnivConstraintSet.empty)))). + +Definition test_clauses := enforce_constraints test_cstrs. + +Definition test_levels : LevelSet.t := + LevelSetProp.of_list (List.map (LevelExpr.get_level) [levela; levelb; levelc]). + +Eval compute in print_clauses test_clauses. + +Definition test' := infer test_clauses. +Eval compute in print_result test'. +Import Universe (sup). + +Definition test_levels' : LevelSet.t := + LevelSetProp.of_list (List.map (LevelExpr.get_level) + [levela; levelb; + levelc; leveld]). + +Notation " x + n " := (LevelExpr.add n x). + +Fixpoint chain (l : list LevelExpr.t) := + match l with + | [] => UnivConstraintSet.empty + | hd :: [] => UnivConstraintSet.empty + | hd :: (hd' :: _) as tl => + add_cstr hd (Le 10) (LevelExpr.add 1 hd') (chain tl) + end. + +Definition levels_to_n n := + unfold n (fun i => (Level.Level (string_of_nat i), 0)). + +Definition test_chain := chain (levels_to_n 2). + +Eval compute in print_clauses (enforce_constraints test_chain). +Eval compute in init_model (enforce_constraints test_chain). +(** These constraints do have a finite model that makes all implications true (not vacuously) *) +Time Eval vm_compute in print_result (infer (enforce_constraints test_chain)). + +(* Eval compute in print_result test''. *) +(* Definition chainres := (infer (enforce_constraints test_chain)). *) + +(*Goal hasFiniteModel chainres. + hnf. + unfold chainres. + unfold infer. + simp loop. + set (f := check_model _ _). + compute in f. + hnf in f. simpl in f. + unfold f. unfold inspect. + simp loop. + set (eq := LevelSet.equal _ _). simpl in eq. + hnf in eq. unfold eq, inspect. + rewrite loop_clause_1_clause_2_equation_2. + set (l := loop _ _ _ _ _). + assert (l = Loop). + subst l. + simp loop. + set (f' := check_model _ _). + hnf in f'. cbn in f'. unfold update_model in f'. simpl in f'. unfold f', inspect. + cbn. + simp loop. + set (f'' := check_model _ _). + hnf in f''. simpl in f''. + unfold inspect, f''. simp loop. + set (eq' := LevelSet.equal _ _). + hnf in eq'. unfold eq', inspect. + simp loop. + set (cm := check_model _ _). + hnf in cm. simpl in cm. + unfold inspect, cm. simp loop. + exact eq_refl. +Qed. *) + +(*Goal chainres = Loop. + unfold chainres. + unfold infer. + set (levels := Clauses.fold _ _ _). + rewrite /check. + simp loop. + set (f := check_model _ _). + hnf in f. cbn in f. + unfold f. unfold inspect. + simp loop. + set (eq := LevelSet.equal _ _). + hnf in eq. unfold eq, inspect. + simp loop. + set (f' := check_model _ _). + hnf in f'. cbn in f'. unfold flip in f'. cbn in f'. + +set (f := check_model _ _). +hnf in f. cbn in f. +unfold f. cbn -[forward]. unfold flip. +unfold init_w. +rewrite unfold_forward. +set (f' := check_model _ _). +cbn in f'. unfold flip in f'. +hnf in f'. cbn in f'. +cbn. + +unfold check_model. cbn -[forward]. unfold flip. +set (f := update_value _ _). cbn in f. +unfold Nat.leb in f. hnf in f. + +Eval compute in print_result (infer ex_levels test_clauses). + +*) + +Definition test_above0 := + (add_cstr (levelc + 1) (ConstraintType.Le 0) levelc UnivConstraintSet.empty). + +Eval compute in print_clauses (enforce_constraints test_above0). +Definition testabove0 := infer (enforce_constraints test_above0). + +(** Loop c + 1 <= c *) +Eval vm_compute in print_result testabove0. + +(** Verify that no clause holds vacuously for the model *) + +Definition premise_holds (m : model) (cl : clause) := + satisfiable_premise m (premise cl). + +Definition premises_hold (cls : clauses) (m : model) : bool := + Clauses.for_all (premise_holds m) cls. + +Definition print_model_premises_hold cls (m : model) := + if premises_hold cls m then "all premises hold" + else "some premise doesn't hold". + +Definition print_premises_hold {V U cls m} (r : result V U cls m) := + match r with + | Loop => "looping" + | Model w m _ => print_model_premises_hold cls m.(model_model) + end. + +(* Is clause [c] non-vacuous and satisfied by the model? *) +Definition check_clause (m : model) (cl : clause) : bool := + satisfiable_premise m (premise cl) && satisfiable_atom m (concl cl). + +Definition check_clauses (m : model) cls : bool := + Clauses.for_all (check_clause m) cls. + +Definition check_cstr (m : model) (c : UnivConstraint.t) := + let cls := enforce_constraint (to_constraint c) (clauses_of_list []) in + check_clauses m cls. + +Definition check_cstrs (m : model) (c : UnivConstraintSet.t) := + let cls := enforce_constraints c in + check_clauses m cls. + + (* as [cl []]. + eapply Clauses.union_spec in H as []. + apply m.(model_clauses_conclusions). + rewrite clauses_conclusions_spec. now exists cl. + eapply prf. rewrite clauses_conclusions_spec. + now exists cl. +Qed. *) + +(*Equations? weaken_model (m : model) (cls : clauses) : valid_model (LevelSet.union (clauses_levels cls) V m cls) := + weaken_model m cls := + {| model_clauses := m.(model_clauses); + model_model := |}. +Proof. + rewrite LevelSet.union_spec. right. now apply m. +Qed. *) + +Definition model_variables (m : model) : LevelSet.t := + LevelMap.fold (fun l _ acc => LevelSet.add l acc) m LevelSet.empty. + +Variant enforce_result := + | Looping + | ModelExt (m : model). + +Definition enforce_cstr {V init cls} (m : valid_model V init cls) (c : UnivConstraint.t) := + let cls := enforce_constraint (to_constraint c) (clauses_of_list []) in + enforce_clauses m cls. + +Definition enforce_cstrs {V init cls} (m : valid_model V init cls) (c : UnivConstraintSet.t) := + let cls := enforce_constraints c in + enforce_clauses m cls. + +Definition initial_cstrs := + (add_cstr (sup levela levelb) Eq (levelc + 1) + (add_cstr levelc (Le 0) (sup levela levelb) + (add_cstr levelc (Le 0) levelb + UnivConstraintSet.empty))). + +Definition enforced_cstrs := + (* (add_cstr (sup levela levelb) Eq (sup (levelc + 1) leveld) *) + (add_cstr (levelb + 10) (Le 0) levele + (* (add_cstr levelc (Le 0) levelb *) + UnivConstraintSet.empty). + +Definition initial_cls := enforce_constraints initial_cstrs. +Definition enforced_cls := enforce_constraints enforced_cstrs. + +Eval vm_compute in init_model initial_cls. + +Definition abeqcS := + enforce_constraints + (add_cstr (sup levela levelb) Eq (levelc + 1) UnivConstraintSet.empty). + +Eval compute in print_clauses initial_cls. +Eval compute in print_clauses abeqcS. + +Definition test'' := infer initial_cls. +Definition testabeqS := infer abeqcS. + +Eval vm_compute in print_result test''. +Eval vm_compute in print_result testabeqS. + +Eval vm_compute in print_model_premises_hold initial_cls (init_model initial_cls). + +Ltac get_result c := + let c' := eval vm_compute in c in + match c' with + | Loop => fail "looping" + | Model ?w ?m _ => exact m + end. + +Definition model_cstrs' := ltac:(get_result test''). + +Notation "x ≡ y" := (eq_refl : x = y) (at level 70). + +Eval vm_compute in check_cstrs model_cstrs'.(model_model) initial_cstrs ≡ true. +(* Here c <= b, in the model b = 0 is minimal, and b's valuation gives 1 *) +Eval vm_compute in print_result (infer initial_cls). + +(* Here it is still the case, we started with b = 0 but move it to 10 + due to the b + 10 -> e clause, and reconsider the b -> c clause to move + c up *) +Eval vm_compute in + option_map valuation_of_model + (enforce_cstrs model_cstrs' enforced_cstrs). + +(* The whole set of constraints has a finite model with c <= b *) + +Definition all_clauses := Clauses.union initial_cls enforced_cls. + +Eval vm_compute in valuation_of_result (infer all_clauses). +Eval vm_compute in + option_map (is_model all_clauses) (option_of_result (infer all_clauses)). + +(* This is a model? *) +Eval vm_compute in enforce_cstrs model_cstrs' enforced_cstrs. +Eval vm_compute in print_clauses initial_cls. + +(** This is also a model of (the closure of) the initial clauses *) +Check (option_map (is_model initial_cls) (enforce_cstrs model_cstrs' enforced_cstrs) + ≡ Some true). + +(* And a model of the new constraints *) +Check (option_map (is_model enforced_cls) (enforce_cstrs model_cstrs' enforced_cstrs) + ≡ Some true). + +(* All premises hold *) +Eval vm_compute in + option_map (print_model_premises_hold enforced_cls) + (enforce_cstrs model_cstrs' enforced_cstrs). diff --git a/utils/theories/MRProd.v b/utils/theories/MRProd.v index 12fa5104b..90d579c0c 100644 --- a/utils/theories/MRProd.v +++ b/utils/theories/MRProd.v @@ -114,7 +114,7 @@ Variant and8 (P1 P2 P3 P4 P5 P6 P7 P8 : Type) : Type := Times8 of P1 & P2 & P3 & Variant and9 (P1 P2 P3 P4 P5 P6 P7 P8 P9 : Type) : Type := Times9 of P1 & P2 & P3 & P4 & P5 & P6 & P7 & P8 & P9. Variant and10 (P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 : Type) : Type := Times10 of P1 & P2 & P3 & P4 & P5 & P6 & P7 & P8 & P9 & P10. -#[global] Hint Constructors and3 and3 and5 and6 and7 and8 and9 : core. +#[global] Hint Constructors and3 and4 and5 and6 and7 and8 and9 : core. Notation "[ × P1 & P2 ]" := (pair P1 P2) (only parsing) : type_scope. Notation "[ × P1 , P2 & P3 ]" := (and3 P1 P2 P3) : type_scope. @@ -132,3 +132,26 @@ Notation "[ × P1 , P2 , P3 , P4 , P5 , P6 , P7 , P8 , P9 & P10 ]" := (and10 P1 Proof. econstructor; reflexivity. Defined. + +Reserved Notation "[ /\ P1 , P2 , P3 , P4 , P5 , P6 & P7 ]" (at level 0, format +"'[hv' [ /\ '[' P1 , '/' P2 , '/' P3 , '/' P4 , '/' P5 , '/' P6 ']' '/ ' & P7 ] ']'"). +Reserved Notation "[ /\ P1 , P2 , P3 , P4 , P5 , P6 , P7 & P8 ]" (at level 0, format +"'[hv' [ /\ '[' P1 , '/' P2 , '/' P3 , '/' P4 , '/' P5 , '/' P6 , '/' P7 ']' '/ ' & P8 ] ']'"). +Reserved Notation "[ /\ P1 , P2 , P3 , P4 , P5 , P6 , P7 , P8 & P9 ]" (at level 0, format +"'[hv' [ /\ '[' P1 , '/' P2 , '/' P3 , '/' P4 , '/' P5 , '/' P6 , '/' P7 , '/' P8 ']' '/ ' & P9 ] ']'"). +Reserved Notation "[ /\ P1 , P2 , P3 , P4 , P5 , P6 , P7 , P8 , P9 & P10 ]" (at level 0, format +"'[hv' [ /\ '[' P1 , '/' P2 , '/' P3 , '/' P4 , '/' P5 , '/' P6 , '/' P7 , '/' P8 , '/' P9 ']' '/ ' & P10 ] ']'"). + +Variant andP6 (P1 P2 P3 P4 P5 P6 : Prop) : Prop := conj6 of P1 & P2 & P3 & P4 & P5 & P6. +Variant andP7 (P1 P2 P3 P4 P5 P6 P7 : Prop) : Prop := conj7 of P1 & P2 & P3 & P4 & P5 & P6 & P7. +Variant andP8 (P1 P2 P3 P4 P5 P6 P7 P8 : Prop) : Prop := conj8 of P1 & P2 & P3 & P4 & P5 & P6 & P7 & P8. +Variant andP9 (P1 P2 P3 P4 P5 P6 P7 P8 P9 : Prop) : Prop := conj9 of P1 & P2 & P3 & P4 & P5 & P6 & P7 & P8 & P9. +Variant andP10 (P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 : Prop) : Prop := conj10 of P1 & P2 & P3 & P4 & P5 & P6 & P7 & P8 & P9 & P10. + +Notation "[ /\ P1 , P2 , P3 , P4 , P5 & P6 ]" := (andP6 P1 P2 P3 P4 P5 P6) : type_scope. +Notation "[ /\ P1 , P2 , P3 , P4 , P5 , P6 & P7 ]" := (andP7 P1 P2 P3 P4 P5 P6 P7) : type_scope. +Notation "[ /\ P1 , P2 , P3 , P4 , P5 , P6 , P7 & P8 ]" := (andP8 P1 P2 P3 P4 P5 P6 P7 P8) : type_scope. +Notation "[ /\ P1 , P2 , P3 , P4 , P5 , P6 , P7 , P8 & P9 ]" := (andP9 P1 P2 P3 P4 P5 P6 P7 P8 P9) : type_scope. +Notation "[ /\ P1 , P2 , P3 , P4 , P5 , P6 , P7 , P8 , P9 & P10 ]" := (andP10 P1 P2 P3 P4 P5 P6 P7 P8 P9 P10) : type_scope. + +#[global] Hint Constructors andP6 andP7 andP8 andP9 andP10 : core. diff --git a/utils/theories/bytestring.v b/utils/theories/bytestring.v index d818d9a67..247b11c5f 100644 --- a/utils/theories/bytestring.v +++ b/utils/theories/bytestring.v @@ -187,6 +187,12 @@ End String. Definition bs := String.t. Notation string := String.t. +Fixpoint to_bytes (s : string) : list Byte.byte := + match s with + | String.EmptyString => nil + | String.String b s => b :: to_bytes s + end. + Bind Scope bs_scope with bs. String Notation String.t String.parse String.print : bs_scope. From 395a8fd21f5e13e66db86cc424c98791b46d316a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 19 Jul 2025 01:02:03 +0200 Subject: [PATCH 002/164] Fix plugin --- .vscode/metarocq.code-workspace | 3 ++ common/theories/Reflect.v | 2 +- common/theories/Universes.v | 2 + template-rocq/_PluginProject.in | 6 +-- template-rocq/src/ast_denoter.ml | 2 +- template-rocq/src/tm_util.ml | 8 +-- template-rocq/theories/TemplateLoopChecking.v | 8 +-- test-suite/loop-checking/META | 8 +++ test-suite/loop-checking/Makefile | 18 +++---- .../loop-checking/Makefile.plugin.local | 3 +- test-suite/loop-checking/_CoqProject | 9 ---- test-suite/loop-checking/_PluginProject | 16 +++--- test-suite/loop-checking/_RocqProject | 9 ++++ .../src/META.rocq-metarocq-loop-checking | 10 ++++ .../src/g_metarocq_loop_checking_plugin.ml | 24 +++++++++ ...lg => g_metarocq_loop_checking_plugin.mlg} | 4 +- ...k => metarocq_loop_checking_plugin.mlpack} | 2 +- test-suite/loop-checking/test/test.v | 12 ++--- .../loop-checking/theories/Extraction.v | 4 +- test-suite/loop-checking/theories/Loader.v | 4 +- .../theories/LoopCheckingPlugin.v | 19 +++---- .../loop-checking/theories/all_stdlib.v | 49 ++----------------- 22 files changed, 114 insertions(+), 108 deletions(-) create mode 100644 test-suite/loop-checking/META delete mode 100644 test-suite/loop-checking/_CoqProject create mode 100644 test-suite/loop-checking/_RocqProject create mode 100644 test-suite/loop-checking/src/META.rocq-metarocq-loop-checking create mode 100644 test-suite/loop-checking/src/g_metarocq_loop_checking_plugin.ml rename test-suite/loop-checking/src/{g_metacoq_loop_checking_plugin.mlg => g_metarocq_loop_checking_plugin.mlg} (64%) rename test-suite/loop-checking/src/{metacoq_loop_checking_plugin.mlpack => metarocq_loop_checking_plugin.mlpack} (62%) diff --git a/.vscode/metarocq.code-workspace b/.vscode/metarocq.code-workspace index 0398c8308..4d1cba7ae 100644 --- a/.vscode/metarocq.code-workspace +++ b/.vscode/metarocq.code-workspace @@ -8,6 +8,7 @@ // A list of arguments to send to coqtop. Use seperate elements instead of spaces to seperate each argument, especially when a flag expects another trailing argument, e.g. `["-I","./bin"]` instead of `["-I ./bin"]` "coqtop.args": [ + // "-bt", // get backtraces from Rocq on errors "-R", "utils/theories", "MetaRocq.Utils", "-R", "common/theories", "MetaRocq.Common", @@ -32,6 +33,8 @@ "-R", "test-suite/plugin-demo/theories", "MetaRocq.ExtractedPluginDemo", "-I", "test-suite/plugin-demo", "-I", "test-suite/plugin-demo/src", + "-R", "test-suite/loop-checking/theories", "MetaRocq.LoopChecking", + "-I", "test-suite/loop-checking/src", "-R", "examples", "MetaRocq.Examples", ], "vscoq.args": [ diff --git a/common/theories/Reflect.v b/common/theories/Reflect.v index 398c17601..c5cc121f8 100644 --- a/common/theories/Reflect.v +++ b/common/theories/Reflect.v @@ -267,7 +267,7 @@ Proof. * now replace l0 with l2 by now apply lt_level_irrel. Qed. -From Coq Require Import ProofIrrelevance. +From Stdlib Require Import ProofIrrelevance. Lemma lt_universe_irrel {x y : Universe.t} (l l' : LevelExprSet.lt x y) : l = l'. Proof. diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 70e6a677f..fbb2f2856 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -343,6 +343,8 @@ Module LevelExprSet. := { t_set : LevelExprSet.t ; t_ne : LevelExprSet.is_empty t_set = false }. + + End LevelExprSet. Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. diff --git a/template-rocq/_PluginProject.in b/template-rocq/_PluginProject.in index 86edb8194..99313f3c6 100644 --- a/template-rocq/_PluginProject.in +++ b/template-rocq/_PluginProject.in @@ -144,6 +144,8 @@ gen-src/mRString.ml gen-src/mRString.mli gen-src/mRUtils.ml gen-src/mRUtils.mli +gen-src/mSetList.ml +gen-src/mSetList.mli gen-src/mSetAVL.ml gen-src/mSetAVL.mli gen-src/mSetDecide.ml @@ -152,10 +154,6 @@ gen-src/mSetFacts.ml gen-src/mSetFacts.mli gen-src/mSetInterface.ml gen-src/mSetInterface.mli -# gen-src/mSetList.ml -# gen-src/mSetList.mli -gen-src/mSetAVL.ml -gen-src/mSetAVL.mli gen-src/mSetProperties.ml gen-src/mSetProperties.mli gen-src/monad_utils.ml diff --git a/template-rocq/src/ast_denoter.ml b/template-rocq/src/ast_denoter.ml index 3f7ed951c..8717a68d3 100644 --- a/template-rocq/src/ast_denoter.ml +++ b/template-rocq/src/ast_denoter.ml @@ -215,7 +215,7 @@ struct Caml_nat.iter_nat Univ.Universe.super u (snd trm) let unquote_universe evm (trm : Universes0.Universe.t) = - let u = Universes0.t_set trm in + let u = Universes0.LevelExprSet.t_set trm in let ux_list = Universes0.LevelExprSet.elements u in let l = List.map unquote_level_expr ux_list in let u = List.fold_left Univ.Universe.sup (List.hd l) (List.tl l) in diff --git a/template-rocq/src/tm_util.ml b/template-rocq/src/tm_util.ml index 9d250ddbb..06a103ccd 100644 --- a/template-rocq/src/tm_util.ml +++ b/template-rocq/src/tm_util.ml @@ -315,13 +315,13 @@ let ugraph_contextset ?kept (g : UGraph.t) = | x :: [] -> acc | x :: rest -> List.fold_right (fun p (levels, cstrs) -> - (Univ.Level.Set.add p levels, Univ.Constraint.add (x, Univ.Eq, p) cstrs)) rest acc) + (Univ.Level.Set.add p levels, Univ.Constraints.add (x, Univ.Eq, p) cstrs)) rest acc) eqs (levels, cstrs) in let levels = Univ.Level.Set.add Univ.Level.set levels in - let levels = Univ.Level.Set.remove Univ.Level.prop levels in - let levels = Univ.Level.Set.remove Univ.Level.sprop levels in - let cstrs = Univ.Constraint.remove (Univ.Level.prop, Univ.Lt, Univ.Level.set) cstrs in + (* let levels = Univ.Level.Set.remove Univ.Level.prop levels in + let levels = Univ.Level.Set.remove Univ.Level.sprop levels in *) + (* let cstrs = Univ.Constraint.remove (Univ.Level.prop, Univ.Lt, Univ.Level.set) cstrs in *) debug Pp.(fun () -> str"Universe context: " ++ Univ.pr_universe_context_set Univ.Level.pr (levels, cstrs)); (levels, cstrs) diff --git a/template-rocq/theories/TemplateLoopChecking.v b/template-rocq/theories/TemplateLoopChecking.v index 5a962391e..8682117fd 100644 --- a/template-rocq/theories/TemplateLoopChecking.v +++ b/template-rocq/theories/TemplateLoopChecking.v @@ -77,10 +77,10 @@ Module LevelNatMapNotation. End LevelNatMapNotation. Import LevelNatMapNotation. Arguments LevelMap.Bst {elt} this%levelnat {is_bst}. - +(* Definition valuation_of_model (m : model) : LevelMap.t nat := - let max := LevelMap.fold (fun l k acc => Nat.max k acc) m 0 in - LevelMap.fold (fun l k acc => LevelMap.add l (max - k) acc) m (LevelMap.empty _). + let max := LevelMap.fold (fun l k acc => Nat.max k acc) m 0%Z in + LevelMap.fold (fun l k acc => LevelMap.add l (max - k)%nat acc) m (LevelMap.empty _). Definition print_level_nat_map (m : LevelMap.t nat) := let list := LevelMap.elements m in @@ -98,4 +98,4 @@ Definition print_result {V cls} (m : infer_result V cls) := | Model w m _ => "satisfiable with model: " ^ print_level_nat_map (model_model m) ^ nl ^ " W = " ^ print_lset w ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model (model_model m)) - end. + end. *) diff --git a/test-suite/loop-checking/META b/test-suite/loop-checking/META new file mode 100644 index 000000000..af1b6ffce --- /dev/null +++ b/test-suite/loop-checking/META @@ -0,0 +1,8 @@ + +package "plugin" ( + requires = "coq-core.plugins.ltac rocq-metarocq-template-ocaml.plugin" + archive(byte) = "metarocq_loop_checking_plugin.cma" + archive(native) = "metarocq_loop_checking_plugin.cmxa" + plugin(byte) = "metarocq_loop_checking_plugin.cma" + plugin(native) = "metarocq_loop_checking_plugin.cmxs" +) diff --git a/test-suite/loop-checking/Makefile b/test-suite/loop-checking/Makefile index 42c55bbfd..bfb6b3738 100644 --- a/test-suite/loop-checking/Makefile +++ b/test-suite/loop-checking/Makefile @@ -1,22 +1,22 @@ -all: coq plugin +all: rocq plugin -coq: Makefile.coq - $(MAKE) -f Makefile.coq +rocq: Makefile.rocq + $(MAKE) -f Makefile.rocq cd gen-src && ./to-lower.sh -Makefile.coq: _CoqProject - coq_makefile -f _CoqProject -o Makefile.coq +Makefile.rocq: _RocqProject + rocq makefile -f _RocqProject -o Makefile.rocq Makefile.plugin: _PluginProject - coq_makefile -f _PluginProject -o Makefile.plugin + rocq makefile -f _PluginProject -o Makefile.plugin -plugin: Makefile.plugin coq +plugin: Makefile.plugin rocq $(MAKE) -f Makefile.plugin .PHONY: plugin -clean: Makefile.coq Makefile.plugin - $(MAKE) -f Makefile.coq clean +clean: Makefile.rocq Makefile.plugin + $(MAKE) -f Makefile.rocq clean $(MAKE) -f Makefile.plugin clean .merlin: diff --git a/test-suite/loop-checking/Makefile.plugin.local b/test-suite/loop-checking/Makefile.plugin.local index 6638cb1b7..0679fe291 100644 --- a/test-suite/loop-checking/Makefile.plugin.local +++ b/test-suite/loop-checking/Makefile.plugin.local @@ -7,4 +7,5 @@ CAMLFLAGS+=-w -34 # Unused type CAMLFLAGS+=-w -60 # Unused module CAMLFLAGS+=-w -8 # Non-exhaustive pattern-matchings (BEWARE, just for extracted code) CAMLFLAGS+=-bin-annot # For merlin -CAMLFLAGS+=-open Metacoq_template_plugin +CAMLFLAGS+=-open Metarocq_template_plugin +CAMLPKGS+=-package rocq-metarocq-template-ocaml.plugin diff --git a/test-suite/loop-checking/_CoqProject b/test-suite/loop-checking/_CoqProject deleted file mode 100644 index efa2df823..000000000 --- a/test-suite/loop-checking/_CoqProject +++ /dev/null @@ -1,9 +0,0 @@ --R ../../template-coq/theories MetaCoq.Template --I ../../template-coq/build --R theories MetaCoq.LoopChecking - -theories/LoopCheckingPlugin.v -theories/Extraction.v - -# For testing -theories/all_stdlib.v \ No newline at end of file diff --git a/test-suite/loop-checking/_PluginProject b/test-suite/loop-checking/_PluginProject index 07f6e92c3..41bb5f011 100644 --- a/test-suite/loop-checking/_PluginProject +++ b/test-suite/loop-checking/_PluginProject @@ -1,15 +1,15 @@ --R ../../template-coq/theories MetaCoq.Template --I ../../template-coq/build +-R ../../template-rocq/theories MetaCoq.Template +-I ../../template-rocq/gen-src +src/META.rocq-metarocq-loop-checking -I src -I gen-src --R theories MetaCoq.LoopChecking +-R theories MetaRocq.LoopChecking -src/g_metacoq_loop_checking_plugin.mlg -src/metacoq_loop_checking_plugin.mlpack +src/g_metarocq_loop_checking_plugin.mlg +src/metarocq_loop_checking_plugin.mlpack -theories/Loader.v -test/test.v +# test/test.v # given by [ls -1 gen-src/*.ml gen-src/*.mli] gen-src/loopChecking.ml @@ -18,3 +18,5 @@ gen-src/templateLoopChecking.ml gen-src/templateLoopChecking.mli gen-src/loopCheckingPlugin.mli gen-src/loopCheckingPlugin.ml + +theories/Loader.v diff --git a/test-suite/loop-checking/_RocqProject b/test-suite/loop-checking/_RocqProject new file mode 100644 index 000000000..24147b5db --- /dev/null +++ b/test-suite/loop-checking/_RocqProject @@ -0,0 +1,9 @@ +-R ../../template-rocq/theories MetaCoq.Template +-I ../../template-rocq/gen-src +-R theories MetaRocq.LoopChecking + +theories/LoopCheckingPlugin.v +theories/Extraction.v + +# For testing +theories/all_stdlib.v \ No newline at end of file diff --git a/test-suite/loop-checking/src/META.rocq-metarocq-loop-checking b/test-suite/loop-checking/src/META.rocq-metarocq-loop-checking new file mode 100644 index 000000000..382aec769 --- /dev/null +++ b/test-suite/loop-checking/src/META.rocq-metarocq-loop-checking @@ -0,0 +1,10 @@ + +package "plugin" ( + directory = "." + requires = "coq-core.plugins.ltac rocq-metarocq-template-ocaml.plugin" + archive(byte) = "metarocq_loop_checking_plugin.cma" + archive(native) = "metarocq_loop_checking_plugin.cmxa" + plugin(byte) = "metarocq_loop_checking_plugin.cma" + plugin(native) = "metarocq_loop_checking_plugin.cmxs" +) +directory = "." diff --git a/test-suite/loop-checking/src/g_metarocq_loop_checking_plugin.ml b/test-suite/loop-checking/src/g_metarocq_loop_checking_plugin.ml new file mode 100644 index 000000000..e5abf0c5d --- /dev/null +++ b/test-suite/loop-checking/src/g_metarocq_loop_checking_plugin.ml @@ -0,0 +1,24 @@ + +# 1 "src/g_metarocq_loop_checking_plugin.mlg" + +open Stdarg +open LoopCheckingPlugin + + +let _ = Mltop.add_known_module "rocq-metarocq-loop-checking.plugin" +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-loop-checking.plugin") ~command:"Check_universes" ~classifier:(fun _ -> Vernacextend.classify_as_query) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Check", + Vernacextend.TyTerminal ("Universes", Vernacextend.TyNil))), + (let coqpp_body () = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 10 "src/g_metarocq_loop_checking_plugin.mlg" + Run_extractable.run_vernac check_universes + ) ~pm) in fun ?loc ~atts () -> + coqpp_body (Attributes.unsupported_attributes atts)), + None))] + diff --git a/test-suite/loop-checking/src/g_metacoq_loop_checking_plugin.mlg b/test-suite/loop-checking/src/g_metarocq_loop_checking_plugin.mlg similarity index 64% rename from test-suite/loop-checking/src/g_metacoq_loop_checking_plugin.mlg rename to test-suite/loop-checking/src/g_metarocq_loop_checking_plugin.mlg index 31e6228d9..c986640a6 100644 --- a/test-suite/loop-checking/src/g_metacoq_loop_checking_plugin.mlg +++ b/test-suite/loop-checking/src/g_metarocq_loop_checking_plugin.mlg @@ -3,9 +3,9 @@ open Stdarg open LoopCheckingPlugin } -DECLARE PLUGIN "metacoq_loop_checking_plugin" +DECLARE PLUGIN "rocq-metarocq-loop-checking.plugin" VERNAC COMMAND EXTEND Check_universes CLASSIFIED AS QUERY STATE program - | [ "MetaCoq" "Check" "Universes" ] -> + | [ "MetaRocq" "Check" "Universes" ] -> { Run_extractable.run_vernac check_universes } END diff --git a/test-suite/loop-checking/src/metacoq_loop_checking_plugin.mlpack b/test-suite/loop-checking/src/metarocq_loop_checking_plugin.mlpack similarity index 62% rename from test-suite/loop-checking/src/metacoq_loop_checking_plugin.mlpack rename to test-suite/loop-checking/src/metarocq_loop_checking_plugin.mlpack index 6343fc0c0..5d430cef7 100644 --- a/test-suite/loop-checking/src/metacoq_loop_checking_plugin.mlpack +++ b/test-suite/loop-checking/src/metarocq_loop_checking_plugin.mlpack @@ -1,4 +1,4 @@ LoopChecking TemplateLoopChecking LoopCheckingPlugin -G_metacoq_loop_checking_plugin +G_metarocq_loop_checking_plugin diff --git a/test-suite/loop-checking/test/test.v b/test-suite/loop-checking/test/test.v index 5d6f624fe..a1995c5de 100644 --- a/test-suite/loop-checking/test/test.v +++ b/test-suite/loop-checking/test/test.v @@ -1,7 +1,7 @@ -Require Import Coq.Strings.String. -Require Import MetaCoq.LoopChecking.Loader. -Require Import MetaCoq.LoopChecking.all_stdlib. +Require Import Stdlib.Strings.String. +Require Import MetaRocq.Template.All. +Require Import MetaRocq.LoopChecking.Loader. +Require Import MetaRocq.LoopChecking.all_stdlib. -Set MetaCoq Timing. - -Time MetaCoq Check Universes. +Set MetaRocq Timing. +Time MetaRocq Check Universes. diff --git a/test-suite/loop-checking/theories/Extraction.v b/test-suite/loop-checking/theories/Extraction.v index 32cd0d80d..42dcfa95b 100644 --- a/test-suite/loop-checking/theories/Extraction.v +++ b/test-suite/loop-checking/theories/Extraction.v @@ -1,5 +1,5 @@ -Require Import Template.Extraction. -From MetaCoq.LoopChecking Require Import LoopCheckingPlugin. +From MetaRocq.Template Require Import Extraction. +From MetaRocq.LoopChecking Require Import LoopCheckingPlugin. Extract Constant BinInt.Z.of_nat => "(fun x -> x)". Extract Constant BinInt.Z.to_nat => "(fun x -> x)". diff --git a/test-suite/loop-checking/theories/Loader.v b/test-suite/loop-checking/theories/Loader.v index 390de9d74..5e4177292 100644 --- a/test-suite/loop-checking/theories/Loader.v +++ b/test-suite/loop-checking/theories/Loader.v @@ -1,2 +1,2 @@ -From MetaCoq.Template Require ExtractableLoader. -Declare ML Module "metacoq_loop_checking_plugin". +From MetaRocq.Template Require ExtractableLoader. +Declare ML Module "rocq-metarocq-loop-checking.plugin". diff --git a/test-suite/loop-checking/theories/LoopCheckingPlugin.v b/test-suite/loop-checking/theories/LoopCheckingPlugin.v index 12a517202..59151aa66 100644 --- a/test-suite/loop-checking/theories/LoopCheckingPlugin.v +++ b/test-suite/loop-checking/theories/LoopCheckingPlugin.v @@ -1,28 +1,29 @@ -Require Import Coq.Lists.List. -From MetaCoq.Template Require Import - bytestring Ast +Require Import Stdlib.Lists.List. +From MetaRocq.Utils Require Import bytestring utils. +From MetaRocq.Template Require Import + Ast Loader TemplateMonad.Extractable. Import TemplateMonad.Extractable. -From MetaCoq Require Import utils Template.BasicAst Template.AstUtils Ast TemplateLoopChecking. +From MetaRocq Require Import Common.BasicAst Template.AstUtils Template.Ast TemplateLoopChecking. Definition time : forall {A} {B : A -> Type}, string -> (forall x : A, B x) -> forall x : A, B x := fun A B s f x => f x. -Extract Constant time => +Extract Constant time => "(fun c f x -> let s = Caml_bytestring.caml_string_of_bytestring c in Tm_util.time (Pp.str s) f x)". Open Scope bs_scope. -Import MCMonadNotation. +Import MRMonadNotation. Local Open Scope monad_scope. Global Instance TemplateMonad_Monad@{t u} : Monad@{t u} TM@{t} := {| ret := @tmReturn ; bind := @tmBind |}. -Definition check_universes : TM unit := - tmQuoteUniverses >>= fun ctx => +Definition check_universes : TM unit := + tmQuoteUniverses >>= fun ctx => let clauses := time "building clauses" enforce_level_constraints (snd ctx) in tmMsg (string_of_nat (LevelSet.cardinal (fst ctx)) ++ " universes and " ++ string_of_nat (ConstraintSet.cardinal (snd ctx)) ++ " constraints") ;; let result := time "loop-checking" TemplateLoopChecking.UnivLoopChecking.infer clauses in - tmMsg (print_result result). + tmMsg (TemplateLoopChecking.UnivLoopChecking.print_result result). diff --git a/test-suite/loop-checking/theories/all_stdlib.v b/test-suite/loop-checking/theories/all_stdlib.v index 90864a94f..9cb364370 100644 --- a/test-suite/loop-checking/theories/all_stdlib.v +++ b/test-suite/loop-checking/theories/all_stdlib.v @@ -1,13 +1,11 @@ -Require Strings.Ascii +From Stdlib Require Strings.Ascii Strings.String Strings.BinaryString Strings.OctalString -Strings.ByteVector Strings.Byte Strings.HexString ssrmatching.ssrmatching ZArith.Zhints -ZArith.Zdigits ZArith.Zorder ZArith.Zminmax ZArith.ZArith @@ -63,11 +61,9 @@ setoid_ring.Rings_R setoid_ring.Ring_theory NArith.NArith NArith.Nsqrt_def -NArith.Ndigits NArith.Ngcd_def NArith.Nnat NArith.Ndec -NArith.Ndist NArith.BinNat NArith.BinNatDef NArith.Ndiv_def @@ -128,7 +124,6 @@ Numbers.Natural.Abstract.NAxioms Numbers.Natural.Abstract.NDiv Numbers.Natural.Abstract.NPow Numbers.Natural.Abstract.NDefOps -Numbers.Natural.Peano.NPeano Numbers.DecimalQ Numbers.DecimalN Numbers.HexadecimalNat @@ -167,16 +162,12 @@ Numbers.NaryFunctions Numbers.Cyclic.Abstract.NZCyclic Numbers.Cyclic.Abstract.CyclicAxioms Numbers.Cyclic.Abstract.DoubleType -Numbers.Cyclic.Abstract.CarryType + Numbers.Cyclic.Int63.Sint63 Numbers.Cyclic.Int63.Cyclic63 Numbers.Cyclic.Int63.Uint63 Numbers.Cyclic.Int63.PrimInt63 Numbers.Cyclic.Int63.Ring63 -Numbers.Cyclic.Int31.Ring31 -Numbers.Cyclic.Int31.Int31 -Numbers.Cyclic.Int31.Cyclic31 -Numbers.Cyclic.ZModulo.ZModulo Numbers.DecimalNat Numbers.DecimalZ Numbers.HexadecimalR @@ -262,7 +253,6 @@ Reals.MVT Reals.Rpower Reals.Rtrigo_reg Reals.Ranalysis_reg -Logic.FinFun Logic.WKL Logic.Classical Logic.ClassicalUniqueChoice @@ -336,7 +326,6 @@ QArith.QArith_base QArith.Qround QArith.Qabs QArith.Qpower -QArith.Qreals QArith.Qminmax QArith.Qring QArith.QOrderedType @@ -344,13 +333,9 @@ QArith.Qreduction QArith.Qcanon QArith.QArith QArith.Qcabs -Lists.Streams Lists.ListDec Lists.ListSet Lists.ListTactics -Lists.SetoidPermutation -Lists.StreamMemo -Lists.SetoidList Lists.List micromega.Lia micromega.Lqa @@ -374,7 +359,6 @@ micromega.ZMicromega micromega.ZArith_hints micromega.EnvRing micromega.Fourier_util -micromega.MExtraction micromega.Env micromega.ZifySint63 micromega.Fourier @@ -454,13 +438,9 @@ Sets.Classical_sets Sets.Relations_3_facts Sets.Powerset Sets.Partial_Order -Bool.Bvector Bool.BoolEq Bool.Bool -Bool.BoolOrder Bool.IfProp -Bool.Zerob -Bool.Sumbool Bool.DecBool Floats.FloatOps Floats.FloatAxioms @@ -505,34 +485,14 @@ Relations.Relation_Definitions Relations.Relation_Operators omega.OmegaLemmas omega.PreOmega -nsatz.Nsatz -nsatz.NsatzTactic btauto.Btauto btauto.Reflect btauto.Algebra Arith.PeanoNat Arith.Arith -Arith.Le -Arith.Gt Arith.EqNat Arith.Bool_nat -Arith.Lt Arith.Factorial -Arith.Div2 -Arith.Minus -Arith.Euclid -Arith.Between -Arith.Max -Arith.Even -Arith.Wf_nat -Arith.Cantor -Arith.Arith_base -Arith.Min -Arith.Plus -Arith.Mult -Arith.Compare_dec -Arith.Peano_dec -Arith.Compare extraction.ExtrHaskellNatNum extraction.Extraction extraction.ExtrOCamlInt63 @@ -553,7 +513,4 @@ extraction.ExtrOcamlNatBigInt extraction.ExtrOCamlPArray extraction.ExtrHaskellString extraction.ExtrOcamlString -extraction.ExtrHaskellNatInteger -Compat.Coq813 -Compat.AdmitAxiom -Compat.Coq814. +extraction.ExtrHaskellNatInteger. \ No newline at end of file From 2d178ab48b9f1c13d5646c97f187b1a6b3985e6b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 19 Jul 2025 01:02:20 +0200 Subject: [PATCH 003/164] Loop checking now builds a model in Z --- template-rocq/theories/LoopChecking.v | 779 ++++++++++++++++++-------- 1 file changed, 555 insertions(+), 224 deletions(-) diff --git a/template-rocq/theories/LoopChecking.v b/template-rocq/theories/LoopChecking.v index 2dc573540..1b043ba39 100644 --- a/template-rocq/theories/LoopChecking.v +++ b/template-rocq/theories/LoopChecking.v @@ -1,8 +1,9 @@ (* Distributed under the terms of the MIT license. *) -From Stdlib Require Import ssreflect ssrbool. +From Stdlib Require Import ssreflect ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils. + From MetaRocq.Common Require Universes. From Equations Require Import Equations. Set Equations Transparent. @@ -65,9 +66,13 @@ Module Type LevelExprSet_fun (Level : LevelOrderedType) (LevelExpr : LevelExprIt Include SWithLeibniz with Module E := LevelExpr. Record nonEmptyLevelExprSet - := { t_set : t ; + := { t_set :> t ; t_ne : is_empty t_set = false }. + (* Parameter map : (LevelExpr.t -> LevelExpr.t) -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet. *) + + (* Parameter map_spec : forall e f u, In e (map f u) <-> exists e0, In e0 u /\ e = (f e0). *) + End LevelExprSet_fun. Module Type LoopCheckingItf (Level : LevelOrderedType) @@ -76,7 +81,7 @@ Module Type LoopCheckingItf (Level : LevelOrderedType) (LevelExprSet : LevelExprSet_fun Level LevelExpr) (LevelMap : FMapOTInterface Level). - Definition model := LevelMap.t nat. + Definition model := LevelMap.t Z. Definition valuation := LevelMap.t nat. Definition clause : Type := LevelExprSet.nonEmptyLevelExprSet × LevelExpr.t. @@ -116,6 +121,8 @@ Module Type LoopCheckingItf (Level : LevelOrderedType) Parameter infer : forall (cls : clauses), infer_result (clauses_levels cls) cls. + Parameter print_result : forall {V cls}, infer_result V cls -> string. + End LoopCheckingItf. Module LoopChecking @@ -592,13 +599,10 @@ Proof. now rewrite LevelSet.union_spec LevelSet.singleton_spec. Qed. -Definition model := LevelMap.t nat. +Definition model := LevelMap.t Z. -Definition level_value (m : model) (level : Level.t) : nat := - match LevelMap.find level m with - | Some val => val - | None => 0 - end. +Definition level_value (m : model) (level : Level.t) : option Z := + LevelMap.find level m. Definition levelexpr_value (m : model) (atom : LevelExpr.t) := level_value m (levelexpr_level atom). @@ -607,16 +611,29 @@ Extraction Inline levelexpr_value. Definition min_atom_value (m : model) (atom : LevelExpr.t) := let '(l, k) := atom in - (Z.of_nat (level_value m l) - Z.of_nat k)%Z. + match level_value m l with + | None => None + | Some val => Some (val - Z.of_nat k)%Z + end. + +Definition option_map2 {A} (f : A -> A -> A) (o o' : option A) : option A := + match o, o' with + | Some x, Some y => Some (f x y) + | None, Some _ + | Some _, None + | None, None => None + end. -Definition min_premise (m : model) (l : nonEmptyLevelExprSet) : Z := +Definition min_premise (m : model) (l : nonEmptyLevelExprSet) : option Z := let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (fun min atom => Z.min (min_atom_value m atom) min) tl (min_atom_value m hd). + fold_left (fun min atom => option_map2 Z.min (min_atom_value m atom) min) tl (min_atom_value m hd). + +Open Scope Z_scope. Definition satisfiable_atom (m : model) (atom : Level.t * nat) : bool := let '(l, k) := atom in match LevelMap.find l m with - | Some val => k <=? val + | Some val => Z.of_nat k <=? val | None => false end. @@ -625,12 +642,20 @@ Definition satisfiable_premise (m : model) (l : nonEmptyLevelExprSet) := (* Definition valid_clause (m : model) (cl : clause) := *) (* implb (satisfiable_premise m (premise cl)) (satisfiable_atom m (concl cl)). *) +Definition level_value_above m l k := + match level_value m l with + | Some val => k <=? val + | None => false + end. Definition valid_clause (m : model) (cl : clause) := let k0 := min_premise m (premise cl) in - if (k0 true + | Some k0 => + let (l, k) := concl cl in + level_value_above m l (Z.of_nat k + k0) + end. Definition is_model (cls : clauses) (m : model) : bool := Clauses.for_all (valid_clause m) cls. @@ -645,20 +670,18 @@ Definition update_model (m : model) l v : model := LevelMap.add l v m. Definition update_value (wm : LevelSet.t × model) (cl : clause) : update_result := let (w, m) := wm in let k0 := min_premise m (premise cl) in - (* cl holds vacuously as the premise doesn't hold *) - if (k0 VacuouslyTrue + | Some k0 => let (l, k) := concl cl in (* Does the conclusion also hold? - We optimize a bit here, rather than adding k0 in a second stage, - we do it already while checking the clause. In the paper, a second - pass computes this. + We optimize a bit here, rather than adding k0 in a second stage, + we do it already while checking the clause. In the paper, a second + pass computes this. *) - if k + Z.to_nat k0 <=? level_value m l then Holds - else - (* The conclusion doesn't hold, we need to set it higher *) - DoesntHold (LevelSet.add l w, update_model m l (k + Z.to_nat k0)). + if level_value_above m l (Z.of_nat k + k0) then Holds + else DoesntHold (LevelSet.add l w, update_model m l (Z.of_nat k + k0)) + end. Definition check_clause_model cl '(modified, wm) := match update_value wm cl with @@ -688,14 +711,15 @@ Proof. intros b w' v'. destruct a. destruct p as []. unfold update_value. - destruct Z.ltb. intros [= -> -> ->] => //. - now eapply IH. destruct x as [prem [l k]]; cbn. - destruct Nat.leb. intros [= -> -> ->] => //. now eapply IH. - intros [= <- <- <-]. intros x inx. - eapply LevelSet.add_spec. - specialize (IH _ _ _ eq_refl). - now right. + destruct min_premise as [k0|] eqn:hk0. + 2:apply IH. + destruct level_value_above. + - intros [= -> -> ->] => //. now eapply IH. + - intros [= <- <- <-]. intros x inx. + eapply LevelSet.add_spec. + specialize (IH _ _ _ eq_refl). + now right. Qed. Lemma check_model_subset {cls w v} : @@ -781,8 +805,8 @@ Definition in_clauses_conclusions (cls : clauses) (x : Level.t): Prop := exists cl, Clauses.In cl cls /\ (level cl.2) = x. Definition v_minus_w_bound (W : LevelSet.t) (m : model) := - LevelMap.fold (fun w v acc => Nat.max v acc) - (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0. + LevelMap.fold (fun w v acc => Z.max v acc) + (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0%Z. Definition levelexpr_k : LevelExpr.t -> nat := snd. Coercion levelexpr_k : LevelExpr.t >-> nat. @@ -798,7 +822,7 @@ Definition gain (cl : clause) : Z := Z.of_nat (levelexpr_k (concl cl)) - Z.of_nat (premise_min (premise cl)). Definition max_gain (cls : clauses) := - Clauses.fold (fun cl acc => Nat.max (Z.to_nat (gain cl)) acc) cls 0. + Clauses.fold (fun cl acc => Nat.max (Z.to_nat (gain cl)) acc) cls 0%nat. Definition model_same_domain (m m' : model) := forall l, LevelMap.In l m <-> LevelMap.In l m'. @@ -856,6 +880,24 @@ Proof. intros eq heq % LevelSet.equal_spec. congruence. Qed. Lemma levelset_union_same U : LevelSet.union U U =_lset U. Proof. lsets. Qed. +Class Commutative {A} (f : A -> A -> A) := comm : forall x y, f x y = f y x. +Instance option_map_2_comm {A} f : @Commutative A f -> @Commutative (option A) (option_map2 f). +Proof. + intros com [x|] [y|] => //=. now rewrite comm. +Qed. + +Instance Zmin_comm : Commutative Z.min := Z.min_comm. +Instance Zmax_comm : Commutative Z.max := Z.max_comm. + +Class Associative {A} (f : A -> A -> A) := assoc : forall x y z, f x (f y z) = f (f x y) z. +Instance option_map_2_assoc {A} f : @Associative A f -> @Associative (option A) (option_map2 f). +Proof. + intros assoc [x|] [y|] [z|]; cbn => //. now rewrite assoc. +Qed. + +Instance Zmin_assoc : Associative Z.min := Z.min_assoc. +Instance Zmax_assoc : Associative Z.max := Z.max_assoc. + Lemma fold_left_comm {A B} (f : B -> A -> B) (l : list A) (x : A) (acc : B) : (forall x y z, f (f z x) y = f (f z y) x) -> fold_left f l (f acc x) = f (fold_left f l acc) x. @@ -865,16 +907,27 @@ Proof. rewrite -IHl. f_equal. now rewrite H. Qed. -Lemma fold_left_le (f g : nat -> LevelSet.elt -> nat) l : - (forall acc acc' x, In x l -> acc <= acc' -> f acc x <= g acc' x) -> - forall acc acc', acc <= acc' -> - fold_left f l acc <= fold_left g l acc'. +Lemma fold_left_min_opt_comm {A} (f : A -> A -> A) l x acc : + Associative f -> Commutative f -> + fold_left (option_map2 f) l (option_map2 f acc x) = option_map2 f (fold_left (option_map2 f) l acc) x. +Proof. + intros ass c. rewrite fold_left_comm => //. + intros. rewrite -(assoc (f := option_map2 f)). + rewrite -(assoc (f := option_map2 f) z y x0). + f_equal. apply comm. +Qed. + +Lemma fold_left_le {A} {le} (f g : A -> LevelSet.elt -> A) l : + (forall acc acc' x, In x l -> le acc acc' -> le (f acc x) (g acc' x)) -> + forall acc acc', le acc acc' -> + le (fold_left f l acc) (fold_left g l acc'). Proof. intros hfg. induction l => //. cbn. intros. apply IHl. intros. apply hfg => //. now right. apply hfg => //. now left. Qed. +Local Open Scope nat_scope. Lemma fold_left_ne_lt (f g : nat -> LevelSet.elt -> nat) l acc : (forall (x y : LevelSet.elt) z, f (f z x) y = f (f z y) x) -> (forall (x y : LevelSet.elt) z, g (g z x) y = g (g z y) x) -> @@ -904,6 +957,7 @@ Proof. * intros acc1 acc' x hin. apply (H2 acc1 acc' x). now right. * exists min. split => //. Qed. +Close Scope nat_scope. Infix "↓" := clauses_with_concl (at level 70). (* \downarrow *) Infix "⇂" := restrict_clauses (at level 70). (* \downharpoonright *) @@ -945,9 +999,11 @@ Lemma update_value_valid {W m cl} : end. Proof. unfold update_value, valid_clause. - destruct Z.ltb => //. destruct cl as [prem [l k]]; cbn. - destruct Nat.leb => //. + destruct min_premise => //. + unfold level_value_above. + destruct level_value => //. + destruct Z.leb => //. Qed. Lemma valid_update_value {W m cl} : @@ -958,9 +1014,11 @@ Lemma valid_update_value {W m cl} : end. Proof. unfold update_value, valid_clause. - destruct Z.ltb => //. destruct cl as [prem [l k]]; cbn. - destruct Nat.leb => //. + destruct min_premise => //. + unfold level_value_above. + destruct level_value => //. + destruct Z.leb => //. Qed. Lemma check_model_aux_false {cls acc acc'} : check_model_aux cls acc = (false, acc') -> acc = acc'. @@ -1031,7 +1089,7 @@ Proof. move/orP: H1 => [->|] //. move/H0. intros ->. now rewrite orb_true_r. Qed. #[local] Instance model_le_refl : Reflexive model_le. -Proof. intros x l k map. exists k; split => //. Qed. +Proof. intros x l k map. exists k; split => //. lia. Qed. #[local] Instance model_le_trans : Transitive model_le. Proof. intros m m' m'' mm' m'm'' l k map. @@ -1039,7 +1097,27 @@ Proof. intros m m' m'' mm' m'm'' l k map. apply m'm'' in map as [k'' [map ?]]. exists k''. split => //. lia. Qed. -Lemma update_model_monotone m l k : level_value m l <= k -> m ⩽ update_model m l k. +Inductive opt_le {A} (le : relation A) : relation (option A) := +| opt_le_some x y : le x y -> opt_le le (Some x) (Some y) +| opt_le_none_some x : opt_le le None x. +Derive Signature for opt_le. + +Instance opt_le_refl {A} (le : relation A) : Reflexive le -> Reflexive (opt_le le). +Proof. + intros hre x; induction x; constructor; reflexivity. +Qed. + +Instance opt_le_trans {A} (le : relation A) : Transitive le -> Transitive (opt_le le). +Proof. + intros hre x; induction x; destruct y as [y|]; intros z H H'; depelim H; depelim H'; constructor. + now transitivity y. +Qed. + +Definition value_le : relation (option Z) := opt_le Z.le. + +Infix "≤" := value_le (at level 50). + +Lemma update_model_monotone m l k : level_value m l ≤ Some k -> m ⩽ update_model m l k. Proof. intros hl. intros l' k' maps. @@ -1050,7 +1128,16 @@ Proof. rewrite (LevelMap.find_1 maps). intros hle. split => //. eapply LevelMap.add_1. eapply LevelMap.OT.eq_refl. - - exists k'. split => //. apply LevelMap.add_2 => //. + now depelim hle. + - exists k'. split => //. apply LevelMap.add_2 => //. lia. +Qed. + +Lemma update_model_not_above m l k : level_value_above m l k = false -> m ⩽ update_model m l k. +Proof. + unfold level_value_above. + intros hlev. + apply update_model_monotone. + destruct level_value as [v|] eqn:hv; constructor; lia. Qed. Lemma check_clause_model_inv {cl modified w m b wm'} : @@ -1064,12 +1151,11 @@ Proof. * intros [= <- <-]. move: upd. unfold update_value. - case: Z.ltb_spec => //. destruct cl as [prem [l k]] => /=. - intros hprem. - case: Nat.leb_spec => // hlt. + destruct min_premise as [k0|] eqn:hmin => //. + destruct level_value_above eqn:hval => //. intros [= <-]. cbn. - eapply update_model_monotone. lia. + now eapply update_model_not_above. Qed. Lemma check_clause_model_intact {cl modified w m wm'} : @@ -1093,10 +1179,11 @@ Proof. * intros [= <-]. move: upd. unfold update_value, valid_clause. - case: Z.ltb_spec => //. + destruct min_premise as [k0|] eqn:hmin => //. destruct cl as [prem [l k]] => /=. - intros hprem. - case: Nat.leb_spec => // hlt. + unfold level_value_above. + destruct level_value as [val|] eqn:hval => //. + case: Z.leb_spec => //. Qed. Lemma check_model_aux_model_le {cls acc acc' b} : @@ -1113,7 +1200,7 @@ Proof. Qed. Lemma level_value_update_model m l k : - level_value (update_model m l k) l = k. + level_value (update_model m l k) l = Some k. Proof. unfold level_value, update_model. cbn -[LevelMap.find LevelMap.add]. @@ -1157,17 +1244,18 @@ Proof. intros cl cl' eqcl x y ->. unfold is_model. now rewrite eqcl. Qed. -Lemma model_le_values {m m' : model} x : m ⩽ m' -> level_value m x <= level_value m' x. +Lemma model_le_values {m m' : model} x : m ⩽ m' -> level_value m x ≤ level_value m' x. Proof. intros lem. specialize (lem x). unfold level_value. - destruct LevelMap.find eqn:hl => //. 2:lia. - apply LevelMap.find_2 in hl. specialize (lem _ hl) as [k' [mapsto leq]]. - now rewrite (LevelMap.find_1 mapsto). + destruct LevelMap.find eqn:hl => //. + - apply LevelMap.find_2 in hl. specialize (lem _ hl) as [k' [mapsto leq]]. + rewrite (LevelMap.find_1 mapsto). now constructor. + - destruct (LevelMap.find x m'); constructor. Qed. Lemma level_value_MapsTo {k e} {m : model} : - LevelMap.MapsTo k e m -> level_value m k = e. + LevelMap.MapsTo k e m -> level_value m k = Some e. Proof. unfold level_value. move=> mapto; rewrite (LevelMap.find_1 mapto) //. @@ -1177,7 +1265,7 @@ Infix "⊂_clset" := Clauses.Subset (at level 70). Lemma max_gain_in cl cls : Clauses.In cl cls -> - Z.to_nat (gain cl) <= max_gain cls. + (Z.to_nat (gain cl) <= max_gain cls)%nat. Proof. intros hin. unfold max_gain. revert cl hin. @@ -1191,7 +1279,7 @@ Qed. Definition max_gain_subset (cls cls' : Clauses.t) : cls ⊂_clset cls' -> - max_gain cls <= max_gain cls'. + (max_gain cls <= max_gain cls')%nat. Proof. unfold max_gain at 1. revert cls'. @@ -1248,9 +1336,9 @@ Proof. - now apply out. Qed. -Definition max_premise_value (m : model) (l : nonEmptyLevelExprSet) : nat := +Definition max_premise_value (m : model) (l : nonEmptyLevelExprSet) : option Z := let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (fun min atom => Nat.max (levelexpr_value m atom) min) tl (levelexpr_value m hd). + fold_left (fun min atom => option_map2 Z.max (levelexpr_value m atom) min) tl (levelexpr_value m hd). Definition non_W_atoms W (l : LevelExprSet.t) := LevelExprSet.filter (fun lk => ~~ LevelSet.mem lk.1 W) l. @@ -1334,6 +1422,8 @@ Proof. rewrite -LevelSet.mem_spec in H1 |- *. destruct LevelSet.mem; intuition auto. Qed. +Local Open Scope Z_scope. + Section MoreNonEmpty. Import LevelExprSet. @@ -1345,9 +1435,27 @@ Section MoreNonEmpty. now move/InA_In_eq/LevelExprSetFact.elements_2. Qed. + Notation min_opt := (option_map2 Z.min). + Lemma Zmin_opt_left x y : min_opt x y ≤ x. + Proof. + destruct x as [x|], y as [y|]; constructor. lia. + Qed. + + Lemma Zmin_opt_right x y : min_opt x y ≤ y. + Proof. + destruct x as [x|], y as [y|]; constructor. lia. + Qed. + + Lemma min_opt_spec x y z : min_opt x y = z -> (z = y \/ z = x). + Proof. + destruct x as [x|], y as [y|], z as [z|]; cbn; intuition auto. + - noconf H. pose proof (Zmin_irreducible x y). destruct H; intuition (f_equal; auto). + - noconf H. + Qed. + Lemma min_premise_spec_aux (m : model) s k : min_premise m s = k -> - (forall x, LevelExprSet.In x s -> (k <= min_atom_value m x)%Z) /\ + (forall x, LevelExprSet.In x s -> (k ≤ min_atom_value m x)%Z) /\ (exists x, LevelExprSet.In x s /\ k = min_atom_value m x). Proof. unfold min_premise. @@ -1360,20 +1468,27 @@ Section MoreNonEmpty. split. intros x [->|] => //. reflexivity. now exists t0; split => //. - destruct IHl as [ha hex]. - split; intros. - eapply (in_elt_inv x a [t0]) in H as [<-|inih]. - cbn. rewrite fold_left_comm. lia. lia. + split. + * intros x hin. + eapply (in_elt_inv x a [t0]) in hin as [<-|inih]. + { cbn. rewrite fold_left_comm. + { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } + apply Zmin_opt_left. } specialize (ha _ inih). - cbn. rewrite fold_left_comm. lia. lia. - destruct hex as [minval [inmin ih]]. - cbn. rewrite fold_left_comm. lia. - destruct (Z.leb_spec (min_atom_value m a) (min_atom_value m minval)). - exists a. split; [intuition|]. lia. exists minval. - cbn in inmin; split; [intuition auto|]. lia. + cbn. rewrite fold_left_comm. + { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } + etransitivity; [apply Zmin_opt_right|assumption]. + * destruct hex as [minval [inmin ih]]. + cbn. rewrite fold_left_comm. + { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } + rewrite ih. + destruct (min_opt_spec (min_atom_value m a) (min_atom_value m minval) _ eq_refl). + { rewrite H. exists minval. cbn in inmin. split; [intuition|reflexivity]. } + { rewrite H. exists a. cbn in inmin. split; [intuition|reflexivity]. } Qed. Lemma min_premise_spec (m : model) (s : nonEmptyLevelExprSet) : - (forall x, LevelExprSet.In x s -> (min_premise m s <= min_atom_value m x)%Z) /\ + (forall x, LevelExprSet.In x s -> min_premise m s ≤ min_atom_value m x) /\ (exists x, LevelExprSet.In x s /\ min_premise m s = min_atom_value m x). Proof. now apply min_premise_spec_aux. @@ -1381,18 +1496,18 @@ Section MoreNonEmpty. Lemma min_premise_subset (m : model) (s s' : nonEmptyLevelExprSet) : LevelExprSet.Subset s s' -> - (min_premise m s' <= min_premise m s)%Z. + min_premise m s' ≤ min_premise m s. Proof. intros sub. have [has [mins [ins eqs]]] := min_premise_spec m s. have [has' [mins' [ins' eqs']]] := min_premise_spec m s'. specialize (sub _ ins). specialize (has' _ sub). - lia. + now rewrite eqs. Qed. Lemma premise_min_spec_aux s k : premise_min s = k -> - (forall x, LevelExprSet.In x s -> (k <= x)) /\ + (forall x, LevelExprSet.In x s -> (k <= x)%nat) /\ (exists x, LevelExprSet.In x s /\ k = x). Proof. unfold premise_min. @@ -1419,7 +1534,7 @@ Section MoreNonEmpty. Qed. Lemma premise_min_spec (s : nonEmptyLevelExprSet) : - (forall x, LevelExprSet.In x s -> premise_min s <= x) /\ + (forall x, LevelExprSet.In x s -> premise_min s <= x)%nat /\ (exists x, LevelExprSet.In x s /\ premise_min s = x). Proof. now apply premise_min_spec_aux. @@ -1427,7 +1542,7 @@ Section MoreNonEmpty. Lemma premise_min_subset (s s' : nonEmptyLevelExprSet) : LevelExprSet.Subset s s' -> - premise_min s' <= premise_min s. + (premise_min s' <= premise_min s)%nat. Proof. intros sub. have [has [mins [ins eqs]]] := premise_min_spec s. @@ -1436,51 +1551,82 @@ Section MoreNonEmpty. lia. Qed. + Lemma fold_comm_assoc x y z : option_map2 Z.max x (option_map2 Z.max y z) = + option_map2 Z.max y (option_map2 Z.max x z). + Proof. + now rewrite (assoc (f := option_map2 Z.max)) (comm (f := option_map2 Z.max) x y) -assoc. + Qed. + Notation max_opt := (option_map2 Z.max). + + Lemma max_opt_spec x y z : max_opt x y = Some z -> exists x' y', x = Some x' /\ y = Some y' /\ z = Z.max x' y'. + Proof. + destruct x as [x|], y as [y|]; cbn; intuition eauto; try noconf H. + exists x, y. auto. + Qed. + + (* Lemma Zmax_opt_left x y : x ≤ max_opt x y. *) + (* Proof. *) + (* destruct x as [x|], y as [y|]; try constructor. lia. *) + (* Qed. *) +(* + Lemma Zmax_opt_right x y : min_opt x y ≤ y. + Proof. + destruct x as [x|], y as [y|]; constructor. lia. + Qed. *) + + Lemma max_premise_value_spec_aux (m : model) s k : - max_premise_value m s = k -> - (forall x, LevelExprSet.In x s -> levelexpr_value m x <= k) /\ - (exists x, LevelExprSet.In x s /\ k = levelexpr_value m x). + max_premise_value m s = Some k -> + (forall x, LevelExprSet.In x s -> exists k', levelexpr_value m x = Some k' /\ Some k' ≤ Some k) /\ + (exists x, LevelExprSet.In x s /\ Some k = levelexpr_value m x). Proof. unfold max_premise_value. move: (to_nonempty_list_spec s). destruct (to_nonempty_list s). intros heq. setoid_rewrite In_elements. rewrite -heq. clear s heq. - intros <-. - induction l. + induction l in k |- *. - cbn. - split. intros x [->|] => //. + intros eq. + split. intros x [->|] => //. exists k. split => //. reflexivity. now exists t0; split => //. - - destruct IHl as [ha hex]. + - cbn. rewrite fold_left_comm. intros; apply fold_comm_assoc. + intros heq. apply max_opt_spec in heq as [y' [z' [eqa [eqf ->]]]]. + specialize (IHl _ eqf). destruct IHl as [ha hex]. split; intros. eapply (in_elt_inv x a [t0]) in H as [<-|inih]. - cbn. rewrite fold_left_comm. lia. lia. - specialize (ha _ inih). - cbn. rewrite fold_left_comm. lia. lia. + { exists y'; intuition eauto. constructor; lia. } + { specialize (ha _ inih) as [k' []]. exists k'; intuition eauto. constructor. depelim H0; lia. } destruct hex as [maxval [inmax ih]]. - cbn. rewrite fold_left_comm. lia. - destruct (Nat.leb_spec (levelexpr_value m maxval) (levelexpr_value m a)). - exists a. split; [intuition|]. lia. exists maxval. - cbn in inmax; split; [intuition auto|]. lia. + cbn. + destruct (Z.leb_spec z' y'). + exists a. split; [intuition|]. rewrite eqa. f_equal. lia. + exists maxval. cbn in inmax; split; [intuition auto|]. rewrite -ih. f_equal; lia. Qed. - Lemma max_premise_value_spec (m : model) (s : nonEmptyLevelExprSet) : - (forall x, LevelExprSet.In x s -> levelexpr_value m x <= max_premise_value m s) /\ - (exists x, LevelExprSet.In x s /\ max_premise_value m s = levelexpr_value m x). + Lemma max_premise_value_spec (m : model) (s : nonEmptyLevelExprSet) k : + max_premise_value m s = Some k -> + (forall x, LevelExprSet.In x s -> exists k', levelexpr_value m x = Some k' /\ Some k' ≤ Some k) /\ + (exists x, LevelExprSet.In x s /\ Some k = levelexpr_value m x). Proof. - now apply max_premise_value_spec_aux. + apply (max_premise_value_spec_aux m s). Qed. End MoreNonEmpty. -Lemma min_premise_pos_spec {m prem} : - (0 <= min_premise m prem)%Z -> - forall x, LevelExprSet.In x prem -> levelexpr_k x <= levelexpr_value m x. +Lemma min_premise_pos_spec {m prem k} : + min_premise m prem = Some k -> + forall x, LevelExprSet.In x prem -> Some (Z.of_nat (levelexpr_k x) + k)%Z ≤ levelexpr_value m x. Proof. pose proof (min_premise_spec m prem) as [amin [exmin [inminpre eqminpre]]]. intros hprem x hin. specialize (amin _ hin). unfold min_atom_value in amin. - destruct x as [l k]; cbn in *. unfold levelexpr_value; cbn. - lia. + destruct x as [l k']; cbn in *. unfold levelexpr_value; cbn. + destruct (level_value m l) eqn:he. + - depelim amin. + rewrite H0 in hprem. depelim hprem. constructor. lia. + constructor. + rewrite H in hprem; depelim hprem. + - depelim amin. rewrite H in hprem. depelim hprem. Qed. Definition equal_model (m m' : model) := LevelMap.Equal m m'. @@ -1507,7 +1653,7 @@ Proof. Qed. Lemma v_minus_w_bound_spec W m : - forall x, ~ LevelSet.In x W -> level_value m x <= v_minus_w_bound W m. + forall x, ~ LevelSet.In x W -> level_value m x ≤ Some (v_minus_w_bound W m). Proof. intros x him. unfold v_minus_w_bound. @@ -1521,7 +1667,7 @@ Proof. rewrite (LevelMap.find_1 H) //. destruct (LevelMap.find _ m) eqn:hl' => //. eapply LevelMap.find_2 in hl'. - assert (LevelMap.MapsTo x n fm). + assert (LevelMap.MapsTo x z fm). eapply LevelMapFact.filter_iff. tc. split => //. now rewrite [_ = true]not_mem. now rewrite (LevelMap.find_1 H) in hl. } @@ -1530,13 +1676,14 @@ Proof. - intros m' em. unfold level_value. destruct LevelMap.find eqn:hl => //. eapply LevelMap.find_2 in hl. - now apply em in hl. + now apply em in hl. constructor. - intros k e a m' m'' map nin hadd. red in hadd. unfold level_value. cbn. rewrite hadd LevelMapFact.F.add_o. - destruct LevelMap.OT.eq_dec. do 2 red in e0. subst x. lia. - destruct LevelMap.find; lia. + destruct LevelMap.OT.eq_dec. do 2 red in e0. subst x. + intros hf. constructor. lia. + destruct LevelMap.find => hf; depelim hf; constructor; lia. Qed. Lemma clauses_levels_restrict_clauses cls W : @@ -1598,7 +1745,7 @@ Definition check_model_invariants cls w m w' m' (modified : bool) := let cll := (levelexpr_level (concl cl)) in [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' & - level_value m cll < level_value m' cll] & + opt_le Z.lt (level_value m cll) (level_value m' cll)] & model_extension w' m m'] else (w, m) = (w', m'). @@ -1628,9 +1775,10 @@ Proof. now setoid_rewrite <-eqcls. Qed. -Lemma min_atom_value_levelexpr_value m l : Z.to_nat (min_atom_value m l) <= levelexpr_value m l - l. +Lemma min_atom_value_levelexpr_value m l a lv : min_atom_value m l = Some a -> levelexpr_value m l = Some lv -> (a <= (lv - Z.of_nat l))%Z. Proof. - destruct l as [l k]; cbn. unfold levelexpr_value. cbn. lia. + destruct l as [l k]; cbn. unfold levelexpr_value. cbn. destruct level_value => //. + intros [= <-] [= <-]. lia. Qed. Lemma clauses_conclusions_add cl cls : @@ -1667,6 +1815,19 @@ Proof. intros heq. red in heq; subst l'. apply hin. now left. Qed. +Lemma opt_lt_le_trans x y z : + opt_le Z.lt x y -> + opt_le Z.le y z -> + opt_le Z.lt x z. +Proof. + intros [] H'; depelim H'; constructor. lia. +Qed. + +Lemma level_value_not_above_spec m l k : level_value_above m l k = false -> opt_le Z.lt (level_value m l) (Some k). +Proof. + unfold level_value_above; destruct level_value => // hlt; constructor. lia. +Qed. + Lemma check_clause_model_modify' {cl cls w m w' m' w'' m'' modified modified'} : check_model_invariants cls w m w' m' modified -> declared_model_level m (clause_conclusion cl) -> @@ -1693,10 +1854,9 @@ Proof. * intros [= <- ->]. move: upd. unfold update_value. - case: Z.ltb_spec => //. + destruct min_premise as [hmin|] eqn:eqmin => //. destruct cl as [prem [l k]] => /=. - intros hprem. - case: Nat.leb_spec => // hlt. + destruct level_value_above eqn:hval => //. intros [= <- <-]. destruct modified; noconf inv. { destruct inv. @@ -1707,13 +1867,14 @@ Proof. intuition eauto. cbn. apply H0 in H4. lsets. + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. destruct H1 as [cl []]; exists cl; split => //. eauto. eauto. - eapply Nat.lt_le_trans; tea. + destruct (level_value m (concl cl)) as [vconcl|] eqn:hconcl; [|constructor]. + eapply opt_lt_le_trans; tea. eapply model_le_values. - now eapply update_model_monotone. + now eapply update_model_not_above. + transitivity m'. { eapply model_extension_weaken; tea. lsets. } split. - { now eapply update_model_monotone. } + { now eapply update_model_not_above. } { eapply update_model_same_domain. eapply H2, declcl. } { eapply update_model_outside. } } @@ -1725,12 +1886,10 @@ Proof. + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. exists (prem, (l, k)). split; tea; eauto. - - unfold valid_clause. cbn. - case: Z.ltb_spec => //. cbn. lia. intros _. - rewrite -Nat.ltb_antisym. apply Nat.ltb_lt; lia. - - cbn. now rewrite level_value_update_model. + - unfold valid_clause. cbn. now rewrite eqmin hval /=. + - cbn. rewrite level_value_update_model. now apply level_value_not_above_spec. + split. - { now eapply update_model_monotone. } + { now eapply update_model_not_above. } { eapply update_model_same_domain. eapply declcl. } { eapply update_model_outside. } } @@ -1830,71 +1989,116 @@ Proof. now eapply check_model_aux_model_le in caux. Qed. +Definition level_value_default m l := + match level_value m l with Some x => x | None => 0 end%Z. + Definition measure_w W cls m w := - let bound := v_minus_w_bound W m in - let maxgain := max_gain (cls_diff cls W) in - (Z.of_nat bound + Z.of_nat maxgain - Z.of_nat (level_value m w))%Z. + let bound := v_minus_w_bound W m in + let maxgain := max_gain (cls_diff cls W) in + (bound + Z.of_nat maxgain - level_value_default m w)%Z. + +Lemma min_premise_max_premise m prem k : + min_premise m prem = Some k -> + exists k', max_premise_value m prem = Some k'. +Proof. + unfold min_premise, max_premise_value. + destruct to_nonempty_list. + assert (forall l k, fold_left + (fun (min : option Z) (atom : LevelExpr.t) => + option_map2 Z.min (let '(l0, k0) := atom in match level_value m l0 with + | Some val => Some (val - Z.of_nat k0)%Z + | None => None + end) min) + l None = + Some k -> False). + { clear. induction l; cbn => //. cbn in *. + destruct a, level_value; cbn; auto. } + assert + (forall x y, fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (Some x) = Some k -> +exists k' : Z, + fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.max (levelexpr_value m atom) min) l (Some y) = Some k'). + { induction l; cbn. + - intros x y [= <-]. now eexists. + - intros x y. + unfold min_atom_value, levelexpr_value, levelexpr_level. destruct a; cbn. + destruct level_value => //=. eapply IHl. cbn. intros H'. exfalso. + eapply H; eauto. } + - unfold min_atom_value, levelexpr_value, levelexpr_level. destruct t; cbn. + destruct level_value => //=. apply H0. + intros; exfalso. now eapply H. +Qed. Lemma invalid_clause_measure W cls cl m : + model_of W m -> ~~ valid_clause m cl -> Clauses.In cl (cls_diff cls W) -> (0 < measure_w W cls m (concl cl))%Z. Proof. - unfold valid_clause. - case: Z.ltb_spec => // hprem. + intros hwv. unfold valid_clause. + (* case: Z.ltb_spec => // hprem. *) destruct cl as [prem [l k]]; cbn. - case: Nat.leb_spec => // hlt. intros _ hin. + destruct min_premise eqn:hmin => //. + move/negbTE/level_value_not_above_spec => hlt hin. have hne := (non_W_atoms_ne _ _ _ hin). cbn. unfold measure_w. unfold gain. set (clsdiff := Clauses.diff _ _). set (bound := v_minus_w_bound W m). - enough (Z.of_nat (level_value m l) < Z.of_nat bound + Z.of_nat (max_gain clsdiff))%Z. lia. + enough (level_value_default m l < bound + Z.of_nat (max_gain clsdiff))%Z. lia. set (prem' := non_W_atoms W prem). set (preml := {| t_set := prem'; t_ne := hne |}). - assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff). + assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff)%nat. { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. unfold gain. cbn. pose proof (premise_min_subset preml prem). rewrite !Z2Nat.inj_sub //; try lia. rewrite !Nat2Z.id. forward H. eapply non_W_atoms_subset. lia. } - eapply Z.lt_le_trans with (Z.of_nat bound + Z.of_nat (Z.to_nat (gain (preml, (l, k)))))%Z; try lia. - rewrite -Nat2Z.inj_add. + eapply Z.lt_le_trans with (bound + Z.of_nat (Z.to_nat (gain (preml, (l, k)))))%Z; try lia. unfold gain; cbn. - enough (level_value m l < v_minus_w_bound W m + (k - premise_min preml)). lia. - enough (k + Z.to_nat (min_premise m prem) <= v_minus_w_bound W m + (k - premise_min preml)). lia. - assert (min_premise m prem <= min_premise m preml)%Z. + enough (level_value_default m l < v_minus_w_bound W m + Z.of_nat (k - premise_min preml))%Z. lia. + unfold level_value_default. destruct (level_value m l) as [vl|] eqn:hl; revgoals. + { apply LevelMapFact.F.not_find_in_iff in hl. elim hl. apply hwv. + eapply Clauses.diff_spec in hin as [hin _]. + now apply in_clauses_with_concl in hin as [hin _]. } + depelim hlt. + enough (Z.of_nat k + z <= v_minus_w_bound W m + Z.of_nat (k - premise_min preml))%Z. lia. + assert (min_premise m prem ≤ min_premise m preml)%Z. { eapply min_premise_subset. eapply non_W_atoms_subset. } - transitivity (k + Z.to_nat (min_premise m preml)). lia. + rewrite hmin in H1. depelim H1. + transitivity (Z.of_nat k + y)%Z. lia. pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. - pose proof (max_premise_value_spec m preml) as [amax [exmax [inmaxpre eqmaxpre]]]. + have [maxpreml eqmax] := min_premise_max_premise m preml _ H2. + pose proof (max_premise_value_spec m preml _ eqmax) as [amax [exmax [inmaxpre eqmaxpre]]]. pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. - assert (premise_min prem <= premise_min preml). + assert (premise_min prem <= premise_min preml)%nat. { eapply premise_min_subset. eapply non_W_atoms_subset. } - transitivity (v_minus_w_bound W m + (k - premise_min preml)). 2:lia. - assert (Z.to_nat (min_premise m preml) <= max_premise_value m preml - premise_min preml). - { rewrite eqpminpre eqmaxpre eqminpre. - pose proof (min_atom_value_levelexpr_value m exmin). etransitivity; tea. - specialize (amax _ inminpre). rewrite eqmaxpre in amax. - assert (expmin <= exmin). specialize (apmin _ inminpre). lia. + (* transitivity (v_minus_w_bound W m + (k - premise_min preml)). 2:lia. *) + assert (y <= maxpreml - Z.of_nat (premise_min preml))%Z. + { rewrite eqpminpre. rewrite H2 in eqminpre; symmetry in eqminpre. + (* eqmaxpre eqminpre. *) + pose proof (min_atom_value_levelexpr_value m exmin). + specialize (amax _ inminpre) as amax'. rewrite eqmaxpre in amax'. + destruct amax' as [vexmin [eqexmin ltexmin]]. + assert (expmin <= exmin)%nat. specialize (apmin _ inminpre). lia. + specialize (H4 _ _ eqminpre eqexmin). depelim ltexmin. etransitivity; tea. + rewrite -eqmaxpre in H6. noconf H6. unfold level_expr_elt in *. lia. } - transitivity (k + (max_premise_value m preml - premise_min preml)). lia. - assert (premise_min preml <= max_premise_value m preml). + transitivity (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)))%Z. lia. + (* assert (Z.of_nat (premise_min preml) <= maxpreml)%Z. { rewrite eqmaxpre. move/min_premise_pos_spec: hprem => hprem. transitivity exmax. apply apmin => //. eapply hprem. - now apply (non_W_atoms_subset W prem). } - assert (k + (max_premise_value m preml - premise_min preml) = - (max_premise_value m preml + k - premise_min preml)) as ->. lia. - enough (max_premise_value m preml <= v_minus_w_bound W m). lia. - { rewrite eqmaxpre. - apply v_minus_w_bound_spec. - intros hin'. + now apply (non_W_atoms_subset W prem). } *) + assert (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)) = + (maxpreml + Z.of_nat k - Z.of_nat (premise_min preml)))%Z as ->. lia. + enough (maxpreml <= v_minus_w_bound W m)%Z. lia. + { have vm := v_minus_w_bound_spec W m exmax. unfold levelexpr_value in eqmaxpre. + rewrite -eqmaxpre in vm. have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). rewrite levelexprset_levels_spec in hlevels. forward hlevels. exists exmax.2. now destruct exmax. rewrite LevelSet.diff_spec in hlevels. - now destruct hlevels. } + destruct hlevels as [_ nw]. specialize (vm nw). now depelim vm. } Qed. Definition levelset_m_eq : LevelSet.t × model -> LevelSet.t × model -> Prop := @@ -1946,19 +2150,27 @@ Proof. now rewrite hm. Qed. +#[local] Instance level_value_above_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> eq) level_value_above. +Proof. + intros m m' hm ? ? -> ? ? ->. + unfold level_value_above. + now rewrite hm. +Qed. + #[local] Instance check_clause_model_proper : Proper (eq ==> modified_levelset_m_eq ==> modified_levelset_m_eq) check_clause_model. Proof. intros x y eq [? []] [? []] []; cbn in *; subst. unfold levelset_m_eq in H0. destruct H0; cbn in *; subst. replace (min_premise m (premise y)) with (min_premise m0 (premise y)). 2: now rewrite H0. - destruct Z.ltb => //. + destruct min_premise. destruct concl => //. - replace (level_value m t1) with (level_value m0 t1). + replace (level_value_above m t1 (Z.of_nat n + z)) with (level_value_above m0 t1 (Z.of_nat n + z)). 2:now rewrite H0. - destruct Nat.leb => //. + destruct level_value_above => //. red. cbn. split => //. red. cbn; split => //. now rewrite H. now rewrite H0. + red. cbn. split => //. Qed. Module ClausesOrd := OrdProperties Clauses. @@ -2021,8 +2233,55 @@ Extraction Inline model_model. Definition valid_model := valid_model_def. +Inductive entails (cls : clauses) : clause -> Prop := +| clause_in (prems : nonEmptyLevelExprSet) (cl : LevelExpr.t) : LevelExprSet.In cl prems -> entails cls (prems, cl) +| clause_cut prems' concl' prems concl : + Clauses.In (prems', concl') cls -> + entails cls (add concl' prems, concl) -> + LevelExprSet.Subset prems' prems -> + entails cls (prems, concl). + +(* Definition succ_expr '((l, k) : LevelExpr.t) := (l, k + 1). +Definition succ_prems s := map (fun '(l, k) => (l, k + 1)) s. +Definition succ_clause '((prems, concl) : clause) := (succ_prems prems, succ_expr concl). +Lemma succ_clause_inj x y : succ_clause x = succ_clause y -> x = y. +Proof. Admitted. +Definition succ_clauses cls := ClausesProp.of_list (List.map (fun cl => succ_clause cl) (ClausesProp.to_list cls)). +Import SetoidList. +Lemma succ_clauses_spec cl cls : Clauses.In cl cls <-> Clauses.In (succ_clause cl) (succ_clauses cls). +Proof. + unfold succ_clauses. + rewrite ClausesProp.of_list_1 InA_In_eq in_map_iff. + firstorder eauto. + - exists cl; split => //. unfold ClausesProp.to_list. now eapply Clauses_In_elements. + - eapply Clauses_In_elements in H0. apply succ_clause_inj in H. now subst. +Qed. + +Lemma entails_plus cls c : entails cls c -> entails (succ_clauses cls) (succ_clause c). +Proof. + induction 1. + - constructor. apply map_spec. exists cl. split => //. + - eapply clause_cut with (succ_prems prems') (succ_expr concl'). + + now rewrite -(succ_clauses_spec (prems', concl')). + + admit. + + admit. +Admitted. + +Definition to_clauses (prems : nonEmptyLevelExprSet) (concl : nonEmptyLevelExprSet) : clauses := + LevelExprSet.fold (fun lk cls => Clauses.add (prems, lk) cls) concl Clauses.empty. + +Definition is_loop (cls : clauses) (t : nonEmptyLevelExprSet) := + let cls' := to_clauses t (succ_prems t) in + Clauses.For_all (fun cl' => entails cls cl') cls'. + *) +(* Definition is_looping (w : LevelSet.t) n (cls : clauses) := + let preml := LevelSet.elements w in + let prem := List.map (fun e => (e, n)) preml in + is_loop cls prem. *) + Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := | Loop + (* (w : LevelSet.t) (n : nat) (islooping : loop_on w n cls) *) | Model (w : LevelSet.t) (m : valid_model V m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). Arguments Loop {V U cls m}. Arguments Model {V U cls m}. @@ -2065,7 +2324,7 @@ Qed. *) Notation "#| V |" := (LevelSet.cardinal V). -Notation loop_measure V W := (#|V|, #|V| - #|W|). +Notation loop_measure V W := (#|V|, #|V| - #|W|)%nat. Definition lexprod_rel := lexprod lt lt. @@ -2080,21 +2339,28 @@ Section InnerLoop. (prf : [/\ clauses_conclusions cls ⊂_lset V', U' ⊂_lset V' & model_of V' m]), lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls m). - Definition sum_W W (f : LevelSet.elt -> nat) := - LevelSet.fold (fun w acc => acc + f w) W 0. + Definition sum_W W (f : LevelSet.elt -> nat) : nat := + LevelSet.fold (fun w acc => acc + f w)%nat W 0%nat. Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := sum_W W (fun w => Z.to_nat (measure_w W cls m w)). + Lemma maps_to_value_default {x k m} : LevelMap.MapsTo x k m -> level_value m x = Some k. + Proof. + intros h; apply LevelMap.find_1 in h. + now rewrite /level_value h. + Qed. + Lemma measure_model W cls m : + model_of W m -> let clsdiff := cls_diff cls W in - measure W cls m = 0 -> is_model clsdiff m. + measure W cls m = 0%nat -> is_model clsdiff m. Proof using. clear loop V U. unfold measure, sum_W, measure_w, is_model. set (clsdiff := Clauses.diff _ _). - intros hm. - assert (LevelSet.For_all (fun w => v_minus_w_bound W m + max_gain clsdiff <= level_value m w) W). + intros hv hm. + assert (LevelSet.For_all (fun w => Some (v_minus_w_bound W m + Z.of_nat (max_gain clsdiff)) ≤ level_value m w)%Z W). { move: hm. generalize (v_minus_w_bound W m) => vbound. eapply LevelSetProp.fold_rec. @@ -2102,92 +2368,140 @@ Section InnerLoop. intros x a s' s'' inw nins' hadd ih heq. forward ih by lia. intros l hin. + specialize (hv _ inw) as [k lv]. rewrite /level_value_default (maps_to_value_default lv) in heq. apply hadd in hin as []. - * subst x. lia. + * subst x. rewrite (maps_to_value_default lv). constructor. lia. * now apply ih. } clear hm. eapply ClausesFact.for_all_iff. tc. intros cl hl. unfold valid_clause. - case: Z.ltb_spec => // hk0. - destruct cl as [prem [l k]] => /=. - eapply Nat.leb_le. cbn in hk0. + destruct min_premise as [k0|] eqn:hk0 => //. + destruct cl as [prem [l k]] => /=. cbn in hk0. rewrite /clsdiff in hl. destruct (proj1 (Clauses.diff_spec _ _ _) hl) as [hlcls hl']. eapply in_clauses_with_concl in hlcls as [lW incls]. specialize (H _ lW). cbn -[clsdiff] in H. cbn in lW. - etransitivity; tea. + specialize (hv _ lW) as [vl hvl]. rewrite /level_value_above (maps_to_value_default hvl). + rewrite (maps_to_value_default hvl) in H; depelim H. + (* etransitivity; tea. *) set (prem' := non_W_atoms W prem). assert (ne : LevelExprSet.is_empty prem' = false). { now eapply (non_W_atoms_ne W (prem, (l, k)) cls). } set (preml := {| t_set := prem'; t_ne := ne |}). - assert (min_premise m prem <= min_premise m preml)%Z. + assert (min_premise m prem ≤ min_premise m preml). { eapply min_premise_subset. eapply non_W_atoms_subset. } (* min_i (f(x_i)-k_i) <= max_i(f(x_i)) - min(k_i) *) pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. - pose proof (max_premise_value_spec m preml) as [amax [exmax [inmaxpre eqmaxpre]]]. + rewrite hk0 in H0. depelim H0. rename y into minpreml. + pose proof (min_premise_max_premise _ _ _ H1) as [maxpreml eqmaxp]. + pose proof (max_premise_value_spec m preml _ eqmaxp) as [amax [exmax [inmaxpre eqmaxpre]]]. + rewrite -eqmaxp in eqmaxpre. pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. - assert (Z.to_nat (min_premise m preml) <= - (max_premise_value m preml) - premise_min preml). - { rewrite eqpminpre eqmaxpre eqminpre. - pose proof (min_atom_value_levelexpr_value m exmin). etransitivity; tea. - specialize (amax _ inminpre). rewrite eqmaxpre in amax. - assert (expmin <= exmin). specialize (apmin _ inminpre). lia. + assert (min_premise m preml ≤ Some (maxpreml - Z.of_nat (premise_min preml)))%Z. + { rewrite eqminpre in H1. + specialize (amax _ inminpre). destruct amax as [k' [lk' hk']]. + depelim hk'. + pose proof (min_atom_value_levelexpr_value m exmin _ _ H2 lk'). + rewrite eqminpre H2. constructor. etransitivity; tea. + rewrite eqmaxpre in eqmaxp. + assert (expmin <= exmin)%nat. specialize (apmin _ inminpre). lia. unfold level_expr_elt in *. lia. } - transitivity (k + (max_premise_value m preml - premise_min preml)). lia. - assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff). + apply Z.leb_le. rewrite H1 in H2. depelim H2. + transitivity (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)))%Z. lia. + assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff)%nat. { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. unfold gain. cbn. pose proof (premise_min_subset preml prem). rewrite !Z2Nat.inj_sub //; try lia. rewrite !Nat2Z.id. - forward H2. eapply non_W_atoms_subset. lia. } - transitivity (v_minus_w_bound W m + Z.to_nat (gain (preml, (l, k)))). + forward H3. eapply non_W_atoms_subset. lia. } + transitivity (v_minus_w_bound W m + (gain (preml, (l, k))))%Z. 2:lia. unfold gain. cbn -[max_premise_value premise_min]. - assert (premise_min preml <= max_premise_value m preml). - { rewrite eqmaxpre. + (* assert (Z.of_nat (premise_min preml) <= maxpreml)%Z. + { + (* rewrite eqmaxpre. *) move/min_premise_pos_spec: hk0 => hprem. - transitivity exmax. apply apmin => //. eapply hprem. - now apply (non_W_atoms_subset W prem). } - assert (k + (max_premise_value m preml - premise_min preml) = - (max_premise_value m preml + k - premise_min preml)) as ->. lia. - rewrite Z2Nat.inj_sub. lia. - rewrite !Nat2Z.id. - assert (max_premise_value m preml <= v_minus_w_bound W m). - { rewrite eqmaxpre. - apply v_minus_w_bound_spec. - intros hin. + transitivity (Z.of_nat (levelexpr_k exmax)). + specialize (apmin _ inmaxpre). now apply inj_le. + rewrite eqmaxp in eqmaxpre. unfold levelexpr_value in eqmaxpre. + unfold levelexpr_k. + specialize (amax _ inmaxpre) as [k' [eqk' k'max]]. + eapply hprem. + now apply (non_W_atoms_subset W prem). } *) + assert (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)) = + (maxpreml + Z.of_nat k - Z.of_nat (premise_min preml)))%Z as ->. lia. + (* rewrite Z2Nat.inj_sub. lia. *) + (* rewrite !Nat2Z.id. *) + assert (maxpreml <= v_minus_w_bound W m)%Z. + { pose proof (v_minus_w_bound_spec W m exmax). have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). rewrite levelexprset_levels_spec in hlevels. forward hlevels. exists exmax.2. now destruct exmax. rewrite LevelSet.diff_spec in hlevels. - now destruct hlevels. } + destruct hlevels. + forward H4 by auto. + rewrite eqmaxp in eqmaxpre. unfold levelexpr_value in eqmaxpre. rewrite -eqmaxpre in H4. + now depelim H4. + } lia. Qed. + Lemma level_value_default_def {m x v} : level_value m x = Some v -> level_value_default m x = v. + Proof. unfold level_value_default. now intros ->. Qed. + + Lemma w_values_ext m m' W : + m ⩽ m' -> model_of W m -> model_of W m'. + Proof. + intros ext hf x hin. + specialize (hf x hin) as [k hl]. + specialize (ext _ _ hl) as [? []]. + now exists x0. + Qed. + + Lemma level_values_in_W m m' W x : + model_of W m -> + m ⩽ m' -> + LevelSet.In x W -> level_value m x ≤ level_value m' x -> + exists k k', level_value m x = Some k /\ level_value m' x = Some k' /\ (k <= k')%Z. + Proof. + intros hwv ext hin hleq. + specialize (hwv _ hin) as x'. destruct x' as [k hl]. rewrite (maps_to_value_default hl) in hleq. + eapply w_values_ext in hwv; tea. + specialize (hwv _ hin) as [k' hl']. + rewrite (maps_to_value_default hl') in hleq. depelim hleq. + do 2 eexists. intuition eauto. + now rewrite (maps_to_value_default hl). + now rewrite (maps_to_value_default hl'). + Qed. + Lemma measure_le {W cls m m'} : + model_of W m -> model_map_outside W m m' -> m ⩽ m' -> - (measure W cls m' <= measure W cls m). + (measure W cls m' <= measure W cls m)%nat. Proof. - intros hout hle. + intros hwv hout hle. unfold measure, measure_w, sum_W. rewrite (v_minus_w_bound_irrel _ _ hout). rewrite !LevelSet.fold_spec. unfold flip. eapply fold_left_le; unfold flip. 2:lia. - intros. rewrite LevelSet_In_elements in H. have lexx' := (model_le_values x hle). - lia. + eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. + erewrite !level_value_default_def; tea. lia. Qed. Lemma measure_lt {W cls m m'} : + model_of W m -> model_map_outside W m m' -> m ⩽ m' -> - (exists l, [/\ LevelSet.In l W, (0 < measure_w W cls m l)%Z & level_value m l < level_value m' l]) -> - (measure W cls m' < measure W cls m). + (exists l, [/\ LevelSet.In l W, (0 < measure_w W cls m l)%Z & + opt_le Z.lt (level_value m l) (level_value m' l)])%Z -> + (measure W cls m' < measure W cls m)%nat. Proof. - intros hout hle. + intros hwv hout hle. unfold measure, measure_w, sum_W. rewrite (v_minus_w_bound_irrel _ _ hout). intros hlt. @@ -2198,14 +2512,18 @@ Section InnerLoop. - destruct hlt as [l [hin _]]. intros he. rewrite -LevelSetProp.elements_Empty in he. lsets. - intros. rewrite LevelSet_In_elements in H. have lexx' := (model_le_values x hle). - lia. + eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. + erewrite !level_value_default_def; tea. lia. - intros. rewrite LevelSet_In_elements in H. have lexx' := (model_le_values x hle). - lia. + eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. + erewrite !level_value_default_def; tea. lia. - destruct hlt as [l [hinl hbound hlev]]. exists l. rewrite LevelSet_In_elements. split => //. intros acc acc' accle. - eapply Nat.add_le_lt_mono => //. lia. + eapply Nat.add_le_lt_mono => //. + depelim hlev. rewrite /level_value_default ?H0 ?H1 in hbound |- *. + lia. apply LevelMapFact.F.not_find_in_iff in H. now apply hwv in hinl. Qed. Lemma is_model_equal {cls cls' m} : Clauses.Equal cls cls' -> is_model cls m -> is_model cls' m. @@ -2241,12 +2559,12 @@ Section InnerLoop. Lemma measure_Z_lt x y : (x < y)%Z -> (0 < y)%Z -> - Z.to_nat x < Z.to_nat y. + (Z.to_nat x < Z.to_nat y)%nat. Proof. intros. lia. Qed. Lemma sum_pos W f : - (0 < sum_W W f) -> - exists w, LevelSet.In w W /\ (0 < f w). + (0 < sum_W W f)%nat -> + exists w, LevelSet.In w W /\ (0 < f w)%nat. Proof. unfold sum_W. eapply LevelSetProp.fold_rec => //. @@ -2258,7 +2576,7 @@ Section InnerLoop. Qed. Lemma measure_pos {W cls m} : - (0 < measure W cls m) -> + (0 < measure W cls m)%nat -> exists l, LevelSet.In l W /\ (0 < measure_w W cls m l)%Z. Proof. unfold measure. @@ -2282,7 +2600,7 @@ Section InnerLoop. exists cl : clause, let cll := levelexpr_level (concl cl) in [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' - & level_value m cll < level_value m' cll] + & (opt_le Z.lt (level_value m cll) (level_value m' cll))%Z] & model_extension w' m m']. Proof. cbn; intros mof cm. @@ -2378,15 +2696,16 @@ Section InnerLoop. pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). destruct hm as [cll [hind nvalid inwconcl hl]]. eapply Nat.lt_le_trans. - 2:{ eapply measure_le; eapply mr. } + 2:{ eapply measure_le; eauto; eapply mr. } eapply measure_lt. + { eapply mr. } { eapply model_map_outside_weaken. eapply hext. lsets. } { apply hext. } eapply invalid_clause_measure in nvalid; tea. exists (levelexpr_level (concl cll)). split => //. eapply clauses_conclusions_diff_left; tea. - eapply clauses_conclusions_spec. exists cll; split => //. exact hind. + eapply clauses_conclusions_spec. exists cll; split => //. exact hind. apply mr. - apply mr'. (* - apply clauses_conclusions_clauses_with_concl. *) - apply mr'. @@ -2426,6 +2745,7 @@ Section InnerLoop. End InnerLoop. +Local Open Scope nat_scope. Lemma diff_cardinal_inter V W : #|LevelSet.diff V W| = #|V| - #|LevelSet.inter V W|. Proof. pose proof (LevelSetProp.diff_inter_cardinal V W). lia. @@ -2602,7 +2922,7 @@ Definition zero_model levels := Definition add_max l k m := match LevelMap.find l m with | Some k' => - if k' LevelMap.add l k m end. @@ -2616,12 +2936,12 @@ Proof. Qed. Lemma In_add_max l l' k acc : - LevelMap.In (elt:=nat) l (add_max l' k acc) <-> + LevelMap.In (elt:=Z) l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). Proof. unfold add_max. destruct LevelMap.find eqn:hl. - case: Nat.ltb_spec. + case: Z.ltb_spec. - rewrite LevelMapFact.F.add_in_iff /Level.eq. firstorder eauto. - intros. intuition auto. subst. @@ -2630,9 +2950,9 @@ Proof. Qed. Lemma In_fold_add_max k n a : - LevelMap.In (elt:=nat) k + LevelMap.In (elt:=Z) k (LevelExprSet.fold - (fun '(l, k0) (acc : LevelMap.t nat) => add_max l k0 acc) n a) <-> + (fun '(l, k0) (acc : LevelMap.t Z) => add_max l (Z.of_nat k0) acc) n a) <-> (LevelSet.In k (levels n)) \/ LevelMap.In k a. Proof. eapply LevelExprSetProp.fold_rec. @@ -2654,7 +2974,7 @@ Proof. Qed. -(* To handle the constraint checking decision problem, +(* To handle the constraint inference problem, we must start with a model where all atoms [l + k] appearing in premises are true. Otherwise the [l := 0] model is minimal for [l+1-> l+2]. @@ -2664,10 +2984,10 @@ Qed. *) -Definition min_model_map (m : LevelMap.t nat) cls : LevelMap.t nat := +Definition min_model_map (m : LevelMap.t Z) cls : LevelMap.t Z := Clauses.fold (fun '(cl, concl) acc => LevelExprSet.fold (fun '(l, k) acc => - add_max l k acc) cl (add_max (levelexpr_level concl) 0 acc)) cls m. + add_max l (Z.of_nat k) acc) cl (add_max (levelexpr_level concl) 0%Z acc)) cls m. Lemma min_model_map_levels m cls k : LevelMap.In k (min_model_map m cls) <-> @@ -2721,17 +3041,28 @@ Equations? infer (cls : clauses) : infer_result (clauses_levels cls) cls := Proof. - now eapply clauses_conclusions_levels. - lsets. - - now eapply init_model_levels. + - red. now eapply init_model_levels. Qed. +Local Open Scope Z_scope. +Lemma max_min max min k : min <= 0 -> max >= 0 -> k <= max -> k >= min -> (max - k - min) >= 0. +Proof. lia. Qed. + Definition valuation_of_model (m : model) : LevelMap.t nat := - let max := LevelMap.fold (fun l k acc => Nat.max k acc) m 0 in - LevelMap.fold (fun l k acc => LevelMap.add l (max - k) acc) m (LevelMap.empty _). + let '(min, max) := LevelMap.fold (fun l k '(min, max) => (Z.min min k, Z.max k max)) m (0, 0)%Z in + LevelMap.fold (fun l k acc => LevelMap.add l (Z.to_nat (max - k - min)) acc) m (LevelMap.empty _). +Close Scope Z_scope. + +Local Open Scope string_scope2. + +Definition print_level_Z_map (m : LevelMap.t Z) := + let list := LevelMap.elements m in + print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_Z w) nl list. Definition print_result {V cls} (m : infer_result V cls) := - match m with + match m return string with | Loop => "looping" - | Model w m _ => "satisfiable with model: " ^ print_level_nat_map m.(model_model) ^ nl ^ " W = " ^ + | Model w m _ => "satisfiable with model: " ^ print_level_Z_map m.(model_model) ^ nl ^ " W = " ^ print_lset w ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model m.(model_model)) end. @@ -2800,7 +3131,7 @@ Definition enforce_clause {V init cls} (m : valid_model V init cls) cl : option Inductive constraint_type := UnivEq | UnivLe. -Notation constraint := (nonEmptyLevelExprSet * constraint_type * nonEmptyLevelExprSet). +Notation constraint := (nonEmptyLevelExprSet * constraint_type * nonEmptyLevelExprSet)%type. Definition enforce_constraint (cstr : constraint) (cls : clauses) : clauses := let '(l, d, r) := cstr in From 3270f4d7f6efce8c2cc0489e661736c86f11b977 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 19 Jul 2025 16:06:53 +0200 Subject: [PATCH 004/164] WIP, add partial models --- template-rocq/theories/LoopChecking.v | 226 ++++++++++++++---- template-rocq/theories/TemplateLoopChecking.v | 41 ++++ .../theories/LoopCheckingPlugin.v | 2 +- 3 files changed, 218 insertions(+), 51 deletions(-) diff --git a/template-rocq/theories/LoopChecking.v b/template-rocq/theories/LoopChecking.v index 1b043ba39..41cc163fb 100644 --- a/template-rocq/theories/LoopChecking.v +++ b/template-rocq/theories/LoopChecking.v @@ -123,6 +123,8 @@ Module Type LoopCheckingItf (Level : LevelOrderedType) Parameter print_result : forall {V cls}, infer_result V cls -> string. + Parameter print_clauses : clauses -> string. + End LoopCheckingItf. Module LoopChecking @@ -599,10 +601,13 @@ Proof. now rewrite LevelSet.union_spec LevelSet.singleton_spec. Qed. -Definition model := LevelMap.t Z. +Definition model := LevelMap.t (option Z). Definition level_value (m : model) (level : Level.t) : option Z := - LevelMap.find level m. + match LevelMap.find level m with + | None => None + | Some v => v + end. Definition levelexpr_value (m : model) (atom : LevelExpr.t) := level_value m (levelexpr_level atom). @@ -632,7 +637,7 @@ Open Scope Z_scope. Definition satisfiable_atom (m : model) (atom : Level.t * nat) : bool := let '(l, k) := atom in - match LevelMap.find l m with + match level_value m l with | Some val => Z.of_nat k <=? val | None => false end. @@ -665,7 +670,7 @@ Inductive update_result := | Holds | DoesntHold (wm : LevelSet.t × model). -Definition update_model (m : model) l v : model := LevelMap.add l v m. +Definition update_model (m : model) l v : model := LevelMap.add l (Some v) m. Definition update_value (wm : LevelSet.t × model) (cl : clause) : update_result := let (w, m) := wm in @@ -805,7 +810,7 @@ Definition in_clauses_conclusions (cls : clauses) (x : Level.t): Prop := exists cl, Clauses.In cl cls /\ (level cl.2) = x. Definition v_minus_w_bound (W : LevelSet.t) (m : model) := - LevelMap.fold (fun w v acc => Z.max v acc) + LevelMap.fold (fun w v acc => Z.max (option_get 0%Z v) acc) (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0%Z. Definition levelexpr_k : LevelExpr.t -> nat := snd. @@ -833,9 +838,30 @@ Proof. intros m l. reflexivity. Qed. #[local] Instance model_same_domain_trans : Transitive model_same_domain. Proof. intros m m' m'' h h' l. rewrite (h l). apply h'. Qed. + +Inductive opt_le {A} (le : relation A) : relation (option A) := +| opt_le_some x y : le x y -> opt_le le (Some x) (Some y) +| opt_le_none_some x : opt_le le None x. +Derive Signature for opt_le. + +Instance opt_le_refl {A} (le : relation A) : Reflexive le -> Reflexive (opt_le le). +Proof. + intros hre x; induction x; constructor; reflexivity. +Qed. + +Instance opt_le_trans {A} (le : relation A) : Transitive le -> Transitive (opt_le le). +Proof. + intros hre x; induction x; destruct y as [y|]; intros z H H'; depelim H; depelim H'; constructor. + now transitivity y. +Qed. + +Definition value_le : relation (option Z) := opt_le Z.le. + +Infix "≤" := value_le (at level 50). + Definition model_le (m m' : model) := forall l k, LevelMap.MapsTo l k m -> - exists k', LevelMap.MapsTo l k' m' /\ k <= k'. + exists k', LevelMap.MapsTo l k' m' /\ k ≤ k'. Infix "⩽" := model_le (at level 70). (* \leqslant *) @@ -1089,47 +1115,27 @@ Proof. move/orP: H1 => [->|] //. move/H0. intros ->. now rewrite orb_true_r. Qed. #[local] Instance model_le_refl : Reflexive model_le. -Proof. intros x l k map. exists k; split => //. lia. Qed. +Proof. intros x l k map. exists k; split => //. reflexivity. Qed. #[local] Instance model_le_trans : Transitive model_le. Proof. intros m m' m'' mm' m'm'' l k map. apply mm' in map as [k' [map ?]]. - apply m'm'' in map as [k'' [map ?]]. exists k''. split => //. lia. + apply m'm'' in map as [k'' [map ?]]. exists k''. split => //. + now transitivity k'. Qed. -Inductive opt_le {A} (le : relation A) : relation (option A) := -| opt_le_some x y : le x y -> opt_le le (Some x) (Some y) -| opt_le_none_some x : opt_le le None x. -Derive Signature for opt_le. - -Instance opt_le_refl {A} (le : relation A) : Reflexive le -> Reflexive (opt_le le). -Proof. - intros hre x; induction x; constructor; reflexivity. -Qed. - -Instance opt_le_trans {A} (le : relation A) : Transitive le -> Transitive (opt_le le). -Proof. - intros hre x; induction x; destruct y as [y|]; intros z H H'; depelim H; depelim H'; constructor. - now transitivity y. -Qed. - -Definition value_le : relation (option Z) := opt_le Z.le. - -Infix "≤" := value_le (at level 50). - Lemma update_model_monotone m l k : level_value m l ≤ Some k -> m ⩽ update_model m l k. Proof. intros hl. intros l' k' maps. unfold update_model. cbn. destruct (eqb_spec l l'). - - exists k. move: hl. subst l'. + - subst l'. exists (Some k). move: hl. unfold level_value. rewrite (LevelMap.find_1 maps). intros hle. split => //. eapply LevelMap.add_1. eapply LevelMap.OT.eq_refl. - now depelim hle. - - exists k'. split => //. apply LevelMap.add_2 => //. lia. + - exists k'. split => //. apply LevelMap.add_2 => //. reflexivity. Qed. Lemma update_model_not_above m l k : level_value_above m l k = false -> m ⩽ update_model m l k. @@ -1250,12 +1256,12 @@ Proof. unfold level_value. destruct LevelMap.find eqn:hl => //. - apply LevelMap.find_2 in hl. specialize (lem _ hl) as [k' [mapsto leq]]. - rewrite (LevelMap.find_1 mapsto). now constructor. - - destruct (LevelMap.find x m'); constructor. + now rewrite (LevelMap.find_1 mapsto). + - constructor. Qed. -Lemma level_value_MapsTo {k e} {m : model} : - LevelMap.MapsTo k e m -> level_value m k = Some e. +Lemma level_value_MapsTo {l k} {m : model} : + LevelMap.MapsTo l k m -> level_value m l = k. Proof. unfold level_value. move=> mapto; rewrite (LevelMap.find_1 mapto) //. @@ -1667,7 +1673,7 @@ Proof. rewrite (LevelMap.find_1 H) //. destruct (LevelMap.find _ m) eqn:hl' => //. eapply LevelMap.find_2 in hl'. - assert (LevelMap.MapsTo x z fm). + assert (LevelMap.MapsTo x o fm). eapply LevelMapFact.filter_iff. tc. split => //. now rewrite [_ = true]not_mem. now rewrite (LevelMap.find_1 H) in hl. } @@ -1682,7 +1688,7 @@ Proof. unfold level_value. cbn. rewrite hadd LevelMapFact.F.add_o. destruct LevelMap.OT.eq_dec. do 2 red in e0. subst x. - intros hf. constructor. lia. + intros hf. destruct e; cbn; constructor. lia. destruct LevelMap.find => hf; depelim hf; constructor; lia. Qed. @@ -1905,6 +1911,24 @@ Proof. now move/hv. Qed. +Definition total_model_of V (m : model) := + forall k, LevelSet.In k V -> exists x, LevelMap.MapsTo k (Some x) m. + +Lemma total_model_of_subset V V' m : + total_model_of V m -> V' ⊂_lset V -> total_model_of V' m. +Proof. + intros ih hv k. specialize (ih k). + now move/hv. +Qed. + +Lemma total_model_of_sub V m : total_model_of V m -> model_of V m. +Proof. + rewrite /total_model_of /model_of. + intros H k hin. specialize (H k hin) as [? ?]. + now exists (Some x). +Qed. +Coercion total_model_of_sub : total_model_of >-> model_of. + Lemma clauses_conclusions_subset {cls cls'} : Clauses.Subset cls cls' -> clauses_conclusions cls ⊂_lset clauses_conclusions cls'. @@ -2028,8 +2052,18 @@ exists k' : Z, intros; exfalso. now eapply H. Qed. +Lemma total_model_of_value_None W m l : + total_model_of W m -> + LevelSet.In l W -> + level_value m l = None -> False. +Proof. + intros tm inw. specialize (tm l inw) as [v hm]. + rewrite /level_value. + now rewrite (LevelMap.find_1 hm). +Qed. + Lemma invalid_clause_measure W cls cl m : - model_of W m -> + total_model_of W m -> ~~ valid_clause m cl -> Clauses.In cl (cls_diff cls W) -> (0 < measure_w W cls m (concl cl))%Z. @@ -2056,7 +2090,7 @@ Proof. unfold gain; cbn. enough (level_value_default m l < v_minus_w_bound W m + Z.of_nat (k - premise_min preml))%Z. lia. unfold level_value_default. destruct (level_value m l) as [vl|] eqn:hl; revgoals. - { apply LevelMapFact.F.not_find_in_iff in hl. elim hl. apply hwv. + { eapply total_model_of_value_None in hl; tea => //. eapply Clauses.diff_spec in hin as [hin _]. now apply in_clauses_with_concl in hin as [hin _]. } depelim hlt. @@ -2345,14 +2379,14 @@ Section InnerLoop. Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := sum_W W (fun w => Z.to_nat (measure_w W cls m w)). - Lemma maps_to_value_default {x k m} : LevelMap.MapsTo x k m -> level_value m x = Some k. + Lemma maps_to_value_default {x k m} : LevelMap.MapsTo x k m -> level_value m x = k. Proof. intros h; apply LevelMap.find_1 in h. now rewrite /level_value h. Qed. Lemma measure_model W cls m : - model_of W m -> + total_model_of W m -> let clsdiff := cls_diff cls W in measure W cls m = 0%nat -> is_model clsdiff m. Proof using. @@ -2452,16 +2486,16 @@ Section InnerLoop. Proof. unfold level_value_default. now intros ->. Qed. Lemma w_values_ext m m' W : - m ⩽ m' -> model_of W m -> model_of W m'. + m ⩽ m' -> total_model_of W m -> total_model_of W m'. Proof. intros ext hf x hin. specialize (hf x hin) as [k hl]. specialize (ext _ _ hl) as [? []]. - now exists x0. + depelim H0. now exists y. Qed. Lemma level_values_in_W m m' W x : - model_of W m -> + total_model_of W m -> m ⩽ m' -> LevelSet.In x W -> level_value m x ≤ level_value m' x -> exists k k', level_value m x = Some k /\ level_value m' x = Some k' /\ (k <= k')%Z. @@ -2477,7 +2511,7 @@ Section InnerLoop. Qed. Lemma measure_le {W cls m m'} : - model_of W m -> + total_model_of W m -> model_map_outside W m m' -> m ⩽ m' -> (measure W cls m' <= measure W cls m)%nat. @@ -2494,7 +2528,7 @@ Section InnerLoop. Qed. Lemma measure_lt {W cls m m'} : - model_of W m -> + total_model_of W m -> model_map_outside W m m' -> m ⩽ m' -> (exists l, [/\ LevelSet.In l W, (0 < measure_w W cls m l)%Z & @@ -2523,7 +2557,7 @@ Section InnerLoop. intros acc acc' accle. eapply Nat.add_le_lt_mono => //. depelim hlev. rewrite /level_value_default ?H0 ?H1 in hbound |- *. - lia. apply LevelMapFact.F.not_find_in_iff in H. now apply hwv in hinl. + lia. now eapply total_model_of_value_None in H; tea. Qed. Lemma is_model_equal {cls cls' m} : Clauses.Equal cls cls' -> is_model cls m -> is_model cls' m. @@ -2617,6 +2651,14 @@ Section InnerLoop. intros k hin. apply dom. now apply mof. Qed. + Lemma total_model_of_ext {W W' m m'} : + total_model_of W m -> model_extension W' m m' -> total_model_of W m'. + Proof. + intros mof [_ dom _]. + intros k hin. destruct (mof k hin). destruct (dom k). + unfold LevelMap.In in H0. apply H0. apply dom. now apply mof. + Qed. + Lemma clauses_partition_spec {cls W allW conclW} : clauses_conclusions cls ⊂_lset W -> Clauses.partition (premise_restricted_to W) cls = (allW, conclW) -> @@ -2661,7 +2703,7 @@ Section InnerLoop. Clauses.Equal premconclW (cls ⇂ W) & Clauses.Equal conclW (Clauses.diff (cls ↓ W) (cls ⇂ W))]). #[tactic="idtac"] - Equations? inner_loop_partition (m : model) (mW : model_of W m) : result W U cls m + Equations? inner_loop_partition (m : model) (mW : total_model_of W m) : result W U cls m by wf (measure W cls m) lt := inner_loop_partition m mW with loop W LevelSet.empty premconclW m _ _ := { (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) @@ -2688,7 +2730,7 @@ Section InnerLoop. all:try destruct prf as [WV neW UW clsW eqprem eqconcl]. all:try solve [intuition auto]. all:try rewrite eqconcl in eqm. - - split => //. rewrite eqprem. apply clauses_conclusions_restrict_clauses. lsets. + - split => //. rewrite eqprem. apply clauses_conclusions_restrict_clauses. lsets. exact mW. - left. now eapply strict_subset_cardinal. - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. eapply model_of_ext. 2:tea. apply mr. @@ -2696,7 +2738,7 @@ Section InnerLoop. pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). destruct hm as [cll [hind nvalid inwconcl hl]]. eapply Nat.lt_le_trans. - 2:{ eapply measure_le; eauto; eapply mr. } + 2:{ eapply measure_le; eauto; try eapply mr. } eapply measure_lt. { eapply mr. } { eapply model_map_outside_weaken. eapply hext. lsets. } @@ -3151,4 +3193,88 @@ Definition clauses_of_list := ClausesProp.of_list. Definition list_of_clauses := Clauses.elements. Definition valuation := LevelMap.t nat. +Definition premises_model_map (m : LevelMap.t Z) cls : LevelMap.t Z := + Clauses.fold (fun '(cl, concl) acc => + LevelExprSet.fold (fun '(l, k) acc => + add_max l (Z.of_nat k) acc) cl acc) cls m. + +Definition clauses_premises_levels (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls LevelSet.empty. + +Lemma clauses_premises_levels_spec_aux l cls acc : + LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls acc) <-> + (exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl))) \/ LevelSet.In l acc. +Proof. + eapply ClausesProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k [hin hl]]. clsets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.union_spec. + split. + * intros [hin'|]. + left. exists x. split => //. + apply hadd. now left. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. + * intros [[k [ins'' ?]]|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma clauses_premises_levels_spec l cls : + LevelSet.In l (clauses_premises_levels cls) <-> + exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl)). +Proof. + unfold clauses_premises_levels. + rewrite clauses_premises_levels_spec_aux. + intuition auto. lsets. +Qed. + +Lemma premises_model_map_levels m cls k : + LevelMap.In k (premises_model_map m cls) <-> + LevelSet.In k (clauses_premises_levels cls) \/ LevelMap.In k m. +Proof. + rewrite /premises_model_map. + rewrite clauses_premises_levels_spec. + eapply ClausesProp.fold_rec. + - intros s' he. intuition auto. + destruct H0 as [cl []]. + clsets. + - intros x a s' s'' inx ninx hadd ih. + destruct x as [cl k']. + rewrite In_fold_add_max ih. + intuition auto. + * left. exists (cl, k'); intuition auto. + apply hadd. now left. + * destruct H as [cl'' []]. left. exists cl''. + intuition auto. apply hadd. now right. + * destruct H3 as [cl'' []]. + apply hadd in H0 as []; subst. + now left. right. now left. +Qed. + +Definition premises_model m cls : model := premises_model_map m cls. + +Variant checking_result (cls : clauses) (cl : clause) : Type := + | DoesNotHold : ~ entails cls cl -> checking_result cls cl + | Entails : entails cls cl -> checking_result cls cl. + +Equations? check {V init cls} (m : valid_model V init cls) (cl : clause) : + checking_result cls cls := + check m cl := + infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model m.(model_model) cls') cls cls' _. +Proof. + repeat split. + - pose proof (model_clauses_conclusions m). lsets. + - pose proof (clauses_conclusions_levels cls'). lsets. + - red. intros. + unfold min_model. rewrite min_model_map_levels. + pose proof (model_of_V m k). + apply LevelSet.union_spec in H as []; auto. +Qed. + + End LoopChecking. diff --git a/template-rocq/theories/TemplateLoopChecking.v b/template-rocq/theories/TemplateLoopChecking.v index 8682117fd..3bddcae79 100644 --- a/template-rocq/theories/TemplateLoopChecking.v +++ b/template-rocq/theories/TemplateLoopChecking.v @@ -99,3 +99,44 @@ Definition print_result {V cls} (m : infer_result V cls) := print_lset w ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model (model_model m)) end. *) + +From MetaRocq.Template Require Import All Core. +Definition time : forall {A} {B : A -> Type}, string -> (forall x : A, B x) -> forall x : A, B x := + fun A B s f x => f x. + +Global Instance TemplateMonad_Monad@{t u} : Monad@{t u} TemplateMonad@{t u} := + {| ret := @tmReturn ; bind := @tmBind |}. +Import MRMonadNotation. +Local Open Scope monad_scope. +Open Scope bs_scope. +Import TemplateLoopChecking.UnivLoopChecking. + +Universes u v. +#[universes(polymorphic)] +Definition check_le@{u v} : unit := tt. + +Definition test : TemplateMonad unit := + tmQuoteUniverses >>= fun ctx => + let clauses := time "building clauses" enforce_level_constraints (snd ctx) in + tmMsg (print_clauses clauses) ;; + (* tmMsg (string_of_nat (LevelSet.cardinal (fst ctx)));; *) + (* ++ " universes and " ++ string_of_nat (ConstraintSet.cardinal (snd ctx)) ++ " constraints") ;; *) + tmMsg "done". + + (* let result := time "loop-checking" TemplateLoopChecking.UnivLoopChecking.infer clauses in *) + (* tmMsg (TemplateLoopChecking.UnivLoopChecking.print_result result). *) +From MetaRocq.Template Require Import Pretty. + +Definition env_from_context (c : ContextSet.t) : global_env_ext := + (empty_ext {| universes := c; declarations := []; retroknowledge := Retroknowledge.empty |}). + +MetaRocq Run (ctx <- tmQuoteUniverses ;; + t <- tmQuote (Type@{u}) ;; + tmMsg (print_term (env_from_context ctx) [] true t)). + +Definition make_level (n : ident) : Level.t := Level.level n. + +Definition check_constraint (cls : clauses) c := + + + diff --git a/test-suite/loop-checking/theories/LoopCheckingPlugin.v b/test-suite/loop-checking/theories/LoopCheckingPlugin.v index 59151aa66..67ad002c6 100644 --- a/test-suite/loop-checking/theories/LoopCheckingPlugin.v +++ b/test-suite/loop-checking/theories/LoopCheckingPlugin.v @@ -21,7 +21,7 @@ Local Open Scope monad_scope. Global Instance TemplateMonad_Monad@{t u} : Monad@{t u} TM@{t} := {| ret := @tmReturn ; bind := @tmBind |}. -Definition check_universes : TM unit := +Definition check_universes : TM unit := tmQuoteUniverses >>= fun ctx => let clauses := time "building clauses" enforce_level_constraints (snd ctx) in tmMsg (string_of_nat (LevelSet.cardinal (fst ctx)) ++ " universes and " ++ string_of_nat (ConstraintSet.cardinal (snd ctx)) ++ " constraints") ;; From aec15c831bd47995527bf6d460348e11f1b40d44 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 21 Jul 2025 14:28:17 +0200 Subject: [PATCH 005/164] Move partial loop checking to a separate file --- template-rocq/theories/LoopCheckingNat.v | 2823 +++++++++++++++ template-rocq/theories/PartialLoopChecking.v | 3280 ++++++++++++++++++ 2 files changed, 6103 insertions(+) create mode 100644 template-rocq/theories/LoopCheckingNat.v create mode 100644 template-rocq/theories/PartialLoopChecking.v diff --git a/template-rocq/theories/LoopCheckingNat.v b/template-rocq/theories/LoopCheckingNat.v new file mode 100644 index 000000000..2dc573540 --- /dev/null +++ b/template-rocq/theories/LoopCheckingNat.v @@ -0,0 +1,2823 @@ +(* Distributed under the terms of the MIT license. *) +From Stdlib Require Import ssreflect ssrbool. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils. +From MetaRocq.Common Require Universes. +From Equations Require Import Equations. +Set Equations Transparent. + +(* TODO move *) +Arguments exist {A P}. +Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. + +Module FMapOrderedType_from_UsualOrderedType (O : UsualOrderedType). + Import O. + Definition t := O.t. + Definition eq : O.t -> O.t -> Prop := O.eq. + Definition lt : O.t -> O.t -> Prop := O.lt. + Definition eq_refl : forall x : O.t, eq x x := reflexivity. + Definition eq_sym : forall x y : O.t, eq x y -> eq y x := fun x y H => symmetry H. + + Lemma eq_trans : forall x y z, O.eq x y -> O.eq y z -> O.eq x z. + Proof. intros x y z. unfold O.eq. apply transitivity. Qed. + Lemma lt_trans : forall x y z, O.lt x y -> O.lt y z -> O.lt x z. + Proof. intros. eapply O.lt_strorder; tea. Qed. + + Lemma lt_not_eq : forall x y : O.t, lt x y -> ~ eq x y. + Proof. + intros x y H eq. do 2 red in eq. subst x. now eapply lt_strorder in H. + Qed. + + Definition compare : forall x y : O.t, Compare lt eq x y. + Proof. + intros. + case_eq (compare x y); intros. + apply EQ. abstract (destruct (compare_spec x y) => //). + apply LT. abstract (destruct (compare_spec x y) => //). + apply GT. abstract (destruct (compare_spec x y) => //). + Defined. + + Definition eq_dec : forall x y : O.t, {eq x y} + {~ eq x y} := eq_dec. +End FMapOrderedType_from_UsualOrderedType. + +Module Type LevelOrderedType. + Include UsualOrderedType. + + Parameter reflect_eq : ReflectEq t. + #[local] Existing Instance reflect_eq. + + Parameter to_string : t -> string. + +End LevelOrderedType. + +Module Type FMapOTInterface (E : UsualOrderedType). + Module OT := FMapOrderedType_from_UsualOrderedType E. + Include FMapInterface.Sfun OT. +End FMapOTInterface. + +Module Type LevelExprItf (Level : LevelOrderedType). + Include UsualOrderedType with Definition t := (Level.t * nat)%type. + Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. +End LevelExprItf. + +Module Type LevelExprSet_fun (Level : LevelOrderedType) (LevelExpr : LevelExprItf Level). + Include SWithLeibniz with Module E := LevelExpr. + + Record nonEmptyLevelExprSet + := { t_set : t ; + t_ne : is_empty t_set = false }. + +End LevelExprSet_fun. + +Module Type LoopCheckingItf (Level : LevelOrderedType) + (LevelSet : MSetInterface.SetsOn Level) + (LevelExpr : LevelExprItf Level) + (LevelExprSet : LevelExprSet_fun Level LevelExpr) + (LevelMap : FMapOTInterface Level). + + Definition model := LevelMap.t nat. + Definition valuation := LevelMap.t nat. + + Definition clause : Type := LevelExprSet.nonEmptyLevelExprSet × LevelExpr.t. + + Parameter clauses : Type. + Parameter clauses_of_list : list clause -> clauses. + Parameter list_of_clauses : clauses -> list clause. + + Inductive constraint_type := UnivEq | UnivLe. + Notation constraint := (LevelExprSet.nonEmptyLevelExprSet * constraint_type * LevelExprSet.nonEmptyLevelExprSet). + + Parameter enforce_constraint : forall (cstr : constraint) (cls : clauses), clauses. + + Parameter valid_model : forall (V : LevelSet.t) (m : model) (cls : clauses), Type. + + Parameter model_model : forall V m cls, valid_model V m cls -> model. + + (* { model_model : model; + model_of_V :> model_of V model_model; + model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; + model_ok :> is_model cls model_model; + model_extends : model_extension V m model_model; + }. *) + + Infix "⊂_lset" := LevelSet.Subset (at level 70). + + Parameter enforce_clauses : forall {V init cls} (m : valid_model V init cls) (cls' : clauses), option model. + + Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := + | Loop + | Model (w : LevelSet.t) (m : valid_model V m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). + + Parameter init_model : clauses -> model. + Parameter clauses_levels : clauses -> LevelSet.t. + + Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). + + Parameter infer : forall (cls : clauses), infer_result (clauses_levels cls) cls. + +End LoopCheckingItf. + +Module LoopChecking + (* Signature of levels: decidable, ordered type *) + (Level : LevelOrderedType) + (LevelSet : MSetInterface.SetsOn Level) + (LevelExpr : LevelExprItf Level) + (LevelExprSet : LevelExprSet_fun Level LevelExpr) + (LevelMap : FMapOTInterface Level) <: LoopCheckingItf Level LevelSet LevelExpr LevelExprSet LevelMap. + +Definition level (e : LevelExpr.t) : Level.t := fst e. +Definition levels (e : LevelExprSet.t) := + LevelExprSet.fold (fun le => LevelSet.add (level le)) e LevelSet.empty. + +Import LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). + +Local Existing Instance Level.reflect_eq. + +Module LevelSetFact := WFactsOn Level LevelSet. +Module LevelSetProp := WPropertiesOn Level LevelSet. +Module LevelSetDecide := LevelSetProp.Dec. +Module LevelMapFact := FMapFacts.WProperties_fun LevelMap.OT LevelMap. + +Ltac lsets := LevelSetDecide.fsetdec. +Notation "(=_lset)" := LevelSet.Equal (at level 0). +Infix "=_lset" := LevelSet.Equal (at level 30). +Infix "⊂_lset" := LevelSet.Subset (at level 70). +Infix "∪" := LevelSet.union (at level 70). + +Definition print_level_nat_map (m : LevelMap.t nat) := + let list := LevelMap.elements m in + print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_nat w) nl list. + +Definition print_lset (l : LevelSet.t) := + let list := LevelSet.elements l in + print_list Level.to_string " " list. + +Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. +Module LevelExprSetProp := WPropertiesOn LevelExpr LevelExprSet. + +(* We have decidable equality w.r.t leibniz equality for sets of levels. *) +#[global, program] Instance levelexprset_reflect : ReflectEq LevelExprSet.t := + { eqb := LevelExprSet.equal }. +Next Obligation. + destruct (LevelExprSet.equal x y) eqn:e; constructor. + eapply LevelExprSet.equal_spec in e. + now eapply LevelExprSet.eq_leibniz. + intros e'. + subst y. + pose proof (@LevelExprSetFact.equal_1 x x). + forward H. reflexivity. congruence. +Qed. + +#[global] Instance levelexprset_eq_dec : Classes.EqDec LevelExprSet.t := Classes.eq_dec. + +Derive NoConfusion for LevelExprSet.nonEmptyLevelExprSet. + +(* We use uip on the is_empty condition *) +#[global, program] Instance nonEmptyLevelExprSet_reflect : ReflectEq nonEmptyLevelExprSet := + { eqb x y := eqb x.(t_set) y.(t_set) }. +Next Obligation. + destruct (eqb_spec (t_set x) (t_set y)); constructor. + destruct x, y; cbn in *. subst. + now rewrite (uip t_ne0 t_ne1). + intros e; subst x; apply H. + reflexivity. +Qed. + +(** This coercion allows to see the non-empty set as a regular [LevelExprSet.t] *) +Coercion t_set : nonEmptyLevelExprSet >-> LevelExprSet.t. +Module LevelExprSetDecide := WDecide (LevelExprSet). +Ltac lesets := LevelExprSetDecide.fsetdec. +Infix "⊂_leset" := LevelExprSet.Subset (at level 70). + +Module NonEmptySetFacts. + #[program] Definition singleton (e : LevelExpr.t) : nonEmptyLevelExprSet + := {| t_set := LevelExprSet.singleton e |}. + Next Obligation. + apply negbTE. + eapply (contra_notN (P := LevelExprSet.Empty (LevelExprSet.singleton e))). + apply LevelExprSetFact.is_empty_2. intros ne. red in ne. specialize (ne e). lesets. + Qed. + + Lemma not_Empty_is_empty s : + ~ LevelExprSet.Empty s -> LevelExprSet.is_empty s = false. + Proof. + intro H. apply not_true_is_false. intro H'. + apply H. now apply LevelExprSetFact.is_empty_2 in H'. + Qed. + + Program Definition add (e : LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet + := {| t_set := LevelExprSet.add e u |}. + Next Obligation. + apply not_Empty_is_empty; intro H. + eapply H. eapply LevelExprSet.add_spec. + left; reflexivity. + Qed. + + Lemma add_spec e u e' : + LevelExprSet.In e' (add e u) <-> e' = e \/ LevelExprSet.In e' u. + Proof. + apply LevelExprSet.add_spec. + Qed. + + Definition add_list : list LevelExpr.t -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet + := List.fold_left (fun u e => add e u). + + Lemma add_list_spec l u e : + LevelExprSet.In e (add_list l u) <-> In e l \/ LevelExprSet.In e u. + Proof. + unfold add_list. rewrite <- fold_left_rev_right. + etransitivity. 2:{ eapply or_iff_compat_r. etransitivity. + 2: apply @InA_In_eq with (A:=LevelExpr.t). + eapply InA_rev. } + induction (List.rev l); cbn. + - split. intuition. intros [H|H]; tas. invs H. + - split. + + intro H. apply add_spec in H. destruct H as [H|H]. + * left. now constructor. + * apply IHl0 in H. destruct H as [H|H]; [left|now right]. + now constructor 2. + + intros [H|H]. inv H. + * apply add_spec; now left. + * apply add_spec; right. apply IHl0. now left. + * apply add_spec; right. apply IHl0. now right. + Qed. + + Lemma elements_not_empty {u : nonEmptyLevelExprSet} : LevelExprSet.elements u <> []. + Proof. + rewrite -LevelExprSetProp.elements_Empty. + move/LevelExprSetFact.is_empty_1. + destruct u as [u1 u2]; cbn in *. congruence. + Qed. + + Equations to_nonempty_list (u : nonEmptyLevelExprSet) : LevelExpr.t * list LevelExpr.t := + | u with inspect (LevelExprSet.elements u) := { + | exist [] eqel => False_rect _ (elements_not_empty eqel) + | exist (e :: l) _ => (e, l) }. + + Lemma singleton_to_nonempty_list e : to_nonempty_list (singleton e) = (e, []). + Proof. + funelim (to_nonempty_list (singleton e)). bang. + clear H. + pose proof (LevelExprSet.singleton_spec e1 e). + rewrite LevelExprSetFact.elements_iff in H. + rewrite InA_In_eq in H. rewrite e0 in H. + destruct H. forward H. now left. noconf H. f_equal. + pose proof (LevelExprSet.cardinal_spec (LevelExprSet.singleton e1)). rewrite e0 in H. cbn in H. + rewrite LevelExprSetProp.singleton_cardinal in H. + destruct l => //. + Qed. + + Lemma to_nonempty_list_spec u : + let '(e, u') := to_nonempty_list u in + e :: u' = LevelExprSet.elements u. + Proof. + funelim (to_nonempty_list u). bang. now rewrite e0. + Qed. + + Lemma to_nonempty_list_spec' u : + (to_nonempty_list u).1 :: (to_nonempty_list u).2 = LevelExprSet.elements u. + Proof. + pose proof (to_nonempty_list_spec u). + now destruct (to_nonempty_list u). + Qed. + + Lemma In_to_nonempty_list (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : + LevelExprSet.In e u + <-> e = (to_nonempty_list u).1 \/ In e (to_nonempty_list u).2. + Proof. + etransitivity. symmetry. apply LevelExprSet.elements_spec1. + pose proof (to_nonempty_list_spec' u) as H. + destruct (to_nonempty_list u) as [e' l]; cbn in *. + rewrite <- H; clear. etransitivity. apply InA_cons. + eapply or_iff_compat_l. apply InA_In_eq. + Qed. + + Lemma In_to_nonempty_list_rev (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : + LevelExprSet.In e u + <-> e = (to_nonempty_list u).1 \/ In e (List.rev (to_nonempty_list u).2). + Proof. + etransitivity. eapply In_to_nonempty_list. + apply or_iff_compat_l. apply in_rev. + Qed. + + Definition map (f : LevelExpr.t -> LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + let '(e, l) := to_nonempty_list u in + add_list (List.map f l) (singleton (f e)). + + Lemma map_spec f u e : + LevelExprSet.In e (map f u) <-> exists e0, LevelExprSet.In e0 u /\ e = (f e0). + Proof. + unfold map. symmetry. etransitivity. + { eapply iff_ex; intro. eapply and_iff_compat_r. eapply In_to_nonempty_list. } + destruct (to_nonempty_list u) as [e' l]; cbn in *. + symmetry. etransitivity. eapply add_list_spec. + etransitivity. eapply or_iff_compat_l. apply LevelExprSet.singleton_spec. + etransitivity. eapply or_iff_compat_r. + apply in_map_iff. clear u. split. + - intros [[e0 []]|H]. + + exists e0. split. right; tas. congruence. + + exists e'. split; tas. left; reflexivity. + - intros [xx [[H|H] ?]]. + + right. congruence. + + left. exists xx. split; tas; congruence. + Qed. + + Program Definition non_empty_union (u v : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + {| t_set := LevelExprSet.union u v |}. + Next Obligation. + apply not_Empty_is_empty; intro H. + assert (HH: LevelExprSet.Empty u). { + intros x Hx. apply (H x). + eapply LevelExprSet.union_spec. now left. } + apply LevelExprSetFact.is_empty_1 in HH. + rewrite t_ne in HH; discriminate. + Qed. + + + Lemma eq_univ (u v : nonEmptyLevelExprSet) : + u = v :> LevelExprSet.t -> u = v. + Proof. + destruct u as [u1 u2], v as [v1 v2]; cbn. intros X; destruct X. + now rewrite (uip_bool _ _ u2 v2). + Qed. + + Lemma eq_univ' (u v : nonEmptyLevelExprSet) : + LevelExprSet.Equal u v -> u = v. + Proof. + intro H. now apply eq_univ, LevelExprSet.eq_leibniz. + Qed. + + Lemma eq_univ'' (u v : nonEmptyLevelExprSet) : + LevelExprSet.elements u = LevelExprSet.elements v -> u = v. + Proof. + intro H. apply eq_univ. + destruct u as [u1 u2], v as [v1 v2]; cbn in *; clear u2 v2. + eapply LevelExprSet.eq_leibniz. red. + intros x. rewrite -!LevelExprSet.elements_spec1 H //. + Qed. + + Lemma univ_expr_eqb_true_iff (u v : nonEmptyLevelExprSet) : + LevelExprSet.equal u v <-> u = v. + Proof. + split. + - intros. + apply eq_univ'. now apply LevelExprSet.equal_spec. + - intros ->. now apply LevelExprSet.equal_spec. + Qed. + + Lemma univ_expr_eqb_comm (u v : nonEmptyLevelExprSet) : + LevelExprSet.equal u v <-> LevelExprSet.equal v u. + Proof. + transitivity (u = v). 2: transitivity (v = u). + - apply univ_expr_eqb_true_iff. + - split; apply eq_sym. + - split; apply univ_expr_eqb_true_iff. + Qed. + + + Lemma LevelExprSet_for_all_false f u : + LevelExprSet.for_all f u = false -> LevelExprSet.exists_ (negb ∘ f) u. + Proof. + intro H. rewrite LevelExprSetFact.exists_b. + rewrite LevelExprSetFact.for_all_b in H. + all: try now intros x y []. + induction (LevelExprSet.elements u); cbn in *; [discriminate|]. + apply andb_false_iff in H; apply orb_true_iff; destruct H as [H|H]. + left; now rewrite H. + right; now rewrite IHl. + Qed. + + Lemma LevelExprSet_For_all_exprs (P : LevelExpr.t -> Prop) (u : nonEmptyLevelExprSet) + : LevelExprSet.For_all P u + <-> P (to_nonempty_list u).1 /\ Forall P (to_nonempty_list u).2. + Proof. + etransitivity. + - eapply iff_forall; intro e. eapply imp_iff_compat_r. + apply In_to_nonempty_list. + - cbn; split. + + intro H. split. apply H. now left. + apply Forall_forall. intros x H0. apply H; now right. + + intros [H1 H2] e [He|He]. subst e; tas. + eapply Forall_forall in H2; tea. + Qed. + +End NonEmptySetFacts. +Import NonEmptySetFacts. + +Definition clause : Type := nonEmptyLevelExprSet × LevelExpr.t. + +Module Clause. + Definition t := clause. + + Definition eq : t -> t -> Prop := eq. + + Definition eq_equiv : RelationClasses.Equivalence eq := _. + + Inductive lt_ : t -> t -> Prop := + | lt_clause1 l e e' : LevelExpr.lt e e' -> lt_ (l, e) (l, e') + | lt_clause2 l l' b b' : LevelExprSet.lt l.(t_set) l'.(t_set) -> lt_ (l, b) (l', b'). + + Definition lt := lt_. + + Global Instance lt_strorder : RelationClasses.StrictOrder lt. + Proof. + constructor. + - intros x X; inversion X; subst. now eapply LevelExpr.lt_strorder in H1. + eapply LevelExprSet.lt_strorder; eassumption. + - intros x y z X1 X2; invs X1; invs X2; constructor; tea. + etransitivity; tea. + etransitivity; tea. + Qed. + + Definition lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt. + intros x x' H1 y y' H2. unfold lt. subst. reflexivity. + Qed. + + Definition compare (x y : t) : comparison := + match x, y with + | (l1, b1), (l2, b2) => + match LevelExprSet.compare l1.(t_set) l2.(t_set) with + | Eq => LevelExpr.compare b1 b2 + | x => x + end + end. + + Definition compare_spec : + forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y). + Proof. + intros [? ?] [? ?]; cbn; repeat constructor. + destruct (LevelExprSet.compare_spec n n0); repeat constructor; tas. + eapply LevelExprSet.eq_leibniz in H. apply NonEmptySetFacts.eq_univ in H. + subst. cbn in *. + destruct (LevelExpr.compare_spec t0 t1); repeat constructor; tas. now subst. + Qed. + + Global Instance reflect_t : ReflectEq t := reflect_prod _ _ . + + Definition eq_dec : forall (l1 l2 : t), {l1 = l2} + {l1 <> l2} := Classes.eq_dec. + + Definition eq_leibniz (x y : t) : eq x y -> x = y := id. +End Clause. + +Module Clauses := MSetAVL.Make Clause. +Module ClausesFact := WFactsOn Clause Clauses. +Module ClausesProp := WPropertiesOn Clause Clauses. +Module ClausesDecide := WDecide (Clauses). +Ltac clsets := ClausesDecide.fsetdec. + +Definition clauses := Clauses.t. + +Lemma filter_add {p x s} : Clauses.Equal (Clauses.filter p (Clauses.add x s)) (if p x then Clauses.add x (Clauses.filter p s) else Clauses.filter p s). +Proof. + intros i. + rewrite Clauses.filter_spec. + destruct (eqb_spec i x); subst; + destruct (p x) eqn:px; rewrite !Clauses.add_spec !Clauses.filter_spec; intuition auto || congruence. +Qed. + +Local Instance proper_fold_transpose {A} (f : Clauses.elt -> A -> A) : + transpose eq f -> + Proper (Clauses.Equal ==> eq ==> eq) (Clauses.fold f). +Proof. + intros hf s s' Hss' x ? <-. + eapply ClausesProp.fold_equal; tc; tea. +Qed. +Existing Class transpose. + +Lemma clauses_fold_filter {A} (f : Clauses.elt -> A -> A) (p : Clauses.elt -> bool) cls acc : + transpose Logic.eq f -> + Clauses.fold f (Clauses.filter p cls) acc = + Clauses.fold (fun elt acc => if p elt then f elt acc else acc) cls acc. +Proof. + intros hf. + symmetry. eapply ClausesProp.fold_rec_bis. + - intros s s' a eq. intros ->. + eapply ClausesProp.fold_equal; tc. auto. + intros x. + rewrite !Clauses.filter_spec. + now rewrite eq. + - now cbn. + - intros. + rewrite H1. + rewrite filter_add. + destruct (p x) eqn:px => //. + rewrite ClausesProp.fold_add //. + rewrite Clauses.filter_spec. intuition auto. +Qed. + +Definition levelexpr_level : LevelExpr.t -> Level.t := fst. +Coercion levelexpr_level : LevelExpr.t >-> Level.t. +Extraction Inline levelexpr_level. + +Definition strict_subset (s s' : LevelSet.t) := + LevelSet.Subset s s' /\ ~ LevelSet.Equal s s'. + +Lemma strict_subset_incl (x y z : LevelSet.t) : LevelSet.Subset x y -> strict_subset y z -> strict_subset x z. +Proof. + intros hs []. split => //. lsets. + intros heq. apply H0. lsets. +Qed. + +Lemma strict_subset_cardinal s s' : strict_subset s s' -> LevelSet.cardinal s < LevelSet.cardinal s'. +Proof. + intros []. + assert (LevelSet.cardinal s <> LevelSet.cardinal s'). + { intros heq. apply H0. + intros x. split; intros. now apply H. + destruct (LevelSet.mem x s) eqn:hin. + eapply LevelSet.mem_spec in hin. + auto. eapply LevelSetProp.FM.not_mem_iff in hin. + exfalso. + eapply LevelSetProp.subset_cardinal_lt in hin; tea. + lia. } + enough (LevelSet.cardinal s <= LevelSet.cardinal s') by lia. + now eapply LevelSetProp.subset_cardinal. +Qed. + +Definition premise (cl : clause) := fst cl. +Definition concl (cl : clause) := snd cl. +Extraction Inline premise concl. + +Definition clause_levels cl := + LevelSet.union (levels (premise cl)) (LevelSet.singleton (levelexpr_level (concl cl))). + +Definition clauses_levels (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls LevelSet.empty. + +Lemma Clauses_In_elements l s : + In l (Clauses.elements s) <-> Clauses.In l s. +Proof. + rewrite ClausesFact.elements_iff. + now rewrite InA_In_eq. +Qed. + +Lemma clauses_levels_spec_aux l cls acc : + LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls acc) <-> + (exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl)) \/ LevelSet.In l acc. +Proof. + eapply ClausesProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k [hin hl]]. clsets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.union_spec. + split. + * intros [hin'|]. + left. exists x. split => //. + apply hadd. now left. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. + * intros [[k [ins'' ?]]|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma clauses_levels_spec l cls : + LevelSet.In l (clauses_levels cls) <-> + exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl). +Proof. + unfold clauses_levels. + rewrite clauses_levels_spec_aux. + intuition auto. lsets. +Qed. + +Lemma clause_levels_spec l cl : + LevelSet.In l (clause_levels cl) <-> + LevelSet.In l (levels (premise cl)) \/ l = levelexpr_level (concl cl). +Proof. + unfold clause_levels. + now rewrite LevelSet.union_spec LevelSet.singleton_spec. +Qed. + +Definition model := LevelMap.t nat. + +Definition level_value (m : model) (level : Level.t) : nat := + match LevelMap.find level m with + | Some val => val + | None => 0 + end. + +Definition levelexpr_value (m : model) (atom : LevelExpr.t) := + level_value m (levelexpr_level atom). + +Extraction Inline levelexpr_value. + +Definition min_atom_value (m : model) (atom : LevelExpr.t) := + let '(l, k) := atom in + (Z.of_nat (level_value m l) - Z.of_nat k)%Z. + +Definition min_premise (m : model) (l : nonEmptyLevelExprSet) : Z := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (fun min atom => Z.min (min_atom_value m atom) min) tl (min_atom_value m hd). + +Definition satisfiable_atom (m : model) (atom : Level.t * nat) : bool := + let '(l, k) := atom in + match LevelMap.find l m with + | Some val => k <=? val + | None => false + end. + +Definition satisfiable_premise (m : model) (l : nonEmptyLevelExprSet) := + LevelExprSet.for_all (satisfiable_atom m) l. + +(* Definition valid_clause (m : model) (cl : clause) := *) + (* implb (satisfiable_premise m (premise cl)) (satisfiable_atom m (concl cl)). *) + +Definition valid_clause (m : model) (cl : clause) := + let k0 := min_premise m (premise cl) in + if (k0 (modified, wm) + | DoesntHold wm' => (true, wm') + | Holds => (modified, wm) + end. + +Definition check_model_aux (cls : clauses) (wm : LevelSet.t × model) : bool × (LevelSet.t × model) := + Clauses.fold check_clause_model cls (false, wm). + +(* If check_model = None then we have a model of all clauses, + othewise, we return Some (W', m') where W ⊂ W' and the model has + been updated for at least one atom l ∈ W'. *) +Definition check_model (cls : clauses) (wm : LevelSet.t × model) := + let '(modified, wm) := check_model_aux cls wm in + if modified then Some wm else None. + +Lemma check_model_aux_subset {cls w v} : + forall b w' v', check_model_aux cls (w, v) = (b, (w', v')) -> LevelSet.Subset w w'. +Proof. + intros w' v'. + unfold check_model, check_model_aux, check_clause_model. revert w' v'. + eapply ClausesProp.fold_rec => //. + { intros. noconf H0. reflexivity. } + intros x a s' s'' hin nin hadd IH. + intros b w' v'. destruct a. + destruct p as []. + unfold update_value. + destruct Z.ltb. intros [= -> -> ->] => //. + now eapply IH. + destruct x as [prem [l k]]; cbn. + destruct Nat.leb. intros [= -> -> ->] => //. now eapply IH. + intros [= <- <- <-]. intros x inx. + eapply LevelSet.add_spec. + specialize (IH _ _ _ eq_refl). + now right. +Qed. + +Lemma check_model_subset {cls w v} : + forall w' v', check_model cls (w, v) = Some (w', v') -> LevelSet.Subset w w'. +Proof. + intros w' v'. unfold check_model. + destruct check_model_aux eqn:cm. + destruct p as [W m]. + eapply check_model_aux_subset in cm. + destruct b => //. now intros [= <- <-]. +Qed. + +Definition premise_restricted_to W cl := + LevelSet.subset (levels (premise cl)) W. + +Definition clause_restricted_to W cl := + LevelSet.subset (levels (premise cl)) W && + LevelSet.mem (level (concl cl)) W. + +Definition restrict_clauses (cls : clauses) (W : LevelSet.t) := + Clauses.filter (clause_restricted_to W) cls. + +Lemma in_restrict_clauses (cls : clauses) (concls : LevelSet.t) cl : + Clauses.In cl (restrict_clauses cls concls) <-> + [/\ LevelSet.In (level (concl cl)) concls, + LevelSet.Subset (levels (premise cl)) concls & + Clauses.In cl cls]. +Proof. + unfold restrict_clauses. + rewrite Clauses.filter_spec. + destruct cl. cbn. + rewrite andb_true_iff LevelSet.subset_spec LevelSet.mem_spec. + firstorder auto. +Qed. + +Definition clauses_with_concl (cls : clauses) (concl : LevelSet.t) := + Clauses.filter (fun '(prem, concla) => LevelSet.mem (level concla) concl) cls. + +Lemma in_clauses_with_concl (cls : clauses) (concls : LevelSet.t) cl : + Clauses.In cl (clauses_with_concl cls concls) <-> + LevelSet.In (level (concl cl)) concls /\ Clauses.In cl cls. +Proof. + unfold clauses_with_concl. + rewrite Clauses.filter_spec. + destruct cl. rewrite LevelSet.mem_spec. cbn. firstorder eauto. +Qed. + +Definition clauses_conclusions (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.add (level (concl cl)) acc) cls LevelSet.empty. + +Lemma clauses_conclusions_spec a cls : + LevelSet.In a (clauses_conclusions cls) <-> + exists cl, Clauses.In cl cls /\ level (concl cl) = a. +Proof. + unfold clauses_conclusions. + eapply ClausesProp.fold_rec; clear. + - move=> s' he /=. rewrite LevelSetFact.empty_iff. + firstorder auto. + - move=> cl ls cls' cls'' hin hnin hadd ih. + rewrite LevelSet.add_spec. firstorder eauto. + specialize (H0 x). cbn in H0. + apply hadd in H1. firstorder eauto. + subst. left. now destruct x. +Qed. + +Lemma clauses_conclusions_clauses_with_concl cls concl : + LevelSet.Subset (clauses_conclusions (clauses_with_concl cls concl)) concl. +Proof. + intros x [cl []] % clauses_conclusions_spec. + eapply in_clauses_with_concl in H as []. + now rewrite H0 in H. +Qed. + +Lemma clauses_conclusions_restrict_clauses cls W : + LevelSet.Subset (clauses_conclusions (restrict_clauses cls W)) W. +Proof. + intros x [cl []] % clauses_conclusions_spec. + eapply in_restrict_clauses in H as []. + now rewrite H0 in H. +Qed. + +Definition in_clauses_conclusions (cls : clauses) (x : Level.t): Prop := + exists cl, Clauses.In cl cls /\ (level cl.2) = x. + +Definition v_minus_w_bound (W : LevelSet.t) (m : model) := + LevelMap.fold (fun w v acc => Nat.max v acc) + (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0. + +Definition levelexpr_k : LevelExpr.t -> nat := snd. +Coercion levelexpr_k : LevelExpr.t >-> nat. + +Definition level_expr_elt : LevelExprSet.elt -> LevelExpr.t := fun x => x. +Coercion level_expr_elt : LevelExprSet.elt >-> LevelExpr.t. + +Definition premise_min (l : nonEmptyLevelExprSet) : nat := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (B:=LevelExpr.t) (fun min atom => Nat.min atom min) tl hd. + +Definition gain (cl : clause) : Z := + Z.of_nat (levelexpr_k (concl cl)) - Z.of_nat (premise_min (premise cl)). + +Definition max_gain (cls : clauses) := + Clauses.fold (fun cl acc => Nat.max (Z.to_nat (gain cl)) acc) cls 0. + +Definition model_same_domain (m m' : model) := + forall l, LevelMap.In l m <-> LevelMap.In l m'. + +#[local] Instance model_same_domain_refl : Reflexive model_same_domain. +Proof. intros m l. reflexivity. Qed. + +#[local] Instance model_same_domain_trans : Transitive model_same_domain. +Proof. intros m m' m'' h h' l. rewrite (h l). apply h'. Qed. + +Definition model_le (m m' : model) := + forall l k, LevelMap.MapsTo l k m -> + exists k', LevelMap.MapsTo l k' m' /\ k <= k'. + +Infix "⩽" := model_le (at level 70). (* \leqslant *) + +Definition model_map_outside V (m m' : model) := + forall l, ~ LevelSet.In l V -> + forall k, LevelMap.MapsTo l k m <-> LevelMap.MapsTo l k m'. + +#[local] Instance model_map_outside_refl V : Reflexive (model_map_outside V). +Proof. intros m l. reflexivity. Qed. + +#[local] Instance model_map_outside_trans V : Transitive (model_map_outside V). +Proof. + intros m m' m'' h h' l hnin k. + rewrite (h l hnin k). now apply h'. +Qed. + +(** The termination proof relies on the correctness of check_model: + it does strictly increase a value but not above [max_gain cls]. +*) + +Lemma clauses_conclusions_diff cls s : + clauses_conclusions (Clauses.diff cls (clauses_with_concl cls s)) ⊂_lset + LevelSet.diff (clauses_conclusions cls) s. +Proof. + intros a. rewrite LevelSet.diff_spec !clauses_conclusions_spec. + firstorder eauto. + exists x; split => //. + now rewrite Clauses.diff_spec in H. + intros ha. + rewrite Clauses.diff_spec in H; destruct H as []. + apply H1. + rewrite in_clauses_with_concl. split => //. + now rewrite H0. +Qed. + +Lemma diff_eq U V : LevelSet.diff V U =_lset V <-> LevelSet.inter V U =_lset LevelSet.empty. +Proof. split. lsets. lsets. Qed. + +Lemma levelset_neq U V : LevelSet.equal U V = false -> ~ LevelSet.Equal U V. +Proof. intros eq heq % LevelSet.equal_spec. congruence. Qed. + +Lemma levelset_union_same U : LevelSet.union U U =_lset U. +Proof. lsets. Qed. + +Lemma fold_left_comm {A B} (f : B -> A -> B) (l : list A) (x : A) (acc : B) : + (forall x y z, f (f z x) y = f (f z y) x) -> + fold_left f l (f acc x) = f (fold_left f l acc) x. +Proof. + intros. + induction l in acc, x |- *; cbn. auto. + rewrite -IHl. f_equal. now rewrite H. +Qed. + +Lemma fold_left_le (f g : nat -> LevelSet.elt -> nat) l : + (forall acc acc' x, In x l -> acc <= acc' -> f acc x <= g acc' x) -> + forall acc acc', acc <= acc' -> + fold_left f l acc <= fold_left g l acc'. +Proof. + intros hfg. + induction l => //. cbn. intros. + apply IHl. intros. apply hfg => //. now right. apply hfg => //. now left. +Qed. + +Lemma fold_left_ne_lt (f g : nat -> LevelSet.elt -> nat) l acc : + (forall (x y : LevelSet.elt) z, f (f z x) y = f (f z y) x) -> + (forall (x y : LevelSet.elt) z, g (g z x) y = g (g z y) x) -> + l <> [] -> + (forall acc acc' x, In x l -> (acc <= acc') -> (f acc x <= g acc' x)) -> + (forall acc acc' x, In x l -> (acc < acc') -> (f acc x < g acc' x)) -> + (exists x, In x l /\ forall acc acc', (acc <= acc') -> (f acc x < g acc' x)) -> + fold_left f l acc < fold_left g l acc. +Proof. + intros hf hg. + generalize (Nat.le_refl acc). + generalize acc at 2 4. + induction l in acc |- * => //. + intros. + destruct l; cbn. + { destruct H3 as [x []]. cbn in H3. destruct H3; subst => //. + now eapply (H4 acc acc0). } + cbn in IHl. + rewrite hf hg. + rewrite fold_left_comm //. rewrite (fold_left_comm g) //. + destruct H3 as [min [hmin hfg]]. + destruct hmin as [<-|hel]. + - apply hfg. apply fold_left_le => //. intros; eapply H1 => //. now right; right. + apply H1 => //. now right; left. + - apply H2. now left. eapply IHl => //. + * intros acc1 acc' x hin. apply (H1 acc1 acc' x). now right. + * intros acc1 acc' x hin. apply (H2 acc1 acc' x). now right. + * exists min. split => //. +Qed. + +Infix "↓" := clauses_with_concl (at level 70). (* \downarrow *) +Infix "⇂" := restrict_clauses (at level 70). (* \downharpoonright *) + +Lemma clauses_conclusions_diff_left cls W cls' : + clauses_conclusions (Clauses.diff (cls ↓ W) cls') ⊂_lset W. +Proof. + intros l. + rewrite clauses_conclusions_spec. + move=> [] cl. rewrite Clauses.diff_spec => [] [] []. + move/in_clauses_with_concl => [] hin ? ? eq. + now rewrite eq in hin. +Qed. + +Lemma clauses_conclusions_diff_restrict cls W cls' : + clauses_conclusions (Clauses.diff (cls ⇂ W) cls') ⊂_lset W. +Proof. + intros l. + rewrite clauses_conclusions_spec. + move=> [] cl. rewrite Clauses.diff_spec => [] [] []. + move/in_restrict_clauses => [] hin ? ? ? eq. + now rewrite eq in hin. +Qed. + +Lemma LevelSet_In_elements l s : + In l (LevelSet.elements s) <-> LevelSet.In l s. +Proof. + rewrite LevelSetFact.elements_iff. + now rewrite InA_In_eq. +Qed. + +Lemma clauses_empty_eq {s} : Clauses.Empty s -> Clauses.Equal s Clauses.empty. +Proof. clsets. Qed. + +Lemma update_value_valid {W m cl} : + match update_value (W, m) cl with + | VacuouslyTrue | Holds => valid_clause m cl + | DoesntHold _ => ~~ valid_clause m cl + end. +Proof. + unfold update_value, valid_clause. + destruct Z.ltb => //. + destruct cl as [prem [l k]]; cbn. + destruct Nat.leb => //. +Qed. + +Lemma valid_update_value {W m cl} : + valid_clause m cl -> + match update_value (W, m) cl with + | VacuouslyTrue | Holds => true + | DoesntHold _ => false + end. +Proof. + unfold update_value, valid_clause. + destruct Z.ltb => //. + destruct cl as [prem [l k]]; cbn. + destruct Nat.leb => //. +Qed. + +Lemma check_model_aux_false {cls acc acc'} : check_model_aux cls acc = (false, acc') -> acc = acc'. +Proof. + unfold check_model_aux, check_clause_model. + eapply ClausesProp.fold_rec. + - intros s emp [=] => //. + - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. + intros IH. + destruct update_value eqn:upd => //. +Qed. + +(* Lemma check_model_aux_true {cls acc acc'} : check_model_aux cls acc = (true, acc') -> acc = acc'. +Proof. + unfold check_model_aux. + eapply ClausesProp.fold_rec. + - intros s emp [=] => //. + - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. + intros IH. + destruct update_value eqn:upd => //. +Qed. *) + +Lemma check_model_aux_model {cls acc} : + check_model_aux cls acc = (false, acc) <-> is_model cls acc.2. +Proof. + unfold check_model_aux, check_clause_model. + unfold is_model. + unfold is_true; rewrite -ClausesFact.for_all_iff. + eapply ClausesProp.fold_rec. + - intros s emp. + split => //. + intros [=] x hx. clsets. + - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. + intros IH. + split. + * move: (@update_value_valid w' m' cl). + destruct update_value eqn:upd => //; intros vcl [= -> <-] ; + destruct IH as [IH _]; specialize (IH eq_refl). + intros x hx; apply incls'' in hx as []; subst. exact vcl. now apply IH. + intros x hx; apply incls'' in hx as []; subst. exact vcl. now apply IH. + * intros hf. + assert (valid_clause acc.2 cl). + { apply hf. apply incls''. intuition auto. } + destruct IH as [_ IH]. forward IH. + { intros x hx. apply hf. apply incls''. now right. } + noconf IH. + move: (@valid_update_value w' m' cl H). + destruct update_value eqn:upd => //. +Qed. + +Lemma clauses_for_all_neg {p s}: + ~~ Clauses.for_all p s <-> ~ Clauses.For_all p s. +Proof. + intuition auto. + rewrite ClausesFact.for_all_iff in H0. red in H. now rewrite H0 in H. + revert H. apply contra_notN. + rewrite ClausesFact.for_all_iff //. +Qed. + +Lemma clauses_for_all_exists {p s}: + ~~ Clauses.for_all p s <-> Clauses.exists_ (fun x => ~~ p x) s. +Proof. + rewrite ClausesFact.for_all_b ClausesFact.exists_b. + induction (Clauses.elements s). + - cbn; auto. reflexivity. + - cbn. rewrite negb_and. intuition auto. + move/orP: H1 => [->|] //. move/H. intros ->. now rewrite orb_true_r. + move/orP: H1 => [->|] //. move/H0. intros ->. now rewrite orb_true_r. +Qed. +#[local] Instance model_le_refl : Reflexive model_le. +Proof. intros x l k map. exists k; split => //. Qed. + +#[local] Instance model_le_trans : Transitive model_le. +Proof. intros m m' m'' mm' m'm'' l k map. + apply mm' in map as [k' [map ?]]. + apply m'm'' in map as [k'' [map ?]]. exists k''. split => //. lia. +Qed. + +Lemma update_model_monotone m l k : level_value m l <= k -> m ⩽ update_model m l k. +Proof. + intros hl. + intros l' k' maps. + unfold update_model. cbn. + destruct (eqb_spec l l'). + - exists k. move: hl. subst l'. + unfold level_value. + rewrite (LevelMap.find_1 maps). + intros hle. + split => //. eapply LevelMap.add_1. eapply LevelMap.OT.eq_refl. + - exists k'. split => //. apply LevelMap.add_2 => //. +Qed. + +Lemma check_clause_model_inv {cl modified w m b wm'} : + check_clause_model cl (modified, (w, m)) = (b, wm') -> + m ⩽ wm'.2. +Proof. + unfold check_clause_model. + destruct (update_value (w, m) cl) eqn:upd. + * now intros [= <- <-]. + * now intros [= <- <-]. + * intros [= <- <-]. + move: upd. + unfold update_value. + case: Z.ltb_spec => //. + destruct cl as [prem [l k]] => /=. + intros hprem. + case: Nat.leb_spec => // hlt. + intros [= <-]. cbn. + eapply update_model_monotone. lia. +Qed. + +Lemma check_clause_model_intact {cl modified w m wm'} : + check_clause_model cl (modified, (w, m)) = (false, wm') -> valid_clause m cl /\ wm' = (w, m). +Proof. + unfold check_clause_model. + move: (@update_value_valid w m cl). + destruct (update_value (w, m) cl) eqn:upd. + * intros valid [= -> <-]. split => //. + * intros valid [= -> <-]. split => //. + * intros _ [=]. +Qed. + +Lemma check_clause_model_modify {cl w m wm'} : + check_clause_model cl (false, (w, m)) = (true, wm') -> ~~ valid_clause m cl. +Proof. + unfold check_clause_model. + destruct (update_value (w, m) cl) eqn:upd. + * now intros [= <- <-]. + * now intros [= <- <-]. + * intros [= <-]. + move: upd. + unfold update_value, valid_clause. + case: Z.ltb_spec => //. + destruct cl as [prem [l k]] => /=. + intros hprem. + case: Nat.leb_spec => // hlt. +Qed. + +Lemma check_model_aux_model_le {cls acc acc' b} : + check_model_aux cls acc = (b, acc') -> acc.2 ⩽ acc'.2. +Proof. + unfold check_model_aux. + revert b acc'. + eapply ClausesProp.fold_rec. + - intros s emp b acc'. intros [=]. subst. reflexivity. + - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. + intros IH b acc'. + move/check_clause_model_inv. + specialize (IH _ _ eq_refl). cbn in IH. now intros; transitivity m'. +Qed. + +Lemma level_value_update_model m l k : + level_value (update_model m l k) l = k. +Proof. + unfold level_value, update_model. + cbn -[LevelMap.find LevelMap.add]. + rewrite LevelMapFact.F.add_o. + destruct LevelMap.OT.eq_dec => //. + exfalso. now apply n. +Qed. + + +Lemma model_map_outside_weaken {W W'} {m m' : model} : + model_map_outside W m m' -> + W ⊂_lset W' -> + model_map_outside W' m m'. +Proof. + intros hm sub x hin k. + apply hm. intros hin'. apply sub in hin'. now apply hin. +Qed. + +Lemma is_model_union {cls cls' m} : + is_model cls m -> is_model cls' m -> is_model (Clauses.union cls cls') m. +Proof. + rewrite /is_model. rewrite /is_true -!ClausesFact.for_all_iff. + now move=> ism ism' x /Clauses.union_spec []. +Qed. + +#[local] Instance Clauses_For_All_proper : Proper (eq ==> Clauses.Equal ==> iff) Clauses.For_all. +Proof. + intros x y -> cl cl' eqcl. + unfold Clauses.For_all. now setoid_rewrite eqcl. +Qed. + +#[local] Instance Clauses_for_all_proper : Proper (eq ==> Clauses.Equal ==> eq) Clauses.for_all. +Proof. + intros x y -> cl cl' eqcl. + apply iff_is_true_eq_bool. + rewrite /is_true -!ClausesFact.for_all_iff. now rewrite eqcl. +Qed. + +#[local] Instance is_model_proper : Proper (Clauses.Equal ==> eq ==> eq) is_model. +Proof. + intros cl cl' eqcl x y ->. unfold is_model. now rewrite eqcl. +Qed. + +Lemma model_le_values {m m' : model} x : m ⩽ m' -> level_value m x <= level_value m' x. +Proof. + intros lem. specialize (lem x). + unfold level_value. + destruct LevelMap.find eqn:hl => //. 2:lia. + apply LevelMap.find_2 in hl. specialize (lem _ hl) as [k' [mapsto leq]]. + now rewrite (LevelMap.find_1 mapsto). +Qed. + +Lemma level_value_MapsTo {k e} {m : model} : + LevelMap.MapsTo k e m -> level_value m k = e. +Proof. + unfold level_value. + move=> mapto; rewrite (LevelMap.find_1 mapto) //. +Qed. + +Infix "⊂_clset" := Clauses.Subset (at level 70). + +Lemma max_gain_in cl cls : + Clauses.In cl cls -> + Z.to_nat (gain cl) <= max_gain cls. +Proof. + intros hin. + unfold max_gain. revert cl hin. + eapply ClausesProp.fold_rec. + - intros s' ise hin. firstorder eauto. + - intros x a s' s'' xs nxs' hadd IH cl' hin'. + eapply hadd in hin' as []. + * subst x. lia. + * specialize (IH _ H). lia. +Qed. + +Definition max_gain_subset (cls cls' : Clauses.t) : + cls ⊂_clset cls' -> + max_gain cls <= max_gain cls'. +Proof. + unfold max_gain at 1. + revert cls'. + eapply ClausesProp.fold_rec. + - intros s' ise sub. lia. + - intros x a s' s'' xs nxs' hadd IH cls'' hs. + specialize (IH cls''). forward IH. transitivity s'' => //. + intros ??. now apply hadd. + assert (incls'' : Clauses.In x cls''). + { now apply hs, hadd. } + apply max_gain_in in incls''. lia. +Qed. + +Notation cls_diff cls W := (Clauses.diff (cls ↓ W) (cls ⇂ W)) (only parsing). + +(* + Equations? extend_model {W cls} (m : valid_model W (cls ⇂ W)) + (r : result W (Clauses.diff (cls ↓ W) (cls ⇂ W))) + : result W (cls ↓ W) := + extend_model _ Loop := Loop; + extend_model m (Model w m' sub) := + Model w {| model_model := m'.(model_model) |} _. + Proof. + - apply LevelSet.subset_spec in sub. now apply clauses_conclusions_clauses_with_concl in H. + - eapply sub. now eapply m.(model_clauses_conclusions). + - apply m. + - eapply LevelSet.subset_spec. eapply LevelSet.subset_spec in sub. + now transitivity V. + Qed. + + *) + +Lemma not_mem l s : ~~ LevelSet.mem l s <-> ~ LevelSet.In l s. +Proof. + split. apply contraNnot. apply LevelSet.mem_spec. + eapply contra_notN; tea. now move/LevelSet.mem_spec. +Qed. + +Lemma v_minus_w_bound_irrel {W} m m' : + model_map_outside W m m' -> + v_minus_w_bound W m = v_minus_w_bound W m'. +Proof. + unfold v_minus_w_bound. + intros out. eapply LevelMapFact.fold_Equal. tc. cbn. + { intros x y eq. cbn. solve_proper. } + { intros x y. cbn. intros e e' a neq. lia. } + apply LevelMapFact.F.Equal_mapsto_iff. + intros k e. rewrite -> LevelMapFact.filter_iff. + 2:{ intros x y eq. red in eq. subst; solve_proper. } + rewrite -> LevelMapFact.filter_iff. + 2:{ move=> x y ->. solve_proper. } + rewrite [_ = true]not_mem. intuition auto. + - now apply out. + - now apply out. +Qed. + +Definition max_premise_value (m : model) (l : nonEmptyLevelExprSet) : nat := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (fun min atom => Nat.max (levelexpr_value m atom) min) tl (levelexpr_value m hd). + +Definition non_W_atoms W (l : LevelExprSet.t) := + LevelExprSet.filter (fun lk => ~~ LevelSet.mem lk.1 W) l. + +Lemma non_W_atoms_spec W l : forall x, LevelExprSet.In x (non_W_atoms W l) <-> LevelExprSet.In x l /\ ~ LevelSet.In x.1 W. +Proof. + intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec -not_mem. +Qed. + +Lemma non_W_atoms_subset W l : non_W_atoms W l ⊂_leset l. +Proof. intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec. Qed. + +Lemma levelexprset_levels_spec_aux l (e : LevelExprSet.t) acc : + LevelSet.In l (LevelExprSet.fold (fun le : LevelExprSet.elt => LevelSet.add (level le)) e acc) <-> + (exists k, LevelExprSet.In (l, k) e) \/ LevelSet.In l acc. +Proof. + eapply LevelExprSetProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k hin]. lesets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.add_spec. + split. + * intros [->|]. + left. exists (levelexpr_k x). + apply hadd. cbn. left. now destruct x. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. apply hadd. now right. + * intros [[k ins'']|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma levelexprset_levels_spec l (e : LevelExprSet.t) : + LevelSet.In l (levels e) <-> exists k, LevelExprSet.In (l, k) e. +Proof. + rewrite levelexprset_levels_spec_aux. intuition auto. lsets. +Qed. + +Lemma levels_exprs_non_W_atoms {W prem} : + LevelSet.Equal (levels (non_W_atoms W prem)) (LevelSet.diff (levels prem) W). +Proof. + intros e. unfold non_W_atoms. + rewrite levelexprset_levels_spec LevelSet.diff_spec levelexprset_levels_spec. + firstorder eauto. + rewrite LevelExprSet.filter_spec in H. now exists x. + rewrite LevelExprSet.filter_spec in H. destruct H. + rewrite LevelSetFact.not_mem_iff. + destruct LevelSet.mem => //. + exists x. + rewrite LevelExprSet.filter_spec. split => //. + rewrite LevelSetFact.not_mem_iff in H0. now rewrite H0. +Qed. + +Lemma levelexprset_empty_levels x : LevelExprSet.Empty x <-> LevelSet.Empty (levels x). +Proof. + split. + - intros he. + intros l hin. + eapply levelexprset_levels_spec in hin as [k hin]. lesets. + - intros emp l hin. eapply emp. eapply (levelexprset_levels_spec l.1). exists l.2. + now destruct l. +Qed. + +Lemma non_W_atoms_ne W cl cls : + Clauses.In cl (cls_diff cls W) -> + LevelExprSet.is_empty (non_W_atoms W (premise cl)) = false. +Proof. + intros x. + apply Clauses.diff_spec in x as [clw clr]. + eapply in_clauses_with_concl in clw as [clw incls]. + apply/negbTE. + apply/(contra_notN _ clr). + intros he. rewrite in_restrict_clauses. split => //. + epose proof (@levels_exprs_non_W_atoms W (premise cl)). + eapply LevelExprSetFact.is_empty_2 in he. + intros x hin. eapply levelexprset_empty_levels in he. rewrite H in he. + specialize (he x). rewrite LevelSet.diff_spec in he. intuition auto. + rewrite -LevelSet.mem_spec in H1 |- *. destruct LevelSet.mem; intuition auto. +Qed. + +Section MoreNonEmpty. + + Import LevelExprSet. + Import NonEmptySetFacts. + + Lemma In_elements {x} {s : nonEmptyLevelExprSet} : In x s <-> List.In x (elements s). + Proof. + split. now move/LevelExprSetFact.elements_1/InA_In_eq. + now move/InA_In_eq/LevelExprSetFact.elements_2. + Qed. + + Lemma min_premise_spec_aux (m : model) s k : + min_premise m s = k -> + (forall x, LevelExprSet.In x s -> (k <= min_atom_value m x)%Z) /\ + (exists x, LevelExprSet.In x s /\ k = min_atom_value m x). + Proof. + unfold min_premise. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. reflexivity. + now exists t0; split => //. + - destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [t0]) in H as [<-|inih]. + cbn. rewrite fold_left_comm. lia. lia. + specialize (ha _ inih). + cbn. rewrite fold_left_comm. lia. lia. + destruct hex as [minval [inmin ih]]. + cbn. rewrite fold_left_comm. lia. + destruct (Z.leb_spec (min_atom_value m a) (min_atom_value m minval)). + exists a. split; [intuition|]. lia. exists minval. + cbn in inmin; split; [intuition auto|]. lia. + Qed. + + Lemma min_premise_spec (m : model) (s : nonEmptyLevelExprSet) : + (forall x, LevelExprSet.In x s -> (min_premise m s <= min_atom_value m x)%Z) /\ + (exists x, LevelExprSet.In x s /\ min_premise m s = min_atom_value m x). + Proof. + now apply min_premise_spec_aux. + Qed. + + Lemma min_premise_subset (m : model) (s s' : nonEmptyLevelExprSet) : + LevelExprSet.Subset s s' -> + (min_premise m s' <= min_premise m s)%Z. + Proof. + intros sub. + have [has [mins [ins eqs]]] := min_premise_spec m s. + have [has' [mins' [ins' eqs']]] := min_premise_spec m s'. + specialize (sub _ ins). specialize (has' _ sub). + lia. + Qed. + + Lemma premise_min_spec_aux s k : + premise_min s = k -> + (forall x, LevelExprSet.In x s -> (k <= x)) /\ + (exists x, LevelExprSet.In x s /\ k = x). + Proof. + unfold premise_min. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. + now exists t0; split => //. + - destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [t0]) in H as [<-|inih]. + cbn. rewrite fold_left_comm. unfold level_expr_elt in *; lia. unfold level_expr_elt in *; lia. + specialize (ha _ inih). + cbn. rewrite fold_left_comm. lia. lia. + destruct hex as [minval [inmin ih]]. + cbn. rewrite fold_left_comm. lia. + destruct (Nat.leb_spec a minval). + exists a. split; [intuition|]. rewrite -ih in H. unfold level_expr_elt in *; lia. + exists minval. + cbn in inmin; split; [intuition auto|]. lia. + Qed. + + Lemma premise_min_spec (s : nonEmptyLevelExprSet) : + (forall x, LevelExprSet.In x s -> premise_min s <= x) /\ + (exists x, LevelExprSet.In x s /\ premise_min s = x). + Proof. + now apply premise_min_spec_aux. + Qed. + + Lemma premise_min_subset (s s' : nonEmptyLevelExprSet) : + LevelExprSet.Subset s s' -> + premise_min s' <= premise_min s. + Proof. + intros sub. + have [has [mins [ins eqs]]] := premise_min_spec s. + have [has' [mins' [ins' eqs']]] := premise_min_spec s'. + specialize (sub _ ins). specialize (has' _ sub). + lia. + Qed. + + Lemma max_premise_value_spec_aux (m : model) s k : + max_premise_value m s = k -> + (forall x, LevelExprSet.In x s -> levelexpr_value m x <= k) /\ + (exists x, LevelExprSet.In x s /\ k = levelexpr_value m x). + Proof. + unfold max_premise_value. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. + now exists t0; split => //. + - destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [t0]) in H as [<-|inih]. + cbn. rewrite fold_left_comm. lia. lia. + specialize (ha _ inih). + cbn. rewrite fold_left_comm. lia. lia. + destruct hex as [maxval [inmax ih]]. + cbn. rewrite fold_left_comm. lia. + destruct (Nat.leb_spec (levelexpr_value m maxval) (levelexpr_value m a)). + exists a. split; [intuition|]. lia. exists maxval. + cbn in inmax; split; [intuition auto|]. lia. + Qed. + + Lemma max_premise_value_spec (m : model) (s : nonEmptyLevelExprSet) : + (forall x, LevelExprSet.In x s -> levelexpr_value m x <= max_premise_value m s) /\ + (exists x, LevelExprSet.In x s /\ max_premise_value m s = levelexpr_value m x). + Proof. + now apply max_premise_value_spec_aux. + Qed. +End MoreNonEmpty. + +Lemma min_premise_pos_spec {m prem} : + (0 <= min_premise m prem)%Z -> + forall x, LevelExprSet.In x prem -> levelexpr_k x <= levelexpr_value m x. +Proof. + pose proof (min_premise_spec m prem) as [amin [exmin [inminpre eqminpre]]]. + intros hprem x hin. + specialize (amin _ hin). + unfold min_atom_value in amin. + destruct x as [l k]; cbn in *. unfold levelexpr_value; cbn. + lia. +Qed. + +Definition equal_model (m m' : model) := LevelMap.Equal m m'. + +#[local] Instance equal_model_equiv : Equivalence equal_model. +Proof. unfold equal_model. + split; try econstructor; eauto. + red. intros. now symmetry. + red; intros. now transitivity y. +Qed. + +#[local] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. +Proof. + intros x y eqm l ? <-. unfold level_value. + unfold equal_model in eqm. + destruct LevelMap.find eqn:hl. + - eapply LevelMap.find_2 in hl. + rewrite eqm in hl. + eapply LevelMap.find_1 in hl. now rewrite hl. + - eapply LevelMapFact.F.not_find_in_iff in hl. + rewrite eqm in hl. + eapply LevelMapFact.F.not_find_in_iff in hl. + now rewrite hl. +Qed. + +Lemma v_minus_w_bound_spec W m : + forall x, ~ LevelSet.In x W -> level_value m x <= v_minus_w_bound W m. +Proof. + intros x him. + unfold v_minus_w_bound. + set (fm := LevelMapFact.filter _ _). + replace (level_value m x) with (level_value fm x). + 2:{ unfold level_value. + destruct LevelMap.find eqn:hl => //. + eapply LevelMap.find_2 in hl. + subst fm. cbn in hl. + eapply LevelMapFact.filter_iff in hl as []. 2:tc. + rewrite (LevelMap.find_1 H) //. + destruct (LevelMap.find _ m) eqn:hl' => //. + eapply LevelMap.find_2 in hl'. + assert (LevelMap.MapsTo x n fm). + eapply LevelMapFact.filter_iff. tc. + split => //. now rewrite [_ = true]not_mem. + now rewrite (LevelMap.find_1 H) in hl. } + clearbody fm. + eapply LevelMapFact.fold_rec. + - intros m' em. unfold level_value. + destruct LevelMap.find eqn:hl => //. + eapply LevelMap.find_2 in hl. + now apply em in hl. + - intros k e a m' m'' map nin hadd. + red in hadd. + unfold level_value. cbn. + rewrite hadd LevelMapFact.F.add_o. + destruct LevelMap.OT.eq_dec. do 2 red in e0. subst x. lia. + destruct LevelMap.find; lia. +Qed. + +Lemma clauses_levels_restrict_clauses cls W : + LevelSet.Subset (clauses_levels (cls ⇂ W)) W. +Proof. + intros x [cl []] % clauses_levels_spec. + eapply in_restrict_clauses in H as [hconc hprem incl]. + eapply clause_levels_spec in H0 as []. apply hprem, H. now subst x. +Qed. + +Lemma clauses_conclusions_levels cls : + clauses_conclusions cls ⊂_lset clauses_levels cls. +Proof. + intros x. + rewrite clauses_conclusions_spec clauses_levels_spec. + setoid_rewrite clause_levels_spec. + firstorder auto. +Qed. + +Record model_extension W m m' := + { model_ext_le : m ⩽ m'; + model_ext_same_domain : model_same_domain m m'; + model_ext_same_outside : model_map_outside W m m' }. + +#[local] Instance model_ext_reflexive W : Reflexive (model_extension W). +Proof. + intros m; split; reflexivity. +Qed. + +#[local] Instance model_ext_transitive W : Transitive (model_extension W). +Proof. + intros m m' m'' h h'; split; (etransitivity; [apply h|apply h']). +Qed. + +Lemma model_extension_weaken W W' m m' : + W ⊂_lset W' -> + model_extension W m m' -> + model_extension W' m m'. +Proof. + intros leW []; split => //. + eapply model_map_outside_weaken; tea. +Qed. + +Lemma model_ext_trans_weaken W W' m m' m'' : + W ⊂_lset W' -> + model_extension W m m' -> + model_extension W' m' m'' -> + model_extension W' m m''. +Proof. + intros leW mext mext'. eapply model_extension_weaken in mext; tea. + now etransitivity; tea. +Qed. + +Definition check_model_invariants cls w m w' m' (modified : bool) := + if modified then + [/\ w ⊂_lset w', + w' ⊂_lset (LevelSet.union w (clauses_conclusions cls)), + exists cl, + let cll := (levelexpr_level (concl cl)) in + [/\ Clauses.In cl cls, ~~ valid_clause m cl, + LevelSet.In cll w' & + level_value m cll < level_value m' cll] & + model_extension w' m m'] + else (w, m) = (w', m'). + +#[local] Instance clauses_conclusions_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_conclusions. +Proof. + intros cls cls' eq x. + rewrite !clauses_conclusions_spec. now setoid_rewrite eq. +Qed. + +#[local] Instance And3P_proper : Proper (iff ==> iff ==> iff ==> iff) ssrbool.and3. +Proof. + repeat intro. split; intros []; split; intuition auto. +Qed. + +#[local] Instance And4P_proper : Proper (iff ==> iff ==> iff ==> iff ==> iff) ssrbool.and4. +Proof. + repeat intro. split; intros []; split; intuition auto. +Qed. + +#[local] Instance check_model_invariants_proper : + Proper (Clauses.Equal ==> eq ==> eq ==> eq ==> eq ==> eq ==> iff) check_model_invariants. +Proof. + intros cls cls' eqcls. + repeat intro; subst. + unfold check_model_invariants. + destruct y3 => //. + now setoid_rewrite <-eqcls. +Qed. + +Lemma min_atom_value_levelexpr_value m l : Z.to_nat (min_atom_value m l) <= levelexpr_value m l - l. +Proof. + destruct l as [l k]; cbn. unfold levelexpr_value. cbn. lia. +Qed. + +Lemma clauses_conclusions_add cl cls : + clauses_conclusions (Clauses.add cl cls) =_lset + (LevelSet.singleton (level (concl cl)) ∪ + clauses_conclusions cls). +Proof. + intros x. + rewrite LevelSet.union_spec !clauses_conclusions_spec. + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.singleton_spec. + firstorder eauto. subst. now left. +Qed. + +Definition declared_model_level (m : model) l := LevelMap.In l m. + +Definition clause_conclusion cl := levelexpr_level (concl cl). + +Definition update_model_same_domain {m l k} : + declared_model_level m l -> + model_same_domain m (update_model m l k). +Proof. + unfold update_model, declared_model_level. + intros hin x. + rewrite LevelMapFact.F.add_in_iff. intuition auto. now subst. +Qed. + +Definition update_model_outside {m w l k} : + model_map_outside (LevelSet.add l w) m (update_model m l k). +Proof. + unfold update_model, model_map_outside. + intros l'. rewrite LevelSet.add_spec. + intros hin k'. + rewrite LevelMapFact.F.add_neq_mapsto_iff //. + intros heq. red in heq; subst l'. apply hin. now left. +Qed. + +Lemma check_clause_model_modify' {cl cls w m w' m' w'' m'' modified modified'} : + check_model_invariants cls w m w' m' modified -> + declared_model_level m (clause_conclusion cl) -> + check_clause_model cl (modified, (w', m')) = (modified', (w'', m'')) -> + check_model_invariants (Clauses.add cl cls) w m w'' m'' modified'. +Proof. + intros inv declcl. + unfold check_clause_model. + destruct (update_value (w', m') cl) eqn:upd. + * intros [= <- <-]. subst. + destruct modified. 2:{ noconf inv. reflexivity. } + destruct inv. + split => //. + + rewrite clauses_conclusions_add; lsets. + + destruct H1 as [cl' []]. + exists cl'; split => //. now rewrite Clauses.add_spec. + * intros [= <- <-]. subst. + destruct modified. 2:{ noconf inv. reflexivity. } + destruct inv. + split => //. + + rewrite clauses_conclusions_add; lsets. + + destruct H1 as [cl' []]. + exists cl'; split => //. now rewrite Clauses.add_spec. + * intros [= <- ->]. + move: upd. + unfold update_value. + case: Z.ltb_spec => //. + destruct cl as [prem [l k]] => /=. + intros hprem. + case: Nat.leb_spec => // hlt. + intros [= <- <-]. + destruct modified; noconf inv. + { destruct inv. + split => //. + + lsets. + + rewrite clauses_conclusions_add. + intros x. rewrite LevelSet.add_spec !LevelSet.union_spec LevelSet.singleton_spec. + intuition eauto. cbn. apply H0 in H4. lsets. + + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. + destruct H1 as [cl []]; exists cl; split => //. eauto. eauto. + eapply Nat.lt_le_trans; tea. + eapply model_le_values. + now eapply update_model_monotone. + + transitivity m'. + { eapply model_extension_weaken; tea. lsets. } + split. + { now eapply update_model_monotone. } + { eapply update_model_same_domain. + eapply H2, declcl. } + { eapply update_model_outside. } } + { split => //. + + lsets. + + rewrite clauses_conclusions_add. + intros x. rewrite LevelSet.add_spec !LevelSet.union_spec LevelSet.singleton_spec. + intuition eauto. + + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. + exists (prem, (l, k)). + split; tea; eauto. + - unfold valid_clause. cbn. + case: Z.ltb_spec => //. cbn. lia. intros _. + rewrite -Nat.ltb_antisym. apply Nat.ltb_lt; lia. + - cbn. now rewrite level_value_update_model. + + split. + { now eapply update_model_monotone. } + { eapply update_model_same_domain. + eapply declcl. } + { eapply update_model_outside. } } +Qed. + +Definition model_of V (m : model) := + forall k, LevelSet.In k V -> LevelMap.In k m. + +Lemma model_of_subset V V' m : + model_of V m -> V' ⊂_lset V -> model_of V' m. +Proof. + rewrite /model_of. intros ih hv k. specialize (ih k). + now move/hv. +Qed. + +Lemma clauses_conclusions_subset {cls cls'} : + Clauses.Subset cls cls' -> + clauses_conclusions cls ⊂_lset clauses_conclusions cls'. +Proof. + intros hsub x. rewrite !clauses_conclusions_spec. + intuition eauto. destruct H as [cl []]; exists cl; split; try clsets; auto. +Qed. + +Lemma check_model_aux_spec {cls w m w' m' modified} : + model_of (clauses_conclusions cls) m -> + check_model_aux cls (w, m) = (modified, (w', m')) -> + check_model_invariants cls w m w' m' modified. +Proof. + rewrite /check_model_aux /is_model. + revert modified w' m'. + eapply ClausesProp.fold_rec. + - intros s' e modified w' m' mof [= <- <- <-]. + split. + - intros x ? s' s'' inx nins' hadd ih modified w' m' mof. + destruct a as [modified'' [w'' m'']]. + assert (ms' : model_of (clauses_conclusions s') m). + { eapply model_of_subset; tea. + eapply clauses_conclusions_subset. red in hadd. intros ?. + specialize (hadd a). intuition auto. } + specialize (ih _ _ _ ms' eq_refl). + apply ClausesProp.Add_Equal in hadd. rewrite hadd. + eapply check_clause_model_modify' => //. + red. apply mof. + apply clauses_conclusions_spec. exists x; split => //. + apply hadd. clsets. +Qed. + +Lemma check_model_spec {cls w m w' m'} : + model_of (clauses_conclusions cls) m -> + check_model cls (w, m) = Some (w', m') -> + check_model_invariants cls w m w' m' true. +Proof. + intros mof. + unfold check_model. + destruct check_model_aux eqn:cm. + destruct p as []. + eapply check_model_aux_spec in cm => //. + destruct b => //. now intros [= <- <-]. +Qed. + +Lemma check_model_aux_not_model {cls w m w' m'} : + model_of (clauses_conclusions cls) m -> + check_model_aux cls (w, m) = (true, (w', m')) -> + ~~ is_model cls m. +Proof. + intros mof. + move/(check_model_aux_spec mof) => [] _ _ [cl [incl inval]] _ _ _. + unfold is_model. + apply clauses_for_all_neg. + intros hf. specialize (hf cl incl). cbn in hf. + rewrite /is_true hf in inval => //. +Qed. + +Lemma check_model_is_model {W cls m} : + model_of (clauses_conclusions cls) m -> + check_model cls (W, m) = None <-> is_model cls m. +Proof. + intros mof; unfold check_model, is_model. + destruct check_model_aux eqn:caux. + destruct b => //. intuition auto. congruence. + { destruct p; eapply check_model_aux_not_model in caux => //. + rewrite /is_model /= // in caux. now rewrite H in caux. } + intuition auto. + pose proof (check_model_aux_false caux). subst p. + now rewrite check_model_aux_model in caux. +Qed. + +Lemma check_model_update {W cls m wm'} : + model_of (clauses_conclusions cls) m -> + check_model cls (W, m) = Some wm' -> ~~ is_model cls m /\ m ⩽ wm'.2. +Proof. + intros mof; unfold check_model, is_model. + destruct check_model_aux eqn:caux. + destruct b => //. intros [= <-]. intuition auto. + destruct p. + now eapply check_model_aux_not_model in caux. + now eapply check_model_aux_model_le in caux. +Qed. + +Definition measure_w W cls m w := + let bound := v_minus_w_bound W m in + let maxgain := max_gain (cls_diff cls W) in + (Z.of_nat bound + Z.of_nat maxgain - Z.of_nat (level_value m w))%Z. + +Lemma invalid_clause_measure W cls cl m : + ~~ valid_clause m cl -> + Clauses.In cl (cls_diff cls W) -> + (0 < measure_w W cls m (concl cl))%Z. +Proof. + unfold valid_clause. + case: Z.ltb_spec => // hprem. + destruct cl as [prem [l k]]; cbn. + case: Nat.leb_spec => // hlt. intros _ hin. + have hne := (non_W_atoms_ne _ _ _ hin). + cbn. unfold measure_w. unfold gain. + set (clsdiff := Clauses.diff _ _). + set (bound := v_minus_w_bound W m). + enough (Z.of_nat (level_value m l) < Z.of_nat bound + Z.of_nat (max_gain clsdiff))%Z. lia. + set (prem' := non_W_atoms W prem). + set (preml := {| t_set := prem'; t_ne := hne |}). + assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff). + { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. + unfold gain. cbn. + pose proof (premise_min_subset preml prem). + rewrite !Z2Nat.inj_sub //; try lia. rewrite !Nat2Z.id. + forward H. eapply non_W_atoms_subset. lia. } + eapply Z.lt_le_trans with (Z.of_nat bound + Z.of_nat (Z.to_nat (gain (preml, (l, k)))))%Z; try lia. + rewrite -Nat2Z.inj_add. + unfold gain; cbn. + enough (level_value m l < v_minus_w_bound W m + (k - premise_min preml)). lia. + enough (k + Z.to_nat (min_premise m prem) <= v_minus_w_bound W m + (k - premise_min preml)). lia. + assert (min_premise m prem <= min_premise m preml)%Z. + { eapply min_premise_subset. eapply non_W_atoms_subset. } + transitivity (k + Z.to_nat (min_premise m preml)). lia. + pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. + pose proof (max_premise_value_spec m preml) as [amax [exmax [inmaxpre eqmaxpre]]]. + pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. + assert (premise_min prem <= premise_min preml). + { eapply premise_min_subset. eapply non_W_atoms_subset. } + transitivity (v_minus_w_bound W m + (k - premise_min preml)). 2:lia. + assert (Z.to_nat (min_premise m preml) <= max_premise_value m preml - premise_min preml). + { rewrite eqpminpre eqmaxpre eqminpre. + pose proof (min_atom_value_levelexpr_value m exmin). etransitivity; tea. + specialize (amax _ inminpre). rewrite eqmaxpre in amax. + assert (expmin <= exmin). specialize (apmin _ inminpre). lia. + unfold level_expr_elt in *. lia. } + transitivity (k + (max_premise_value m preml - premise_min preml)). lia. + assert (premise_min preml <= max_premise_value m preml). + { rewrite eqmaxpre. + move/min_premise_pos_spec: hprem => hprem. + transitivity exmax. apply apmin => //. eapply hprem. + now apply (non_W_atoms_subset W prem). } + assert (k + (max_premise_value m preml - premise_min preml) = + (max_premise_value m preml + k - premise_min preml)) as ->. lia. + enough (max_premise_value m preml <= v_minus_w_bound W m). lia. + { rewrite eqmaxpre. + apply v_minus_w_bound_spec. + intros hin'. + have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). + rewrite levelexprset_levels_spec in hlevels. + forward hlevels. + exists exmax.2. now destruct exmax. + rewrite LevelSet.diff_spec in hlevels. + now destruct hlevels. } +Qed. + +Definition levelset_m_eq : LevelSet.t × model -> LevelSet.t × model -> Prop := + fun x y => LevelSet.Equal x.1 y.1 /\ LevelMap.Equal x.2 y.2. + +#[local] Instance lmeq_eq : Equivalence levelset_m_eq. +Proof. + split. intros x. split => //. + intros x y []; split => //. now rewrite H. + intros x y z [] []; split => //. + all:etransitivity; tea. +Qed. + +Definition modified_levelset_m_eq : bool × LevelSet.t × model -> bool × LevelSet.t × model -> Prop := + fun x y => x.1 = y.1 /\ levelset_m_eq x.2 y.2. + +#[local] Instance mlm_eq : Equivalence modified_levelset_m_eq. +Proof. + split. intros x. split => //. + intros x y []; split => //. now symmetry. + intros x y z [] []; split => //. all:etransitivity; tea. +Qed. + +#[local] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. +Proof. + intros m m' eqm ? ? ->. unfold min_atom_value. + destruct y => //. + now rewrite eqm. +Qed. + +#[local] Instance fold_left_ext {A B} : Proper (`=2` ==> eq ==> eq ==> eq) (@fold_left A B). +Proof. + intros f g hfg ? ? -> ? ? ->. + induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). +Qed. + +#[local] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. +Proof. + intros m m' eq ? ? ->. + unfold min_premise. + destruct to_nonempty_list. + now setoid_rewrite eq. +Qed. + +#[local] Instance update_model_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> LevelMap.Equal) update_model. +Proof. + intros m m' hm ? ? -> ? ? ->. + unfold update_model. + now rewrite hm. +Qed. + +#[local] Instance check_clause_model_proper : Proper (eq ==> modified_levelset_m_eq ==> modified_levelset_m_eq) check_clause_model. +Proof. + intros x y eq [? []] [? []] []; cbn in *; subst. + unfold levelset_m_eq in H0. destruct H0; cbn in *; subst. + replace (min_premise m (premise y)) with (min_premise m0 (premise y)). + 2: now rewrite H0. + destruct Z.ltb => //. + destruct concl => //. + replace (level_value m t1) with (level_value m0 t1). + 2:now rewrite H0. + destruct Nat.leb => //. + red. cbn. split => //. + red. cbn; split => //. now rewrite H. now rewrite H0. +Qed. + +Module ClausesOrd := OrdProperties Clauses. + + +#[local] Instance check_model_aux_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model_aux. +Proof. + intros cls cls' eq. + intros wm wm' eq'. subst wm'. + unfold check_model_aux. + now eapply ClausesOrd.fold_equal; tc. +Qed. + +#[local] Instance check_model_aux_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> modified_levelset_m_eq) check_model_aux. +Proof. + intros cls cls' eq. + intros wm wm' eq'. + transitivity (check_model_aux cls' wm). + 2:{ unfold check_model_aux. + eapply (ClausesProp.fold_init (eqA := modified_levelset_m_eq)); tc. + red. cbn => //. } + unfold check_model_aux. + now eapply ClausesOrd.fold_equal; tc. +Qed. + +#[local] Instance check_model_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> R_opt levelset_m_eq) check_model. +Proof. + intros cls cls' eq. + intros wm wm' eq'. + unfold check_model. + destruct (check_model_aux cls wm) eqn:eqc. + destruct (check_model_aux cls' wm') eqn:eqc' => //. + pose proof (check_model_aux_proper cls cls' eq wm wm' eq'). + rewrite eqc eqc' in H. destruct H; cbn in *; subst. + red in H0. destruct H0. + destruct b0 => //. +Qed. + +#[local] Instance check_model_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model. +Proof. + intros cls cls' eq. + intros wm wm' eq'. + unfold check_model. + now subst wm'; rewrite eq. +Qed. + +Record valid_model_def (V : LevelSet.t) (m : model) (cls : clauses) := + { model_model : model; + model_of_V :> model_of V model_model; + model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; + model_ok :> is_model cls model_model; + model_extends : model_extension V m model_model; + }. +Arguments model_model {V m cls}. +Arguments model_of_V {V m cls}. +Arguments model_clauses_conclusions {V m cls}. +Arguments model_ok {V m cls}. +Arguments model_extends {V m cls}. +Extraction Inline model_model. + +Definition valid_model := valid_model_def. + +Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := + | Loop + | Model (w : LevelSet.t) (m : valid_model V m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). +Arguments Loop {V U cls m}. +Arguments Model {V U cls m}. +Arguments lexprod {A B}. + +Definition option_of_result {V U m cls} (r : result V U m cls) : option model := + match r with + | Loop => None + | Model w m sub => Some m.(model_model) + end. + +Definition extends_model {W U cls m m'} : + m' ⩽ m -> + model_same_domain m' m -> + model_map_outside W m' m -> + result W U cls m -> result W U cls m'. +Proof. + intros leq ldom lout []. exact Loop. + econstructor 2; tea. + destruct m0. econstructor; tea. + - now transitivity m. +Qed. + +(* #[tactic="idtac"] +Equations? result_inclusion {V U m cls V'} (r : result V U cls m) + (prf : LevelSet.Subset V V') : result V' U cls m := + result_inclusion Loop _ := Loop; + result_inclusion (Model w m' sub) sub' := + Model w {| model_model := m'.(model_model) |} _. +Proof. + - + - transitivity V => //. now eapply m'.(model_clauses_conclusions). + - apply m'. + - apply m'. + - apply m'. + - intros x hin. apply m'. intros hv. + apply sub' in hv. now apply hin. + - intuition lsets. +Qed. *) + +Notation "#| V |" := (LevelSet.cardinal V). + +Notation loop_measure V W := (#|V|, #|V| - #|W|). + +Definition lexprod_rel := lexprod lt lt. + +#[local] Instance lexprod_rel_wf : WellFounded lexprod_rel. +Proof. + eapply (Acc_intro_generator 1000). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. +Defined. + +Section InnerLoop. + Context (V : LevelSet.t) (U : LevelSet.t) + (loop : forall (V' U' : LevelSet.t) (cls : clauses) (m : model) + (prf : [/\ clauses_conclusions cls ⊂_lset V', U' ⊂_lset V' & model_of V' m]), + lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls m). + + Definition sum_W W (f : LevelSet.elt -> nat) := + LevelSet.fold (fun w acc => acc + f w) W 0. + + Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := + sum_W W (fun w => Z.to_nat (measure_w W cls m w)). + + Lemma measure_model W cls m : + let clsdiff := cls_diff cls W in + measure W cls m = 0 -> is_model clsdiff m. + Proof using. + clear loop V U. + unfold measure, sum_W, measure_w, is_model. + set (clsdiff := Clauses.diff _ _). + intros hm. + assert (LevelSet.For_all (fun w => v_minus_w_bound W m + max_gain clsdiff <= level_value m w) W). + { move: hm. + generalize (v_minus_w_bound W m) => vbound. + eapply LevelSetProp.fold_rec. + intros. intros x hin. firstorder eauto. + intros x a s' s'' inw nins' hadd ih heq. + forward ih by lia. + intros l hin. + apply hadd in hin as []. + * subst x. lia. + * now apply ih. } + clear hm. + eapply ClausesFact.for_all_iff. tc. + intros cl hl. + unfold valid_clause. + case: Z.ltb_spec => // hk0. + destruct cl as [prem [l k]] => /=. + eapply Nat.leb_le. cbn in hk0. + rewrite /clsdiff in hl. + destruct (proj1 (Clauses.diff_spec _ _ _) hl) as [hlcls hl']. + eapply in_clauses_with_concl in hlcls as [lW incls]. + specialize (H _ lW). cbn -[clsdiff] in H. cbn in lW. + etransitivity; tea. + set (prem' := non_W_atoms W prem). + assert (ne : LevelExprSet.is_empty prem' = false). + { now eapply (non_W_atoms_ne W (prem, (l, k)) cls). } + set (preml := {| t_set := prem'; t_ne := ne |}). + assert (min_premise m prem <= min_premise m preml)%Z. + { eapply min_premise_subset. eapply non_W_atoms_subset. } + (* min_i (f(x_i)-k_i) <= max_i(f(x_i)) - min(k_i) *) + pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. + pose proof (max_premise_value_spec m preml) as [amax [exmax [inmaxpre eqmaxpre]]]. + pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. + assert (Z.to_nat (min_premise m preml) <= + (max_premise_value m preml) - premise_min preml). + { rewrite eqpminpre eqmaxpre eqminpre. + pose proof (min_atom_value_levelexpr_value m exmin). etransitivity; tea. + specialize (amax _ inminpre). rewrite eqmaxpre in amax. + assert (expmin <= exmin). specialize (apmin _ inminpre). lia. + unfold level_expr_elt in *. lia. } + transitivity (k + (max_premise_value m preml - premise_min preml)). lia. + assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff). + { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. + unfold gain. cbn. + pose proof (premise_min_subset preml prem). + rewrite !Z2Nat.inj_sub //; try lia. rewrite !Nat2Z.id. + forward H2. eapply non_W_atoms_subset. lia. } + transitivity (v_minus_w_bound W m + Z.to_nat (gain (preml, (l, k)))). + 2:lia. + unfold gain. cbn -[max_premise_value premise_min]. + assert (premise_min preml <= max_premise_value m preml). + { rewrite eqmaxpre. + move/min_premise_pos_spec: hk0 => hprem. + transitivity exmax. apply apmin => //. eapply hprem. + now apply (non_W_atoms_subset W prem). } + assert (k + (max_premise_value m preml - premise_min preml) = + (max_premise_value m preml + k - premise_min preml)) as ->. lia. + rewrite Z2Nat.inj_sub. lia. + rewrite !Nat2Z.id. + assert (max_premise_value m preml <= v_minus_w_bound W m). + { rewrite eqmaxpre. + apply v_minus_w_bound_spec. + intros hin. + have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). + rewrite levelexprset_levels_spec in hlevels. + forward hlevels. + exists exmax.2. now destruct exmax. + rewrite LevelSet.diff_spec in hlevels. + now destruct hlevels. } + lia. + Qed. + + Lemma measure_le {W cls m m'} : + model_map_outside W m m' -> + m ⩽ m' -> + (measure W cls m' <= measure W cls m). + Proof. + intros hout hle. + unfold measure, measure_w, sum_W. + rewrite (v_minus_w_bound_irrel _ _ hout). + rewrite !LevelSet.fold_spec. unfold flip. + eapply fold_left_le; unfold flip. 2:lia. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + lia. + Qed. + + Lemma measure_lt {W cls m m'} : + model_map_outside W m m' -> + m ⩽ m' -> + (exists l, [/\ LevelSet.In l W, (0 < measure_w W cls m l)%Z & level_value m l < level_value m' l]) -> + (measure W cls m' < measure W cls m). + Proof. + intros hout hle. + unfold measure, measure_w, sum_W. + rewrite (v_minus_w_bound_irrel _ _ hout). + intros hlt. + rewrite !LevelSet.fold_spec. unfold flip. + eapply fold_left_ne_lt; unfold flip. + - unfold flip. intros; lia. + - unfold flip; intros; lia. + - destruct hlt as [l [hin _]]. intros he. rewrite -LevelSetProp.elements_Empty in he. lsets. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + lia. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + lia. + - destruct hlt as [l [hinl hbound hlev]]. + exists l. rewrite LevelSet_In_elements. split => //. + intros acc acc' accle. + eapply Nat.add_le_lt_mono => //. lia. + Qed. + + Lemma is_model_equal {cls cls' m} : Clauses.Equal cls cls' -> is_model cls m -> is_model cls' m. + Proof. now intros ->. Qed. + + Lemma union_diff_eq {cls cls'} : Clauses.Equal (Clauses.union cls (Clauses.diff cls' cls)) + (Clauses.union cls cls'). + Proof. clsets. Qed. + + Lemma union_restrict_with_concl {cls W} : + Clauses.Equal (Clauses.union (cls ⇂ W) (cls ↓ W)) (cls ↓ W). + Proof. + intros cl. rewrite Clauses.union_spec. + intuition auto. + eapply in_clauses_with_concl. + now eapply in_restrict_clauses in H0 as []. + Qed. + + Lemma maps_to_level_value x (m m' : model) : + (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> + level_value m x = level_value m' x. + Proof. + intros heq. + unfold level_value. + destruct LevelMap.find eqn:hl. + apply LevelMap.find_2 in hl. rewrite heq in hl. + rewrite (LevelMap.find_1 hl) //. + destruct (LevelMap.find x m') eqn:hl' => //. + apply LevelMap.find_2 in hl'. rewrite -heq in hl'. + now rewrite (LevelMap.find_1 hl') in hl. + Qed. + + Lemma measure_Z_lt x y : + (x < y)%Z -> + (0 < y)%Z -> + Z.to_nat x < Z.to_nat y. + Proof. intros. lia. Qed. + + Lemma sum_pos W f : + (0 < sum_W W f) -> + exists w, LevelSet.In w W /\ (0 < f w). + Proof. + unfold sum_W. + eapply LevelSetProp.fold_rec => //. + intros. lia. + intros. + destruct (Nat.ltb_spec 0 a). + - destruct (H2 H4) as [w [hin hlt]]. exists w. split => //. apply H1. now right. + - exists x. split => //. apply H1. now left. lia. + Qed. + + Lemma measure_pos {W cls m} : + (0 < measure W cls m) -> + exists l, LevelSet.In l W /\ (0 < measure_w W cls m l)%Z. + Proof. + unfold measure. + move/sum_pos => [w [hin hlt]]. + exists w. split => //. lia. + Qed. + + Lemma model_of_diff cls W m : + model_of W m -> model_of (clauses_conclusions (cls_diff cls W)) m. + Proof. + intros; eapply model_of_subset; tea. + eapply clauses_conclusions_diff_left. + Qed. + Hint Resolve model_of_diff : core. + + Lemma check_model_spec_diff {cls w m w' m' w''} : + model_of w m -> + let cls := (cls_diff cls w) in + check_model cls (w'', m) = Some (w', m') -> + [/\ w'' ⊂_lset w', w' ⊂_lset (w'' ∪ w), + exists cl : clause, + let cll := levelexpr_level (concl cl) in + [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' + & level_value m cll < level_value m' cll] + & model_extension w' m m']. + Proof. + cbn; intros mof cm. + pose proof (clauses_conclusions_diff_left cls w (cls ⇂ w)). + apply check_model_spec in cm as []. + split => //. lsets. + eapply model_of_subset; tea. + Qed. + + Lemma model_of_ext {W W' m m'} : + model_of W m -> model_extension W' m m' -> model_of W m'. + Proof. + intros mof [_ dom _]. + intros k hin. apply dom. now apply mof. + Qed. + + Lemma clauses_partition_spec {cls W allW conclW} : + clauses_conclusions cls ⊂_lset W -> + Clauses.partition (premise_restricted_to W) cls = (allW, conclW) -> + (Clauses.Equal allW (cls ⇂ W)) /\ + (Clauses.Equal conclW (Clauses.diff cls (cls ⇂ W))). + Proof. + intros clW. + destruct Clauses.partition eqn:eqp. + intros [= <- <-]. + change t with (t, t0).1. + change t0 with (t, t0).2 at 2. + rewrite -eqp. clear t t0 eqp. + split. + - intros cl. rewrite Clauses.partition_spec1. + rewrite in_restrict_clauses Clauses.filter_spec. + rewrite /premise_restricted_to LevelSet.subset_spec. firstorder eauto. + apply clW, clauses_conclusions_spec. now exists cl. + - intros cl. rewrite Clauses.partition_spec2. + rewrite Clauses.filter_spec Clauses.diff_spec. + rewrite /premise_restricted_to. intuition auto. + move/negbTE: H1. eapply eq_true_false_abs. + eapply LevelSet.subset_spec. + now eapply in_restrict_clauses in H as []. + apply eq_true_not_negb. move/LevelSet.subset_spec => he. + apply H1. apply in_restrict_clauses. split => //. + apply clW, clauses_conclusions_spec. now exists cl. + Qed. + + Lemma clauses_conclusions_eq cls W : + clauses_conclusions cls ⊂_lset W -> + Clauses.Equal cls (cls ↓ W). + Proof. + intros cl x. + rewrite in_clauses_with_concl. intuition auto. + apply cl, clauses_conclusions_spec. now exists x. + Qed. + + Section innerloop_partition. + Context (W : LevelSet.t) (cls : clauses). + Context (premconclW conclW : clauses). + Context (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W, + Clauses.Equal premconclW (cls ⇂ W) & Clauses.Equal conclW (Clauses.diff (cls ↓ W) (cls ⇂ W))]). + + #[tactic="idtac"] + Equations? inner_loop_partition (m : model) (mW : model_of W m) : result W U cls m + by wf (measure W cls m) lt := + inner_loop_partition m mW with loop W LevelSet.empty premconclW m _ _ := { + (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) + | Loop => Loop + (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). + By invariant Wr ⊂ W *) + | Model Wr mr hsub with inspect (check_model conclW (Wr, model_model mr)) := { + | exist None eqm => Model W {| model_model := model_model mr |} _ + | exist (Some (Wconcl, mconcl)) eqm with inner_loop_partition mconcl _ := { + (* Here Wconcl ⊂ Wr by invariant *) + | Loop => Loop + | Model Wr' mr' hsub' => Model Wr' {| model_model := model_model mr' |} hsub' } + (* Here Wr' ⊂ W by invariant *) + (* We check if the new model [mr] for (cls ⇂ W) extends to a model of (cls ↓ W). *) + (* We're entitled to recursively compute a better model starting with mconcl, + as we have made the measure decrease: + some atom in W has been strictly updated in Wconcl. *) + } }. + Proof. + all:cbn [model_model]; clear loop inner_loop_partition. + all:try solve [try apply LevelSet.subset_spec; try reflexivity]. + all:try apply LevelSet.subset_spec in hsub. + all:auto. + all:try destruct prf as [WV neW UW clsW eqprem eqconcl]. + all:try solve [intuition auto]. + all:try rewrite eqconcl in eqm. + - split => //. rewrite eqprem. apply clauses_conclusions_restrict_clauses. lsets. + - left. now eapply strict_subset_cardinal. + - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. + eapply model_of_ext. 2:tea. apply mr. + - eapply (check_model_spec_diff mr) in eqm as [subwwconcl subwconcl hm hext] => //. + pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). + destruct hm as [cll [hind nvalid inwconcl hl]]. + eapply Nat.lt_le_trans. + 2:{ eapply measure_le; eapply mr. } + eapply measure_lt. + { eapply model_map_outside_weaken. eapply hext. lsets. } + { apply hext. } + eapply invalid_clause_measure in nvalid; tea. + exists (levelexpr_level (concl cll)). + split => //. + eapply clauses_conclusions_diff_left; tea. + eapply clauses_conclusions_spec. exists cll; split => //. exact hind. + - apply mr'. + (* - apply clauses_conclusions_clauses_with_concl. *) + - apply mr'. + - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. + eapply model_ext_trans_weaken. 2:apply mr. lsets. + transitivity mconcl. eapply model_extension_weaken. 2:tea. lsets. apply mr'. + - apply mr. + (* - eapply clauses_conclusions_clauses_with_concl. *) + - rewrite check_model_is_model in eqm. + 1:{ eapply model_of_diff, mr. } + have okm := (model_ok mr). + have mu := is_model_union okm eqm. + rewrite {1}eqprem in mu. + rewrite union_diff_eq in mu. + rewrite union_restrict_with_concl in mu. + now rewrite (clauses_conclusions_eq _ _ clsW). + - apply mr. + - split; lsets. + Qed. + End innerloop_partition. + + (* We first partition the clauses among those that mention only W and the ones that can mention other atoms. + We then call the loop on these two sets of clauses, which not need to change during the recursive calls. + *) + #[tactic="idtac"] + Equations? inner_loop (W : LevelSet.t) (cls : clauses) (m : model) + (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & model_of W m]) : + result W U cls m := + inner_loop W cls m prf with inspect (Clauses.partition (premise_restricted_to W) cls) := + | exist (premconclW, conclW) eqp => inner_loop_partition W cls premconclW conclW _ m _. + Proof. + - destruct prf as [subWV neW UW clsW mW]. + eapply (clauses_partition_spec clsW) in eqp as [eqprem eqconcl]. + split => //. now rewrite -(clauses_conclusions_eq _ _ clsW). + - apply prf. + Qed. + +End InnerLoop. + +Lemma diff_cardinal_inter V W : #|LevelSet.diff V W| = #|V| - #|LevelSet.inter V W|. +Proof. + pose proof (LevelSetProp.diff_inter_cardinal V W). lia. +Qed. + +Lemma diff_cardinal V W : W ⊂_lset V -> #|LevelSet.diff V W| = #|V| - #|W|. +Proof. + intros hsub. + rewrite diff_cardinal_inter LevelSetProp.inter_sym LevelSetProp.inter_subset_equal //. +Qed. + +Lemma is_modelP m cls : reflect (Clauses.For_all (valid_clause m) cls) (is_model cls m). +Proof. + case E: is_model; constructor. + - now move: E; rewrite /is_model -ClausesFact.for_all_iff. + - intros hf. apply ClausesFact.for_all_iff in hf; tc. unfold is_model in E; congruence. +Qed. + +Lemma is_model_invalid_clause cl cls m : is_model cls m -> ~~ valid_clause m cl -> ~ Clauses.In cl cls. +Proof. + move/is_modelP => ism /negP valid hin. + now specialize (ism _ hin). +Qed. + +Lemma strict_subset_leq_right U V W : + strict_subset U V -> V ⊂_lset W -> strict_subset U W. +Proof. + intros [] le. split. lsets. intros eq. rewrite -eq in le. + apply H0. lsets. +Qed. + +Lemma strict_subset_diff_incl V W W' : + strict_subset W' W -> + W ⊂_lset V -> + W' ⊂_lset V -> + strict_subset (LevelSet.diff V W) (LevelSet.diff V W'). +Proof. + intros [] lew lew'. + split. lsets. + intros eq. + apply H0. lsets. +Qed. + +(* To help equations *) +Opaque lexprod_rel_wf. + +Lemma check_model_spec_V {V cls w m w' m'} : + model_of V m -> clauses_conclusions cls ⊂_lset V -> + check_model cls (w, m) = Some (w', m') -> + check_model_invariants cls w m w' m' true. +Proof. + cbn; intros mof incl cm. + apply check_model_spec in cm => //. + eapply model_of_subset; tea. +Qed. + +Lemma valid_model_of {V W m cls} (m' : valid_model W m cls) : + model_of V m -> model_of V (model_model m'). +Proof. + intros mof. eapply model_of_ext; tea. eapply m'. +Qed. + +#[tactic="idtac"] +Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (m : model) + (prf : [/\ clauses_conclusions cls ⊂_lset V, U ⊂_lset V & model_of V m]) : result V U cls m + by wf (loop_measure V U) lexprod_rel := + loop V U cls m prf with inspect (check_model cls (U, m)) := + | exist None eqm => Model U {| model_model := m |} _ + | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { + | exist true eq := Loop + (* Loop on cls ↓ W, with |W| < |V| *) + | exist false neq with inner_loop V U loop W (cls ↓ W) m' _ := + { | Loop := Loop + | Model Wc mwc hsub' + (* We get a model for (cls ↓ W), we check if it extends to all clauses. + By invariant |Wc| cannot be larger than |W|. *) + with inspect (check_model cls (Wc, mwc.(model_model))) := + { | exist None eqm' => Model Wc {| model_model := mwc.(model_model) |} _ + | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { + | exist true _ := Loop + | exist false neq' with loop V Wcls cls mcls _ := { + (* Here Wcls < V, we've found a model for all of the clauses with conclusion + in W, which can now be fixed. We concentrate on the clauses whose + conclusion is different. Clearly |W| < |V|, but |Wcls| is not + necessarily < |V| *) + | Loop := Loop + | Model Wvw mcls' hsub'' := Model Wvw {| model_model := model_model mcls' |} _ } } } + } + } + . +Proof. + all:clear loop. + all:try solve [intuition auto]. + all:try eapply levelset_neq in neq. + all:have cls_sub := clauses_conclusions_levels cls. + all:destruct prf as [clsV UV mof]. + - apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. + split => //. split => //. lsets. + destruct hcl as [l [hl _]]. intros he. lsets. + apply clauses_conclusions_clauses_with_concl. + eapply model_of_ext; tea. eapply model_of_subset; tea. lsets. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply check_model_spec in eqm' as []. + 2:{ eapply model_of_subset. 2:exact clsV. + exact (valid_model_of mwc (model_of_ext mof ext)). } + split. lsets. lsets. + exact (model_of_ext (valid_model_of mwc (model_of_ext mof ext)) H2). + - right. + eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply check_model_spec in eqm' as []. + 2:{ eapply model_of_subset. 2:exact clsV. + exact (valid_model_of mwc (model_of_ext mof ext)). } + destruct hsub' as [UWc WcW]. + assert (Wcls ⊂_lset V). lsets. + rewrite -!diff_cardinal //. + eapply strict_subset_cardinal. + assert (strict_subset Wc Wcls). + { split => //. + destruct H1 as [cl [clcls nvalid hcll hv]]. + pose proof (model_ok mwc). + eapply is_model_invalid_clause in H1; tea. + assert (~ LevelSet.In (levelexpr_level (concl cl)) W). + { intros hin. rewrite in_clauses_with_concl in H1. intuition auto. } + move/(_ (levelexpr_level (concl cl))) => [] wcwcls wclswc. + now apply H4, WcW, wclswc. } + eapply (strict_subset_leq_right _ (LevelSet.diff V Wc)). + 2:{ clear -UWc WcW UW WU H3 H4. lsets. } + apply strict_subset_diff_incl => //. clear -H H3; lsets. + - eapply mcls'. + - auto. + - exact mcls'. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply check_model_spec in eqm' as []. + 2:{ eapply model_of_subset. 2:exact clsV. + exact (valid_model_of mwc (model_of_ext mof ext)). } + assert (WV : W ⊂_lset V). + { clear -UV clsV WU; lsets. } + eapply model_ext_trans_weaken => //. 2:tea. auto. + transitivity mcls; [|apply mcls']. + transitivity (model_model mwc). 2:{ eapply model_extension_weaken; [|tea]. lsets. } + eapply model_extension_weaken. 2:apply mwc. auto. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply check_model_spec in eqm' as []. + 2:{ eapply model_of_subset. 2:exact clsV. + exact (valid_model_of mwc (model_of_ext mof ext)). } + split. lsets. lsets. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + refine (valid_model_of mwc _). + refine (model_of_ext mof ext). + - auto. + - rewrite check_model_is_model // in eqm'. + eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + refine (valid_model_of mwc _). + eapply model_of_subset. + refine (model_of_ext mof ext). auto. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + transitivity m'. eapply model_extension_weaken; [|tea]. lsets. + eapply model_extension_weaken. 2:apply mwc. lsets. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + split; lsets. + - exact mof. + - exact clsV. + - apply check_model_is_model in eqm; eauto. + eapply model_of_subset; tea. + - reflexivity. + - split; lsets. +Qed. + +Transparent lexprod_rel_wf. + +Definition zero_model levels := + LevelSet.fold (fun l acc => LevelMap.add l 0 acc) levels (LevelMap.empty _). + +Definition add_max l k m := + match LevelMap.find l m with + | Some k' => + if k' LevelMap.add l k m + end. + +#[local] Instance proper_levelexprset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) + levels. +Proof. + intros s s' eq l. + rewrite !levelexprset_levels_spec. + firstorder eauto. +Qed. + +Lemma In_add_max l l' k acc : + LevelMap.In (elt:=nat) l (add_max l' k acc) <-> + (l = l' \/ LevelMap.In l acc). +Proof. + unfold add_max. + destruct LevelMap.find eqn:hl. + case: Nat.ltb_spec. + - rewrite LevelMapFact.F.add_in_iff /Level.eq. + firstorder eauto. + - intros. intuition auto. subst. + now rewrite LevelMapFact.F.in_find_iff hl. + - LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. +Qed. + +Lemma In_fold_add_max k n a : + LevelMap.In (elt:=nat) k + (LevelExprSet.fold + (fun '(l, k0) (acc : LevelMap.t nat) => add_max l k0 acc) n a) <-> + (LevelSet.In k (levels n)) \/ LevelMap.In k a. +Proof. + eapply LevelExprSetProp.fold_rec. + - intros s' he. + rewrite (LevelExprSetProp.empty_is_empty_1 he). + cbn. unfold levels. rewrite LevelExprSetProp.fold_empty. rewrite LevelSetFact.empty_iff. intuition auto. + - intros. + destruct x as [l k']. + rewrite In_add_max. + rewrite H2 !levelexprset_levels_spec. + split. + * intros []; subst. + left. exists k'. apply H1. now left. + destruct H3 as [[k'' ?]|?]. left; exists k''. apply H1. now right. + now right. + * red in H1. setoid_rewrite H1. + intros [[k'' []]|]. noconf H3. now left. + right. now left; exists k''. right; right. apply H3. +Qed. + + +(* To handle the constraint checking decision problem, + we must start with a model where all atoms [l + k] + appearing in premises are true. Otherwise the + [l := 0] model is minimal for [l+1-> l+2]. + Starting with [l := 1], we see that the minimal model above it + has [l := ∞]. + We also ensure that all levels in the conclusions are in the model. + + *) + +Definition min_model_map (m : LevelMap.t nat) cls : LevelMap.t nat := + Clauses.fold (fun '(cl, concl) acc => + LevelExprSet.fold (fun '(l, k) acc => + add_max l k acc) cl (add_max (levelexpr_level concl) 0 acc)) cls m. + +Lemma min_model_map_levels m cls k : + LevelMap.In k (min_model_map m cls) <-> + LevelSet.In k (clauses_levels cls) \/ LevelMap.In k m. +Proof. + rewrite /min_model_map. + rewrite clauses_levels_spec. + eapply ClausesProp.fold_rec. + - intros s' he. intuition auto. + destruct H0 as [cl []]. + clsets. + - intros x a s' s'' inx ninx hadd ih. + destruct x as [cl k']. + rewrite In_fold_add_max In_add_max. rewrite ih. + intuition auto. left. exists (cl, k'); intuition auto. + apply hadd. now left. + rewrite clause_levels_spec. now left. + subst. left. exists (cl, k'). split. apply hadd; now left. + rewrite clause_levels_spec. now right. + destruct H as [cl'' []]. left. exists cl''. + intuition auto. apply hadd. now right. + destruct H3 as [cl'' []]. + apply hadd in H0 as []; subst. + rewrite clause_levels_spec in H3. destruct H3; subst. + cbn in H0. now left. right. now left. + right. right. left; exists cl''. split => //. +Qed. + +Definition min_model m cls : model := min_model_map m cls. + +Definition init_model cls := min_model (LevelMap.empty _) cls. + +Lemma init_model_levels cls k : + LevelMap.In k (init_model cls) <-> LevelSet.In k (clauses_levels cls). +Proof. + rewrite min_model_map_levels. intuition auto. + now rewrite LevelMapFact.F.empty_in_iff in H0. +Qed. + +Definition init_w (levels : LevelSet.t) : LevelSet.t := LevelSet.empty. + +(* We don't need predecessor clauses as they are trivially satisfied *) +(* Definition add_predecessors (V : LevelSet.t) cls := + LevelSet.fold (fun l acc => + Clauses.add (NonEmptySetFacts.singleton (l, 1), (l, 0)) acc) V cls. *) + +Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). + +Equations? infer (cls : clauses) : infer_result (clauses_levels cls) cls := + infer cls := loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (And3 _ _ _). +Proof. + - now eapply clauses_conclusions_levels. + - lsets. + - now eapply init_model_levels. +Qed. + +Definition valuation_of_model (m : model) : LevelMap.t nat := + let max := LevelMap.fold (fun l k acc => Nat.max k acc) m 0 in + LevelMap.fold (fun l k acc => LevelMap.add l (max - k) acc) m (LevelMap.empty _). + +Definition print_result {V cls} (m : infer_result V cls) := + match m with + | Loop => "looping" + | Model w m _ => "satisfiable with model: " ^ print_level_nat_map m.(model_model) ^ nl ^ " W = " ^ + print_lset w + ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model m.(model_model)) + end. + +Definition valuation_of_result {V cls} (m : infer_result V cls) := + match m with + | Loop => "looping" + | Model w m _ => print_level_nat_map (valuation_of_model m.(model_model)) + end. + +Definition to_string_expr (e : LevelExpr.t) : string := + let '(l, n) := e in Level.to_string l ^ (if n is 0 then "" else "+" ^ string_of_nat n). + +Definition print_premise (l : nonEmptyLevelExprSet) : string := + let (e, exprs) := NonEmptySetFacts.to_nonempty_list l in + to_string_expr e ^ + match exprs with + | [] => "" + | l => ", " ^ print_list to_string_expr ", " exprs + end. + +Definition print_clauses (cls : clauses) := + let list := Clauses.elements cls in + print_list (fun '(l, r) => + print_premise l ^ " → " ^ to_string_expr r) nl list. + +Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) + (prf : clauses_conclusions cls ⊂_lset V /\ clauses_conclusions cls' ⊂_lset V /\ model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := + | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m _. +Proof. + split. 2:lsets. + intros x. rewrite clauses_conclusions_spec. + intros [cl [hcl hl]]. + rewrite Clauses.union_spec in hcl. destruct hcl. + - apply H, clauses_conclusions_spec. exists cl => //. + - apply H0, clauses_conclusions_spec. exists cl => //. + - exact H1. +Qed. + +(* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by + setting a minimal value for the new atoms in [clauses_levels cls \ V] + such that the new clauses [cls] do not hold vacuously. +*) +Equations? infer_extension {V init cls} (m : valid_model V init cls) (cls' : clauses) : + result (LevelSet.union (clauses_levels cls') V) LevelSet.empty (Clauses.union cls cls') (min_model m.(model_model) cls') := + infer_extension m cls' := + infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model m.(model_model) cls') cls cls' _. +Proof. + repeat split. + - pose proof (model_clauses_conclusions m). lsets. + - pose proof (clauses_conclusions_levels cls'). lsets. + - red. intros. + unfold min_model. rewrite min_model_map_levels. + pose proof (model_of_V m k). + apply LevelSet.union_spec in H as []; auto. +Qed. + +Definition enforce_clauses {V init cls} (m : valid_model V init cls) cls' : option model := + match infer_extension m cls' with + | Loop => None + | Model w m _ => Some m.(model_model) + end. + +Definition enforce_clause {V init cls} (m : valid_model V init cls) cl : option model := + enforce_clauses m (Clauses.singleton cl). + +Inductive constraint_type := UnivEq | UnivLe. + +Notation constraint := (nonEmptyLevelExprSet * constraint_type * nonEmptyLevelExprSet). + +Definition enforce_constraint (cstr : constraint) (cls : clauses) : clauses := + let '(l, d, r) := cstr in + match d with + | UnivLe => + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) l cls + | UnivEq => + let cls := + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) l cls + in + let cls' := + LevelExprSet.fold (fun rk acc => Clauses.add (l, rk) acc) r cls + in cls' + end. + +Definition clauses_of_list := ClausesProp.of_list. +Definition list_of_clauses := Clauses.elements. +Definition valuation := LevelMap.t nat. + +End LoopChecking. diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v new file mode 100644 index 000000000..41cc163fb --- /dev/null +++ b/template-rocq/theories/PartialLoopChecking.v @@ -0,0 +1,3280 @@ +(* Distributed under the terms of the MIT license. *) +From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils. + +From MetaRocq.Common Require Universes. +From Equations Require Import Equations. +Set Equations Transparent. + +(* TODO move *) +Arguments exist {A P}. +Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. + +Module FMapOrderedType_from_UsualOrderedType (O : UsualOrderedType). + Import O. + Definition t := O.t. + Definition eq : O.t -> O.t -> Prop := O.eq. + Definition lt : O.t -> O.t -> Prop := O.lt. + Definition eq_refl : forall x : O.t, eq x x := reflexivity. + Definition eq_sym : forall x y : O.t, eq x y -> eq y x := fun x y H => symmetry H. + + Lemma eq_trans : forall x y z, O.eq x y -> O.eq y z -> O.eq x z. + Proof. intros x y z. unfold O.eq. apply transitivity. Qed. + Lemma lt_trans : forall x y z, O.lt x y -> O.lt y z -> O.lt x z. + Proof. intros. eapply O.lt_strorder; tea. Qed. + + Lemma lt_not_eq : forall x y : O.t, lt x y -> ~ eq x y. + Proof. + intros x y H eq. do 2 red in eq. subst x. now eapply lt_strorder in H. + Qed. + + Definition compare : forall x y : O.t, Compare lt eq x y. + Proof. + intros. + case_eq (compare x y); intros. + apply EQ. abstract (destruct (compare_spec x y) => //). + apply LT. abstract (destruct (compare_spec x y) => //). + apply GT. abstract (destruct (compare_spec x y) => //). + Defined. + + Definition eq_dec : forall x y : O.t, {eq x y} + {~ eq x y} := eq_dec. +End FMapOrderedType_from_UsualOrderedType. + +Module Type LevelOrderedType. + Include UsualOrderedType. + + Parameter reflect_eq : ReflectEq t. + #[local] Existing Instance reflect_eq. + + Parameter to_string : t -> string. + +End LevelOrderedType. + +Module Type FMapOTInterface (E : UsualOrderedType). + Module OT := FMapOrderedType_from_UsualOrderedType E. + Include FMapInterface.Sfun OT. +End FMapOTInterface. + +Module Type LevelExprItf (Level : LevelOrderedType). + Include UsualOrderedType with Definition t := (Level.t * nat)%type. + Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. +End LevelExprItf. + +Module Type LevelExprSet_fun (Level : LevelOrderedType) (LevelExpr : LevelExprItf Level). + Include SWithLeibniz with Module E := LevelExpr. + + Record nonEmptyLevelExprSet + := { t_set :> t ; + t_ne : is_empty t_set = false }. + + (* Parameter map : (LevelExpr.t -> LevelExpr.t) -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet. *) + + (* Parameter map_spec : forall e f u, In e (map f u) <-> exists e0, In e0 u /\ e = (f e0). *) + +End LevelExprSet_fun. + +Module Type LoopCheckingItf (Level : LevelOrderedType) + (LevelSet : MSetInterface.SetsOn Level) + (LevelExpr : LevelExprItf Level) + (LevelExprSet : LevelExprSet_fun Level LevelExpr) + (LevelMap : FMapOTInterface Level). + + Definition model := LevelMap.t Z. + Definition valuation := LevelMap.t nat. + + Definition clause : Type := LevelExprSet.nonEmptyLevelExprSet × LevelExpr.t. + + Parameter clauses : Type. + Parameter clauses_of_list : list clause -> clauses. + Parameter list_of_clauses : clauses -> list clause. + + Inductive constraint_type := UnivEq | UnivLe. + Notation constraint := (LevelExprSet.nonEmptyLevelExprSet * constraint_type * LevelExprSet.nonEmptyLevelExprSet). + + Parameter enforce_constraint : forall (cstr : constraint) (cls : clauses), clauses. + + Parameter valid_model : forall (V : LevelSet.t) (m : model) (cls : clauses), Type. + + Parameter model_model : forall V m cls, valid_model V m cls -> model. + + (* { model_model : model; + model_of_V :> model_of V model_model; + model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; + model_ok :> is_model cls model_model; + model_extends : model_extension V m model_model; + }. *) + + Infix "⊂_lset" := LevelSet.Subset (at level 70). + + Parameter enforce_clauses : forall {V init cls} (m : valid_model V init cls) (cls' : clauses), option model. + + Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := + | Loop + | Model (w : LevelSet.t) (m : valid_model V m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). + + Parameter init_model : clauses -> model. + Parameter clauses_levels : clauses -> LevelSet.t. + + Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). + + Parameter infer : forall (cls : clauses), infer_result (clauses_levels cls) cls. + + Parameter print_result : forall {V cls}, infer_result V cls -> string. + + Parameter print_clauses : clauses -> string. + +End LoopCheckingItf. + +Module LoopChecking + (* Signature of levels: decidable, ordered type *) + (Level : LevelOrderedType) + (LevelSet : MSetInterface.SetsOn Level) + (LevelExpr : LevelExprItf Level) + (LevelExprSet : LevelExprSet_fun Level LevelExpr) + (LevelMap : FMapOTInterface Level) <: LoopCheckingItf Level LevelSet LevelExpr LevelExprSet LevelMap. + +Definition level (e : LevelExpr.t) : Level.t := fst e. +Definition levels (e : LevelExprSet.t) := + LevelExprSet.fold (fun le => LevelSet.add (level le)) e LevelSet.empty. + +Import LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). + +Local Existing Instance Level.reflect_eq. + +Module LevelSetFact := WFactsOn Level LevelSet. +Module LevelSetProp := WPropertiesOn Level LevelSet. +Module LevelSetDecide := LevelSetProp.Dec. +Module LevelMapFact := FMapFacts.WProperties_fun LevelMap.OT LevelMap. + +Ltac lsets := LevelSetDecide.fsetdec. +Notation "(=_lset)" := LevelSet.Equal (at level 0). +Infix "=_lset" := LevelSet.Equal (at level 30). +Infix "⊂_lset" := LevelSet.Subset (at level 70). +Infix "∪" := LevelSet.union (at level 70). + +Definition print_level_nat_map (m : LevelMap.t nat) := + let list := LevelMap.elements m in + print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_nat w) nl list. + +Definition print_lset (l : LevelSet.t) := + let list := LevelSet.elements l in + print_list Level.to_string " " list. + +Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. +Module LevelExprSetProp := WPropertiesOn LevelExpr LevelExprSet. + +(* We have decidable equality w.r.t leibniz equality for sets of levels. *) +#[global, program] Instance levelexprset_reflect : ReflectEq LevelExprSet.t := + { eqb := LevelExprSet.equal }. +Next Obligation. + destruct (LevelExprSet.equal x y) eqn:e; constructor. + eapply LevelExprSet.equal_spec in e. + now eapply LevelExprSet.eq_leibniz. + intros e'. + subst y. + pose proof (@LevelExprSetFact.equal_1 x x). + forward H. reflexivity. congruence. +Qed. + +#[global] Instance levelexprset_eq_dec : Classes.EqDec LevelExprSet.t := Classes.eq_dec. + +Derive NoConfusion for LevelExprSet.nonEmptyLevelExprSet. + +(* We use uip on the is_empty condition *) +#[global, program] Instance nonEmptyLevelExprSet_reflect : ReflectEq nonEmptyLevelExprSet := + { eqb x y := eqb x.(t_set) y.(t_set) }. +Next Obligation. + destruct (eqb_spec (t_set x) (t_set y)); constructor. + destruct x, y; cbn in *. subst. + now rewrite (uip t_ne0 t_ne1). + intros e; subst x; apply H. + reflexivity. +Qed. + +(** This coercion allows to see the non-empty set as a regular [LevelExprSet.t] *) +Coercion t_set : nonEmptyLevelExprSet >-> LevelExprSet.t. +Module LevelExprSetDecide := WDecide (LevelExprSet). +Ltac lesets := LevelExprSetDecide.fsetdec. +Infix "⊂_leset" := LevelExprSet.Subset (at level 70). + +Module NonEmptySetFacts. + #[program] Definition singleton (e : LevelExpr.t) : nonEmptyLevelExprSet + := {| t_set := LevelExprSet.singleton e |}. + Next Obligation. + apply negbTE. + eapply (contra_notN (P := LevelExprSet.Empty (LevelExprSet.singleton e))). + apply LevelExprSetFact.is_empty_2. intros ne. red in ne. specialize (ne e). lesets. + Qed. + + Lemma not_Empty_is_empty s : + ~ LevelExprSet.Empty s -> LevelExprSet.is_empty s = false. + Proof. + intro H. apply not_true_is_false. intro H'. + apply H. now apply LevelExprSetFact.is_empty_2 in H'. + Qed. + + Program Definition add (e : LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet + := {| t_set := LevelExprSet.add e u |}. + Next Obligation. + apply not_Empty_is_empty; intro H. + eapply H. eapply LevelExprSet.add_spec. + left; reflexivity. + Qed. + + Lemma add_spec e u e' : + LevelExprSet.In e' (add e u) <-> e' = e \/ LevelExprSet.In e' u. + Proof. + apply LevelExprSet.add_spec. + Qed. + + Definition add_list : list LevelExpr.t -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet + := List.fold_left (fun u e => add e u). + + Lemma add_list_spec l u e : + LevelExprSet.In e (add_list l u) <-> In e l \/ LevelExprSet.In e u. + Proof. + unfold add_list. rewrite <- fold_left_rev_right. + etransitivity. 2:{ eapply or_iff_compat_r. etransitivity. + 2: apply @InA_In_eq with (A:=LevelExpr.t). + eapply InA_rev. } + induction (List.rev l); cbn. + - split. intuition. intros [H|H]; tas. invs H. + - split. + + intro H. apply add_spec in H. destruct H as [H|H]. + * left. now constructor. + * apply IHl0 in H. destruct H as [H|H]; [left|now right]. + now constructor 2. + + intros [H|H]. inv H. + * apply add_spec; now left. + * apply add_spec; right. apply IHl0. now left. + * apply add_spec; right. apply IHl0. now right. + Qed. + + Lemma elements_not_empty {u : nonEmptyLevelExprSet} : LevelExprSet.elements u <> []. + Proof. + rewrite -LevelExprSetProp.elements_Empty. + move/LevelExprSetFact.is_empty_1. + destruct u as [u1 u2]; cbn in *. congruence. + Qed. + + Equations to_nonempty_list (u : nonEmptyLevelExprSet) : LevelExpr.t * list LevelExpr.t := + | u with inspect (LevelExprSet.elements u) := { + | exist [] eqel => False_rect _ (elements_not_empty eqel) + | exist (e :: l) _ => (e, l) }. + + Lemma singleton_to_nonempty_list e : to_nonempty_list (singleton e) = (e, []). + Proof. + funelim (to_nonempty_list (singleton e)). bang. + clear H. + pose proof (LevelExprSet.singleton_spec e1 e). + rewrite LevelExprSetFact.elements_iff in H. + rewrite InA_In_eq in H. rewrite e0 in H. + destruct H. forward H. now left. noconf H. f_equal. + pose proof (LevelExprSet.cardinal_spec (LevelExprSet.singleton e1)). rewrite e0 in H. cbn in H. + rewrite LevelExprSetProp.singleton_cardinal in H. + destruct l => //. + Qed. + + Lemma to_nonempty_list_spec u : + let '(e, u') := to_nonempty_list u in + e :: u' = LevelExprSet.elements u. + Proof. + funelim (to_nonempty_list u). bang. now rewrite e0. + Qed. + + Lemma to_nonempty_list_spec' u : + (to_nonempty_list u).1 :: (to_nonempty_list u).2 = LevelExprSet.elements u. + Proof. + pose proof (to_nonempty_list_spec u). + now destruct (to_nonempty_list u). + Qed. + + Lemma In_to_nonempty_list (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : + LevelExprSet.In e u + <-> e = (to_nonempty_list u).1 \/ In e (to_nonempty_list u).2. + Proof. + etransitivity. symmetry. apply LevelExprSet.elements_spec1. + pose proof (to_nonempty_list_spec' u) as H. + destruct (to_nonempty_list u) as [e' l]; cbn in *. + rewrite <- H; clear. etransitivity. apply InA_cons. + eapply or_iff_compat_l. apply InA_In_eq. + Qed. + + Lemma In_to_nonempty_list_rev (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : + LevelExprSet.In e u + <-> e = (to_nonempty_list u).1 \/ In e (List.rev (to_nonempty_list u).2). + Proof. + etransitivity. eapply In_to_nonempty_list. + apply or_iff_compat_l. apply in_rev. + Qed. + + Definition map (f : LevelExpr.t -> LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + let '(e, l) := to_nonempty_list u in + add_list (List.map f l) (singleton (f e)). + + Lemma map_spec f u e : + LevelExprSet.In e (map f u) <-> exists e0, LevelExprSet.In e0 u /\ e = (f e0). + Proof. + unfold map. symmetry. etransitivity. + { eapply iff_ex; intro. eapply and_iff_compat_r. eapply In_to_nonempty_list. } + destruct (to_nonempty_list u) as [e' l]; cbn in *. + symmetry. etransitivity. eapply add_list_spec. + etransitivity. eapply or_iff_compat_l. apply LevelExprSet.singleton_spec. + etransitivity. eapply or_iff_compat_r. + apply in_map_iff. clear u. split. + - intros [[e0 []]|H]. + + exists e0. split. right; tas. congruence. + + exists e'. split; tas. left; reflexivity. + - intros [xx [[H|H] ?]]. + + right. congruence. + + left. exists xx. split; tas; congruence. + Qed. + + Program Definition non_empty_union (u v : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + {| t_set := LevelExprSet.union u v |}. + Next Obligation. + apply not_Empty_is_empty; intro H. + assert (HH: LevelExprSet.Empty u). { + intros x Hx. apply (H x). + eapply LevelExprSet.union_spec. now left. } + apply LevelExprSetFact.is_empty_1 in HH. + rewrite t_ne in HH; discriminate. + Qed. + + + Lemma eq_univ (u v : nonEmptyLevelExprSet) : + u = v :> LevelExprSet.t -> u = v. + Proof. + destruct u as [u1 u2], v as [v1 v2]; cbn. intros X; destruct X. + now rewrite (uip_bool _ _ u2 v2). + Qed. + + Lemma eq_univ' (u v : nonEmptyLevelExprSet) : + LevelExprSet.Equal u v -> u = v. + Proof. + intro H. now apply eq_univ, LevelExprSet.eq_leibniz. + Qed. + + Lemma eq_univ'' (u v : nonEmptyLevelExprSet) : + LevelExprSet.elements u = LevelExprSet.elements v -> u = v. + Proof. + intro H. apply eq_univ. + destruct u as [u1 u2], v as [v1 v2]; cbn in *; clear u2 v2. + eapply LevelExprSet.eq_leibniz. red. + intros x. rewrite -!LevelExprSet.elements_spec1 H //. + Qed. + + Lemma univ_expr_eqb_true_iff (u v : nonEmptyLevelExprSet) : + LevelExprSet.equal u v <-> u = v. + Proof. + split. + - intros. + apply eq_univ'. now apply LevelExprSet.equal_spec. + - intros ->. now apply LevelExprSet.equal_spec. + Qed. + + Lemma univ_expr_eqb_comm (u v : nonEmptyLevelExprSet) : + LevelExprSet.equal u v <-> LevelExprSet.equal v u. + Proof. + transitivity (u = v). 2: transitivity (v = u). + - apply univ_expr_eqb_true_iff. + - split; apply eq_sym. + - split; apply univ_expr_eqb_true_iff. + Qed. + + + Lemma LevelExprSet_for_all_false f u : + LevelExprSet.for_all f u = false -> LevelExprSet.exists_ (negb ∘ f) u. + Proof. + intro H. rewrite LevelExprSetFact.exists_b. + rewrite LevelExprSetFact.for_all_b in H. + all: try now intros x y []. + induction (LevelExprSet.elements u); cbn in *; [discriminate|]. + apply andb_false_iff in H; apply orb_true_iff; destruct H as [H|H]. + left; now rewrite H. + right; now rewrite IHl. + Qed. + + Lemma LevelExprSet_For_all_exprs (P : LevelExpr.t -> Prop) (u : nonEmptyLevelExprSet) + : LevelExprSet.For_all P u + <-> P (to_nonempty_list u).1 /\ Forall P (to_nonempty_list u).2. + Proof. + etransitivity. + - eapply iff_forall; intro e. eapply imp_iff_compat_r. + apply In_to_nonempty_list. + - cbn; split. + + intro H. split. apply H. now left. + apply Forall_forall. intros x H0. apply H; now right. + + intros [H1 H2] e [He|He]. subst e; tas. + eapply Forall_forall in H2; tea. + Qed. + +End NonEmptySetFacts. +Import NonEmptySetFacts. + +Definition clause : Type := nonEmptyLevelExprSet × LevelExpr.t. + +Module Clause. + Definition t := clause. + + Definition eq : t -> t -> Prop := eq. + + Definition eq_equiv : RelationClasses.Equivalence eq := _. + + Inductive lt_ : t -> t -> Prop := + | lt_clause1 l e e' : LevelExpr.lt e e' -> lt_ (l, e) (l, e') + | lt_clause2 l l' b b' : LevelExprSet.lt l.(t_set) l'.(t_set) -> lt_ (l, b) (l', b'). + + Definition lt := lt_. + + Global Instance lt_strorder : RelationClasses.StrictOrder lt. + Proof. + constructor. + - intros x X; inversion X; subst. now eapply LevelExpr.lt_strorder in H1. + eapply LevelExprSet.lt_strorder; eassumption. + - intros x y z X1 X2; invs X1; invs X2; constructor; tea. + etransitivity; tea. + etransitivity; tea. + Qed. + + Definition lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt. + intros x x' H1 y y' H2. unfold lt. subst. reflexivity. + Qed. + + Definition compare (x y : t) : comparison := + match x, y with + | (l1, b1), (l2, b2) => + match LevelExprSet.compare l1.(t_set) l2.(t_set) with + | Eq => LevelExpr.compare b1 b2 + | x => x + end + end. + + Definition compare_spec : + forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y). + Proof. + intros [? ?] [? ?]; cbn; repeat constructor. + destruct (LevelExprSet.compare_spec n n0); repeat constructor; tas. + eapply LevelExprSet.eq_leibniz in H. apply NonEmptySetFacts.eq_univ in H. + subst. cbn in *. + destruct (LevelExpr.compare_spec t0 t1); repeat constructor; tas. now subst. + Qed. + + Global Instance reflect_t : ReflectEq t := reflect_prod _ _ . + + Definition eq_dec : forall (l1 l2 : t), {l1 = l2} + {l1 <> l2} := Classes.eq_dec. + + Definition eq_leibniz (x y : t) : eq x y -> x = y := id. +End Clause. + +Module Clauses := MSetAVL.Make Clause. +Module ClausesFact := WFactsOn Clause Clauses. +Module ClausesProp := WPropertiesOn Clause Clauses. +Module ClausesDecide := WDecide (Clauses). +Ltac clsets := ClausesDecide.fsetdec. + +Definition clauses := Clauses.t. + +Lemma filter_add {p x s} : Clauses.Equal (Clauses.filter p (Clauses.add x s)) (if p x then Clauses.add x (Clauses.filter p s) else Clauses.filter p s). +Proof. + intros i. + rewrite Clauses.filter_spec. + destruct (eqb_spec i x); subst; + destruct (p x) eqn:px; rewrite !Clauses.add_spec !Clauses.filter_spec; intuition auto || congruence. +Qed. + +Local Instance proper_fold_transpose {A} (f : Clauses.elt -> A -> A) : + transpose eq f -> + Proper (Clauses.Equal ==> eq ==> eq) (Clauses.fold f). +Proof. + intros hf s s' Hss' x ? <-. + eapply ClausesProp.fold_equal; tc; tea. +Qed. +Existing Class transpose. + +Lemma clauses_fold_filter {A} (f : Clauses.elt -> A -> A) (p : Clauses.elt -> bool) cls acc : + transpose Logic.eq f -> + Clauses.fold f (Clauses.filter p cls) acc = + Clauses.fold (fun elt acc => if p elt then f elt acc else acc) cls acc. +Proof. + intros hf. + symmetry. eapply ClausesProp.fold_rec_bis. + - intros s s' a eq. intros ->. + eapply ClausesProp.fold_equal; tc. auto. + intros x. + rewrite !Clauses.filter_spec. + now rewrite eq. + - now cbn. + - intros. + rewrite H1. + rewrite filter_add. + destruct (p x) eqn:px => //. + rewrite ClausesProp.fold_add //. + rewrite Clauses.filter_spec. intuition auto. +Qed. + +Definition levelexpr_level : LevelExpr.t -> Level.t := fst. +Coercion levelexpr_level : LevelExpr.t >-> Level.t. +Extraction Inline levelexpr_level. + +Definition strict_subset (s s' : LevelSet.t) := + LevelSet.Subset s s' /\ ~ LevelSet.Equal s s'. + +Lemma strict_subset_incl (x y z : LevelSet.t) : LevelSet.Subset x y -> strict_subset y z -> strict_subset x z. +Proof. + intros hs []. split => //. lsets. + intros heq. apply H0. lsets. +Qed. + +Lemma strict_subset_cardinal s s' : strict_subset s s' -> LevelSet.cardinal s < LevelSet.cardinal s'. +Proof. + intros []. + assert (LevelSet.cardinal s <> LevelSet.cardinal s'). + { intros heq. apply H0. + intros x. split; intros. now apply H. + destruct (LevelSet.mem x s) eqn:hin. + eapply LevelSet.mem_spec in hin. + auto. eapply LevelSetProp.FM.not_mem_iff in hin. + exfalso. + eapply LevelSetProp.subset_cardinal_lt in hin; tea. + lia. } + enough (LevelSet.cardinal s <= LevelSet.cardinal s') by lia. + now eapply LevelSetProp.subset_cardinal. +Qed. + +Definition premise (cl : clause) := fst cl. +Definition concl (cl : clause) := snd cl. +Extraction Inline premise concl. + +Definition clause_levels cl := + LevelSet.union (levels (premise cl)) (LevelSet.singleton (levelexpr_level (concl cl))). + +Definition clauses_levels (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls LevelSet.empty. + +Lemma Clauses_In_elements l s : + In l (Clauses.elements s) <-> Clauses.In l s. +Proof. + rewrite ClausesFact.elements_iff. + now rewrite InA_In_eq. +Qed. + +Lemma clauses_levels_spec_aux l cls acc : + LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls acc) <-> + (exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl)) \/ LevelSet.In l acc. +Proof. + eapply ClausesProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k [hin hl]]. clsets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.union_spec. + split. + * intros [hin'|]. + left. exists x. split => //. + apply hadd. now left. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. + * intros [[k [ins'' ?]]|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma clauses_levels_spec l cls : + LevelSet.In l (clauses_levels cls) <-> + exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl). +Proof. + unfold clauses_levels. + rewrite clauses_levels_spec_aux. + intuition auto. lsets. +Qed. + +Lemma clause_levels_spec l cl : + LevelSet.In l (clause_levels cl) <-> + LevelSet.In l (levels (premise cl)) \/ l = levelexpr_level (concl cl). +Proof. + unfold clause_levels. + now rewrite LevelSet.union_spec LevelSet.singleton_spec. +Qed. + +Definition model := LevelMap.t (option Z). + +Definition level_value (m : model) (level : Level.t) : option Z := + match LevelMap.find level m with + | None => None + | Some v => v + end. + +Definition levelexpr_value (m : model) (atom : LevelExpr.t) := + level_value m (levelexpr_level atom). + +Extraction Inline levelexpr_value. + +Definition min_atom_value (m : model) (atom : LevelExpr.t) := + let '(l, k) := atom in + match level_value m l with + | None => None + | Some val => Some (val - Z.of_nat k)%Z + end. + +Definition option_map2 {A} (f : A -> A -> A) (o o' : option A) : option A := + match o, o' with + | Some x, Some y => Some (f x y) + | None, Some _ + | Some _, None + | None, None => None + end. + +Definition min_premise (m : model) (l : nonEmptyLevelExprSet) : option Z := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (fun min atom => option_map2 Z.min (min_atom_value m atom) min) tl (min_atom_value m hd). + +Open Scope Z_scope. + +Definition satisfiable_atom (m : model) (atom : Level.t * nat) : bool := + let '(l, k) := atom in + match level_value m l with + | Some val => Z.of_nat k <=? val + | None => false + end. + +Definition satisfiable_premise (m : model) (l : nonEmptyLevelExprSet) := + LevelExprSet.for_all (satisfiable_atom m) l. + +(* Definition valid_clause (m : model) (cl : clause) := *) + (* implb (satisfiable_premise m (premise cl)) (satisfiable_atom m (concl cl)). *) +Definition level_value_above m l k := + match level_value m l with + | Some val => k <=? val + | None => false + end. + +Definition valid_clause (m : model) (cl : clause) := + let k0 := min_premise m (premise cl) in + match k0 with + | None => true + | Some k0 => + let (l, k) := concl cl in + level_value_above m l (Z.of_nat k + k0) + end. + +Definition is_model (cls : clauses) (m : model) : bool := + Clauses.for_all (valid_clause m) cls. + +Inductive update_result := + | VacuouslyTrue + | Holds + | DoesntHold (wm : LevelSet.t × model). + +Definition update_model (m : model) l v : model := LevelMap.add l (Some v) m. + +Definition update_value (wm : LevelSet.t × model) (cl : clause) : update_result := + let (w, m) := wm in + let k0 := min_premise m (premise cl) in + match k0 with + | None => VacuouslyTrue + | Some k0 => + let (l, k) := concl cl in + (* Does the conclusion also hold? + We optimize a bit here, rather than adding k0 in a second stage, + we do it already while checking the clause. In the paper, a second + pass computes this. + *) + if level_value_above m l (Z.of_nat k + k0) then Holds + else DoesntHold (LevelSet.add l w, update_model m l (Z.of_nat k + k0)) + end. + +Definition check_clause_model cl '(modified, wm) := + match update_value wm cl with + | VacuouslyTrue => (modified, wm) + | DoesntHold wm' => (true, wm') + | Holds => (modified, wm) + end. + +Definition check_model_aux (cls : clauses) (wm : LevelSet.t × model) : bool × (LevelSet.t × model) := + Clauses.fold check_clause_model cls (false, wm). + +(* If check_model = None then we have a model of all clauses, + othewise, we return Some (W', m') where W ⊂ W' and the model has + been updated for at least one atom l ∈ W'. *) +Definition check_model (cls : clauses) (wm : LevelSet.t × model) := + let '(modified, wm) := check_model_aux cls wm in + if modified then Some wm else None. + +Lemma check_model_aux_subset {cls w v} : + forall b w' v', check_model_aux cls (w, v) = (b, (w', v')) -> LevelSet.Subset w w'. +Proof. + intros w' v'. + unfold check_model, check_model_aux, check_clause_model. revert w' v'. + eapply ClausesProp.fold_rec => //. + { intros. noconf H0. reflexivity. } + intros x a s' s'' hin nin hadd IH. + intros b w' v'. destruct a. + destruct p as []. + unfold update_value. + destruct x as [prem [l k]]; cbn. + destruct min_premise as [k0|] eqn:hk0. + 2:apply IH. + destruct level_value_above. + - intros [= -> -> ->] => //. now eapply IH. + - intros [= <- <- <-]. intros x inx. + eapply LevelSet.add_spec. + specialize (IH _ _ _ eq_refl). + now right. +Qed. + +Lemma check_model_subset {cls w v} : + forall w' v', check_model cls (w, v) = Some (w', v') -> LevelSet.Subset w w'. +Proof. + intros w' v'. unfold check_model. + destruct check_model_aux eqn:cm. + destruct p as [W m]. + eapply check_model_aux_subset in cm. + destruct b => //. now intros [= <- <-]. +Qed. + +Definition premise_restricted_to W cl := + LevelSet.subset (levels (premise cl)) W. + +Definition clause_restricted_to W cl := + LevelSet.subset (levels (premise cl)) W && + LevelSet.mem (level (concl cl)) W. + +Definition restrict_clauses (cls : clauses) (W : LevelSet.t) := + Clauses.filter (clause_restricted_to W) cls. + +Lemma in_restrict_clauses (cls : clauses) (concls : LevelSet.t) cl : + Clauses.In cl (restrict_clauses cls concls) <-> + [/\ LevelSet.In (level (concl cl)) concls, + LevelSet.Subset (levels (premise cl)) concls & + Clauses.In cl cls]. +Proof. + unfold restrict_clauses. + rewrite Clauses.filter_spec. + destruct cl. cbn. + rewrite andb_true_iff LevelSet.subset_spec LevelSet.mem_spec. + firstorder auto. +Qed. + +Definition clauses_with_concl (cls : clauses) (concl : LevelSet.t) := + Clauses.filter (fun '(prem, concla) => LevelSet.mem (level concla) concl) cls. + +Lemma in_clauses_with_concl (cls : clauses) (concls : LevelSet.t) cl : + Clauses.In cl (clauses_with_concl cls concls) <-> + LevelSet.In (level (concl cl)) concls /\ Clauses.In cl cls. +Proof. + unfold clauses_with_concl. + rewrite Clauses.filter_spec. + destruct cl. rewrite LevelSet.mem_spec. cbn. firstorder eauto. +Qed. + +Definition clauses_conclusions (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.add (level (concl cl)) acc) cls LevelSet.empty. + +Lemma clauses_conclusions_spec a cls : + LevelSet.In a (clauses_conclusions cls) <-> + exists cl, Clauses.In cl cls /\ level (concl cl) = a. +Proof. + unfold clauses_conclusions. + eapply ClausesProp.fold_rec; clear. + - move=> s' he /=. rewrite LevelSetFact.empty_iff. + firstorder auto. + - move=> cl ls cls' cls'' hin hnin hadd ih. + rewrite LevelSet.add_spec. firstorder eauto. + specialize (H0 x). cbn in H0. + apply hadd in H1. firstorder eauto. + subst. left. now destruct x. +Qed. + +Lemma clauses_conclusions_clauses_with_concl cls concl : + LevelSet.Subset (clauses_conclusions (clauses_with_concl cls concl)) concl. +Proof. + intros x [cl []] % clauses_conclusions_spec. + eapply in_clauses_with_concl in H as []. + now rewrite H0 in H. +Qed. + +Lemma clauses_conclusions_restrict_clauses cls W : + LevelSet.Subset (clauses_conclusions (restrict_clauses cls W)) W. +Proof. + intros x [cl []] % clauses_conclusions_spec. + eapply in_restrict_clauses in H as []. + now rewrite H0 in H. +Qed. + +Definition in_clauses_conclusions (cls : clauses) (x : Level.t): Prop := + exists cl, Clauses.In cl cls /\ (level cl.2) = x. + +Definition v_minus_w_bound (W : LevelSet.t) (m : model) := + LevelMap.fold (fun w v acc => Z.max (option_get 0%Z v) acc) + (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0%Z. + +Definition levelexpr_k : LevelExpr.t -> nat := snd. +Coercion levelexpr_k : LevelExpr.t >-> nat. + +Definition level_expr_elt : LevelExprSet.elt -> LevelExpr.t := fun x => x. +Coercion level_expr_elt : LevelExprSet.elt >-> LevelExpr.t. + +Definition premise_min (l : nonEmptyLevelExprSet) : nat := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (B:=LevelExpr.t) (fun min atom => Nat.min atom min) tl hd. + +Definition gain (cl : clause) : Z := + Z.of_nat (levelexpr_k (concl cl)) - Z.of_nat (premise_min (premise cl)). + +Definition max_gain (cls : clauses) := + Clauses.fold (fun cl acc => Nat.max (Z.to_nat (gain cl)) acc) cls 0%nat. + +Definition model_same_domain (m m' : model) := + forall l, LevelMap.In l m <-> LevelMap.In l m'. + +#[local] Instance model_same_domain_refl : Reflexive model_same_domain. +Proof. intros m l. reflexivity. Qed. + +#[local] Instance model_same_domain_trans : Transitive model_same_domain. +Proof. intros m m' m'' h h' l. rewrite (h l). apply h'. Qed. + + +Inductive opt_le {A} (le : relation A) : relation (option A) := +| opt_le_some x y : le x y -> opt_le le (Some x) (Some y) +| opt_le_none_some x : opt_le le None x. +Derive Signature for opt_le. + +Instance opt_le_refl {A} (le : relation A) : Reflexive le -> Reflexive (opt_le le). +Proof. + intros hre x; induction x; constructor; reflexivity. +Qed. + +Instance opt_le_trans {A} (le : relation A) : Transitive le -> Transitive (opt_le le). +Proof. + intros hre x; induction x; destruct y as [y|]; intros z H H'; depelim H; depelim H'; constructor. + now transitivity y. +Qed. + +Definition value_le : relation (option Z) := opt_le Z.le. + +Infix "≤" := value_le (at level 50). + +Definition model_le (m m' : model) := + forall l k, LevelMap.MapsTo l k m -> + exists k', LevelMap.MapsTo l k' m' /\ k ≤ k'. + +Infix "⩽" := model_le (at level 70). (* \leqslant *) + +Definition model_map_outside V (m m' : model) := + forall l, ~ LevelSet.In l V -> + forall k, LevelMap.MapsTo l k m <-> LevelMap.MapsTo l k m'. + +#[local] Instance model_map_outside_refl V : Reflexive (model_map_outside V). +Proof. intros m l. reflexivity. Qed. + +#[local] Instance model_map_outside_trans V : Transitive (model_map_outside V). +Proof. + intros m m' m'' h h' l hnin k. + rewrite (h l hnin k). now apply h'. +Qed. + +(** The termination proof relies on the correctness of check_model: + it does strictly increase a value but not above [max_gain cls]. +*) + +Lemma clauses_conclusions_diff cls s : + clauses_conclusions (Clauses.diff cls (clauses_with_concl cls s)) ⊂_lset + LevelSet.diff (clauses_conclusions cls) s. +Proof. + intros a. rewrite LevelSet.diff_spec !clauses_conclusions_spec. + firstorder eauto. + exists x; split => //. + now rewrite Clauses.diff_spec in H. + intros ha. + rewrite Clauses.diff_spec in H; destruct H as []. + apply H1. + rewrite in_clauses_with_concl. split => //. + now rewrite H0. +Qed. + +Lemma diff_eq U V : LevelSet.diff V U =_lset V <-> LevelSet.inter V U =_lset LevelSet.empty. +Proof. split. lsets. lsets. Qed. + +Lemma levelset_neq U V : LevelSet.equal U V = false -> ~ LevelSet.Equal U V. +Proof. intros eq heq % LevelSet.equal_spec. congruence. Qed. + +Lemma levelset_union_same U : LevelSet.union U U =_lset U. +Proof. lsets. Qed. + +Class Commutative {A} (f : A -> A -> A) := comm : forall x y, f x y = f y x. +Instance option_map_2_comm {A} f : @Commutative A f -> @Commutative (option A) (option_map2 f). +Proof. + intros com [x|] [y|] => //=. now rewrite comm. +Qed. + +Instance Zmin_comm : Commutative Z.min := Z.min_comm. +Instance Zmax_comm : Commutative Z.max := Z.max_comm. + +Class Associative {A} (f : A -> A -> A) := assoc : forall x y z, f x (f y z) = f (f x y) z. +Instance option_map_2_assoc {A} f : @Associative A f -> @Associative (option A) (option_map2 f). +Proof. + intros assoc [x|] [y|] [z|]; cbn => //. now rewrite assoc. +Qed. + +Instance Zmin_assoc : Associative Z.min := Z.min_assoc. +Instance Zmax_assoc : Associative Z.max := Z.max_assoc. + +Lemma fold_left_comm {A B} (f : B -> A -> B) (l : list A) (x : A) (acc : B) : + (forall x y z, f (f z x) y = f (f z y) x) -> + fold_left f l (f acc x) = f (fold_left f l acc) x. +Proof. + intros. + induction l in acc, x |- *; cbn. auto. + rewrite -IHl. f_equal. now rewrite H. +Qed. + +Lemma fold_left_min_opt_comm {A} (f : A -> A -> A) l x acc : + Associative f -> Commutative f -> + fold_left (option_map2 f) l (option_map2 f acc x) = option_map2 f (fold_left (option_map2 f) l acc) x. +Proof. + intros ass c. rewrite fold_left_comm => //. + intros. rewrite -(assoc (f := option_map2 f)). + rewrite -(assoc (f := option_map2 f) z y x0). + f_equal. apply comm. +Qed. + +Lemma fold_left_le {A} {le} (f g : A -> LevelSet.elt -> A) l : + (forall acc acc' x, In x l -> le acc acc' -> le (f acc x) (g acc' x)) -> + forall acc acc', le acc acc' -> + le (fold_left f l acc) (fold_left g l acc'). +Proof. + intros hfg. + induction l => //. cbn. intros. + apply IHl. intros. apply hfg => //. now right. apply hfg => //. now left. +Qed. + +Local Open Scope nat_scope. +Lemma fold_left_ne_lt (f g : nat -> LevelSet.elt -> nat) l acc : + (forall (x y : LevelSet.elt) z, f (f z x) y = f (f z y) x) -> + (forall (x y : LevelSet.elt) z, g (g z x) y = g (g z y) x) -> + l <> [] -> + (forall acc acc' x, In x l -> (acc <= acc') -> (f acc x <= g acc' x)) -> + (forall acc acc' x, In x l -> (acc < acc') -> (f acc x < g acc' x)) -> + (exists x, In x l /\ forall acc acc', (acc <= acc') -> (f acc x < g acc' x)) -> + fold_left f l acc < fold_left g l acc. +Proof. + intros hf hg. + generalize (Nat.le_refl acc). + generalize acc at 2 4. + induction l in acc |- * => //. + intros. + destruct l; cbn. + { destruct H3 as [x []]. cbn in H3. destruct H3; subst => //. + now eapply (H4 acc acc0). } + cbn in IHl. + rewrite hf hg. + rewrite fold_left_comm //. rewrite (fold_left_comm g) //. + destruct H3 as [min [hmin hfg]]. + destruct hmin as [<-|hel]. + - apply hfg. apply fold_left_le => //. intros; eapply H1 => //. now right; right. + apply H1 => //. now right; left. + - apply H2. now left. eapply IHl => //. + * intros acc1 acc' x hin. apply (H1 acc1 acc' x). now right. + * intros acc1 acc' x hin. apply (H2 acc1 acc' x). now right. + * exists min. split => //. +Qed. +Close Scope nat_scope. + +Infix "↓" := clauses_with_concl (at level 70). (* \downarrow *) +Infix "⇂" := restrict_clauses (at level 70). (* \downharpoonright *) + +Lemma clauses_conclusions_diff_left cls W cls' : + clauses_conclusions (Clauses.diff (cls ↓ W) cls') ⊂_lset W. +Proof. + intros l. + rewrite clauses_conclusions_spec. + move=> [] cl. rewrite Clauses.diff_spec => [] [] []. + move/in_clauses_with_concl => [] hin ? ? eq. + now rewrite eq in hin. +Qed. + +Lemma clauses_conclusions_diff_restrict cls W cls' : + clauses_conclusions (Clauses.diff (cls ⇂ W) cls') ⊂_lset W. +Proof. + intros l. + rewrite clauses_conclusions_spec. + move=> [] cl. rewrite Clauses.diff_spec => [] [] []. + move/in_restrict_clauses => [] hin ? ? ? eq. + now rewrite eq in hin. +Qed. + +Lemma LevelSet_In_elements l s : + In l (LevelSet.elements s) <-> LevelSet.In l s. +Proof. + rewrite LevelSetFact.elements_iff. + now rewrite InA_In_eq. +Qed. + +Lemma clauses_empty_eq {s} : Clauses.Empty s -> Clauses.Equal s Clauses.empty. +Proof. clsets. Qed. + +Lemma update_value_valid {W m cl} : + match update_value (W, m) cl with + | VacuouslyTrue | Holds => valid_clause m cl + | DoesntHold _ => ~~ valid_clause m cl + end. +Proof. + unfold update_value, valid_clause. + destruct cl as [prem [l k]]; cbn. + destruct min_premise => //. + unfold level_value_above. + destruct level_value => //. + destruct Z.leb => //. +Qed. + +Lemma valid_update_value {W m cl} : + valid_clause m cl -> + match update_value (W, m) cl with + | VacuouslyTrue | Holds => true + | DoesntHold _ => false + end. +Proof. + unfold update_value, valid_clause. + destruct cl as [prem [l k]]; cbn. + destruct min_premise => //. + unfold level_value_above. + destruct level_value => //. + destruct Z.leb => //. +Qed. + +Lemma check_model_aux_false {cls acc acc'} : check_model_aux cls acc = (false, acc') -> acc = acc'. +Proof. + unfold check_model_aux, check_clause_model. + eapply ClausesProp.fold_rec. + - intros s emp [=] => //. + - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. + intros IH. + destruct update_value eqn:upd => //. +Qed. + +(* Lemma check_model_aux_true {cls acc acc'} : check_model_aux cls acc = (true, acc') -> acc = acc'. +Proof. + unfold check_model_aux. + eapply ClausesProp.fold_rec. + - intros s emp [=] => //. + - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. + intros IH. + destruct update_value eqn:upd => //. +Qed. *) + +Lemma check_model_aux_model {cls acc} : + check_model_aux cls acc = (false, acc) <-> is_model cls acc.2. +Proof. + unfold check_model_aux, check_clause_model. + unfold is_model. + unfold is_true; rewrite -ClausesFact.for_all_iff. + eapply ClausesProp.fold_rec. + - intros s emp. + split => //. + intros [=] x hx. clsets. + - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. + intros IH. + split. + * move: (@update_value_valid w' m' cl). + destruct update_value eqn:upd => //; intros vcl [= -> <-] ; + destruct IH as [IH _]; specialize (IH eq_refl). + intros x hx; apply incls'' in hx as []; subst. exact vcl. now apply IH. + intros x hx; apply incls'' in hx as []; subst. exact vcl. now apply IH. + * intros hf. + assert (valid_clause acc.2 cl). + { apply hf. apply incls''. intuition auto. } + destruct IH as [_ IH]. forward IH. + { intros x hx. apply hf. apply incls''. now right. } + noconf IH. + move: (@valid_update_value w' m' cl H). + destruct update_value eqn:upd => //. +Qed. + +Lemma clauses_for_all_neg {p s}: + ~~ Clauses.for_all p s <-> ~ Clauses.For_all p s. +Proof. + intuition auto. + rewrite ClausesFact.for_all_iff in H0. red in H. now rewrite H0 in H. + revert H. apply contra_notN. + rewrite ClausesFact.for_all_iff //. +Qed. + +Lemma clauses_for_all_exists {p s}: + ~~ Clauses.for_all p s <-> Clauses.exists_ (fun x => ~~ p x) s. +Proof. + rewrite ClausesFact.for_all_b ClausesFact.exists_b. + induction (Clauses.elements s). + - cbn; auto. reflexivity. + - cbn. rewrite negb_and. intuition auto. + move/orP: H1 => [->|] //. move/H. intros ->. now rewrite orb_true_r. + move/orP: H1 => [->|] //. move/H0. intros ->. now rewrite orb_true_r. +Qed. +#[local] Instance model_le_refl : Reflexive model_le. +Proof. intros x l k map. exists k; split => //. reflexivity. Qed. + +#[local] Instance model_le_trans : Transitive model_le. +Proof. intros m m' m'' mm' m'm'' l k map. + apply mm' in map as [k' [map ?]]. + apply m'm'' in map as [k'' [map ?]]. exists k''. split => //. + now transitivity k'. +Qed. + +Lemma update_model_monotone m l k : level_value m l ≤ Some k -> m ⩽ update_model m l k. +Proof. + intros hl. + intros l' k' maps. + unfold update_model. cbn. + destruct (eqb_spec l l'). + - subst l'. exists (Some k). move: hl. + unfold level_value. + rewrite (LevelMap.find_1 maps). + intros hle. + split => //. eapply LevelMap.add_1. eapply LevelMap.OT.eq_refl. + - exists k'. split => //. apply LevelMap.add_2 => //. reflexivity. +Qed. + +Lemma update_model_not_above m l k : level_value_above m l k = false -> m ⩽ update_model m l k. +Proof. + unfold level_value_above. + intros hlev. + apply update_model_monotone. + destruct level_value as [v|] eqn:hv; constructor; lia. +Qed. + +Lemma check_clause_model_inv {cl modified w m b wm'} : + check_clause_model cl (modified, (w, m)) = (b, wm') -> + m ⩽ wm'.2. +Proof. + unfold check_clause_model. + destruct (update_value (w, m) cl) eqn:upd. + * now intros [= <- <-]. + * now intros [= <- <-]. + * intros [= <- <-]. + move: upd. + unfold update_value. + destruct cl as [prem [l k]] => /=. + destruct min_premise as [k0|] eqn:hmin => //. + destruct level_value_above eqn:hval => //. + intros [= <-]. cbn. + now eapply update_model_not_above. +Qed. + +Lemma check_clause_model_intact {cl modified w m wm'} : + check_clause_model cl (modified, (w, m)) = (false, wm') -> valid_clause m cl /\ wm' = (w, m). +Proof. + unfold check_clause_model. + move: (@update_value_valid w m cl). + destruct (update_value (w, m) cl) eqn:upd. + * intros valid [= -> <-]. split => //. + * intros valid [= -> <-]. split => //. + * intros _ [=]. +Qed. + +Lemma check_clause_model_modify {cl w m wm'} : + check_clause_model cl (false, (w, m)) = (true, wm') -> ~~ valid_clause m cl. +Proof. + unfold check_clause_model. + destruct (update_value (w, m) cl) eqn:upd. + * now intros [= <- <-]. + * now intros [= <- <-]. + * intros [= <-]. + move: upd. + unfold update_value, valid_clause. + destruct min_premise as [k0|] eqn:hmin => //. + destruct cl as [prem [l k]] => /=. + unfold level_value_above. + destruct level_value as [val|] eqn:hval => //. + case: Z.leb_spec => //. +Qed. + +Lemma check_model_aux_model_le {cls acc acc' b} : + check_model_aux cls acc = (b, acc') -> acc.2 ⩽ acc'.2. +Proof. + unfold check_model_aux. + revert b acc'. + eapply ClausesProp.fold_rec. + - intros s emp b acc'. intros [=]. subst. reflexivity. + - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. + intros IH b acc'. + move/check_clause_model_inv. + specialize (IH _ _ eq_refl). cbn in IH. now intros; transitivity m'. +Qed. + +Lemma level_value_update_model m l k : + level_value (update_model m l k) l = Some k. +Proof. + unfold level_value, update_model. + cbn -[LevelMap.find LevelMap.add]. + rewrite LevelMapFact.F.add_o. + destruct LevelMap.OT.eq_dec => //. + exfalso. now apply n. +Qed. + + +Lemma model_map_outside_weaken {W W'} {m m' : model} : + model_map_outside W m m' -> + W ⊂_lset W' -> + model_map_outside W' m m'. +Proof. + intros hm sub x hin k. + apply hm. intros hin'. apply sub in hin'. now apply hin. +Qed. + +Lemma is_model_union {cls cls' m} : + is_model cls m -> is_model cls' m -> is_model (Clauses.union cls cls') m. +Proof. + rewrite /is_model. rewrite /is_true -!ClausesFact.for_all_iff. + now move=> ism ism' x /Clauses.union_spec []. +Qed. + +#[local] Instance Clauses_For_All_proper : Proper (eq ==> Clauses.Equal ==> iff) Clauses.For_all. +Proof. + intros x y -> cl cl' eqcl. + unfold Clauses.For_all. now setoid_rewrite eqcl. +Qed. + +#[local] Instance Clauses_for_all_proper : Proper (eq ==> Clauses.Equal ==> eq) Clauses.for_all. +Proof. + intros x y -> cl cl' eqcl. + apply iff_is_true_eq_bool. + rewrite /is_true -!ClausesFact.for_all_iff. now rewrite eqcl. +Qed. + +#[local] Instance is_model_proper : Proper (Clauses.Equal ==> eq ==> eq) is_model. +Proof. + intros cl cl' eqcl x y ->. unfold is_model. now rewrite eqcl. +Qed. + +Lemma model_le_values {m m' : model} x : m ⩽ m' -> level_value m x ≤ level_value m' x. +Proof. + intros lem. specialize (lem x). + unfold level_value. + destruct LevelMap.find eqn:hl => //. + - apply LevelMap.find_2 in hl. specialize (lem _ hl) as [k' [mapsto leq]]. + now rewrite (LevelMap.find_1 mapsto). + - constructor. +Qed. + +Lemma level_value_MapsTo {l k} {m : model} : + LevelMap.MapsTo l k m -> level_value m l = k. +Proof. + unfold level_value. + move=> mapto; rewrite (LevelMap.find_1 mapto) //. +Qed. + +Infix "⊂_clset" := Clauses.Subset (at level 70). + +Lemma max_gain_in cl cls : + Clauses.In cl cls -> + (Z.to_nat (gain cl) <= max_gain cls)%nat. +Proof. + intros hin. + unfold max_gain. revert cl hin. + eapply ClausesProp.fold_rec. + - intros s' ise hin. firstorder eauto. + - intros x a s' s'' xs nxs' hadd IH cl' hin'. + eapply hadd in hin' as []. + * subst x. lia. + * specialize (IH _ H). lia. +Qed. + +Definition max_gain_subset (cls cls' : Clauses.t) : + cls ⊂_clset cls' -> + (max_gain cls <= max_gain cls')%nat. +Proof. + unfold max_gain at 1. + revert cls'. + eapply ClausesProp.fold_rec. + - intros s' ise sub. lia. + - intros x a s' s'' xs nxs' hadd IH cls'' hs. + specialize (IH cls''). forward IH. transitivity s'' => //. + intros ??. now apply hadd. + assert (incls'' : Clauses.In x cls''). + { now apply hs, hadd. } + apply max_gain_in in incls''. lia. +Qed. + +Notation cls_diff cls W := (Clauses.diff (cls ↓ W) (cls ⇂ W)) (only parsing). + +(* + Equations? extend_model {W cls} (m : valid_model W (cls ⇂ W)) + (r : result W (Clauses.diff (cls ↓ W) (cls ⇂ W))) + : result W (cls ↓ W) := + extend_model _ Loop := Loop; + extend_model m (Model w m' sub) := + Model w {| model_model := m'.(model_model) |} _. + Proof. + - apply LevelSet.subset_spec in sub. now apply clauses_conclusions_clauses_with_concl in H. + - eapply sub. now eapply m.(model_clauses_conclusions). + - apply m. + - eapply LevelSet.subset_spec. eapply LevelSet.subset_spec in sub. + now transitivity V. + Qed. + + *) + +Lemma not_mem l s : ~~ LevelSet.mem l s <-> ~ LevelSet.In l s. +Proof. + split. apply contraNnot. apply LevelSet.mem_spec. + eapply contra_notN; tea. now move/LevelSet.mem_spec. +Qed. + +Lemma v_minus_w_bound_irrel {W} m m' : + model_map_outside W m m' -> + v_minus_w_bound W m = v_minus_w_bound W m'. +Proof. + unfold v_minus_w_bound. + intros out. eapply LevelMapFact.fold_Equal. tc. cbn. + { intros x y eq. cbn. solve_proper. } + { intros x y. cbn. intros e e' a neq. lia. } + apply LevelMapFact.F.Equal_mapsto_iff. + intros k e. rewrite -> LevelMapFact.filter_iff. + 2:{ intros x y eq. red in eq. subst; solve_proper. } + rewrite -> LevelMapFact.filter_iff. + 2:{ move=> x y ->. solve_proper. } + rewrite [_ = true]not_mem. intuition auto. + - now apply out. + - now apply out. +Qed. + +Definition max_premise_value (m : model) (l : nonEmptyLevelExprSet) : option Z := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (fun min atom => option_map2 Z.max (levelexpr_value m atom) min) tl (levelexpr_value m hd). + +Definition non_W_atoms W (l : LevelExprSet.t) := + LevelExprSet.filter (fun lk => ~~ LevelSet.mem lk.1 W) l. + +Lemma non_W_atoms_spec W l : forall x, LevelExprSet.In x (non_W_atoms W l) <-> LevelExprSet.In x l /\ ~ LevelSet.In x.1 W. +Proof. + intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec -not_mem. +Qed. + +Lemma non_W_atoms_subset W l : non_W_atoms W l ⊂_leset l. +Proof. intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec. Qed. + +Lemma levelexprset_levels_spec_aux l (e : LevelExprSet.t) acc : + LevelSet.In l (LevelExprSet.fold (fun le : LevelExprSet.elt => LevelSet.add (level le)) e acc) <-> + (exists k, LevelExprSet.In (l, k) e) \/ LevelSet.In l acc. +Proof. + eapply LevelExprSetProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k hin]. lesets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.add_spec. + split. + * intros [->|]. + left. exists (levelexpr_k x). + apply hadd. cbn. left. now destruct x. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. apply hadd. now right. + * intros [[k ins'']|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma levelexprset_levels_spec l (e : LevelExprSet.t) : + LevelSet.In l (levels e) <-> exists k, LevelExprSet.In (l, k) e. +Proof. + rewrite levelexprset_levels_spec_aux. intuition auto. lsets. +Qed. + +Lemma levels_exprs_non_W_atoms {W prem} : + LevelSet.Equal (levels (non_W_atoms W prem)) (LevelSet.diff (levels prem) W). +Proof. + intros e. unfold non_W_atoms. + rewrite levelexprset_levels_spec LevelSet.diff_spec levelexprset_levels_spec. + firstorder eauto. + rewrite LevelExprSet.filter_spec in H. now exists x. + rewrite LevelExprSet.filter_spec in H. destruct H. + rewrite LevelSetFact.not_mem_iff. + destruct LevelSet.mem => //. + exists x. + rewrite LevelExprSet.filter_spec. split => //. + rewrite LevelSetFact.not_mem_iff in H0. now rewrite H0. +Qed. + +Lemma levelexprset_empty_levels x : LevelExprSet.Empty x <-> LevelSet.Empty (levels x). +Proof. + split. + - intros he. + intros l hin. + eapply levelexprset_levels_spec in hin as [k hin]. lesets. + - intros emp l hin. eapply emp. eapply (levelexprset_levels_spec l.1). exists l.2. + now destruct l. +Qed. + +Lemma non_W_atoms_ne W cl cls : + Clauses.In cl (cls_diff cls W) -> + LevelExprSet.is_empty (non_W_atoms W (premise cl)) = false. +Proof. + intros x. + apply Clauses.diff_spec in x as [clw clr]. + eapply in_clauses_with_concl in clw as [clw incls]. + apply/negbTE. + apply/(contra_notN _ clr). + intros he. rewrite in_restrict_clauses. split => //. + epose proof (@levels_exprs_non_W_atoms W (premise cl)). + eapply LevelExprSetFact.is_empty_2 in he. + intros x hin. eapply levelexprset_empty_levels in he. rewrite H in he. + specialize (he x). rewrite LevelSet.diff_spec in he. intuition auto. + rewrite -LevelSet.mem_spec in H1 |- *. destruct LevelSet.mem; intuition auto. +Qed. + +Local Open Scope Z_scope. + +Section MoreNonEmpty. + + Import LevelExprSet. + Import NonEmptySetFacts. + + Lemma In_elements {x} {s : nonEmptyLevelExprSet} : In x s <-> List.In x (elements s). + Proof. + split. now move/LevelExprSetFact.elements_1/InA_In_eq. + now move/InA_In_eq/LevelExprSetFact.elements_2. + Qed. + + Notation min_opt := (option_map2 Z.min). + Lemma Zmin_opt_left x y : min_opt x y ≤ x. + Proof. + destruct x as [x|], y as [y|]; constructor. lia. + Qed. + + Lemma Zmin_opt_right x y : min_opt x y ≤ y. + Proof. + destruct x as [x|], y as [y|]; constructor. lia. + Qed. + + Lemma min_opt_spec x y z : min_opt x y = z -> (z = y \/ z = x). + Proof. + destruct x as [x|], y as [y|], z as [z|]; cbn; intuition auto. + - noconf H. pose proof (Zmin_irreducible x y). destruct H; intuition (f_equal; auto). + - noconf H. + Qed. + + Lemma min_premise_spec_aux (m : model) s k : + min_premise m s = k -> + (forall x, LevelExprSet.In x s -> (k ≤ min_atom_value m x)%Z) /\ + (exists x, LevelExprSet.In x s /\ k = min_atom_value m x). + Proof. + unfold min_premise. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. reflexivity. + now exists t0; split => //. + - destruct IHl as [ha hex]. + split. + * intros x hin. + eapply (in_elt_inv x a [t0]) in hin as [<-|inih]. + { cbn. rewrite fold_left_comm. + { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } + apply Zmin_opt_left. } + specialize (ha _ inih). + cbn. rewrite fold_left_comm. + { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } + etransitivity; [apply Zmin_opt_right|assumption]. + * destruct hex as [minval [inmin ih]]. + cbn. rewrite fold_left_comm. + { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } + rewrite ih. + destruct (min_opt_spec (min_atom_value m a) (min_atom_value m minval) _ eq_refl). + { rewrite H. exists minval. cbn in inmin. split; [intuition|reflexivity]. } + { rewrite H. exists a. cbn in inmin. split; [intuition|reflexivity]. } + Qed. + + Lemma min_premise_spec (m : model) (s : nonEmptyLevelExprSet) : + (forall x, LevelExprSet.In x s -> min_premise m s ≤ min_atom_value m x) /\ + (exists x, LevelExprSet.In x s /\ min_premise m s = min_atom_value m x). + Proof. + now apply min_premise_spec_aux. + Qed. + + Lemma min_premise_subset (m : model) (s s' : nonEmptyLevelExprSet) : + LevelExprSet.Subset s s' -> + min_premise m s' ≤ min_premise m s. + Proof. + intros sub. + have [has [mins [ins eqs]]] := min_premise_spec m s. + have [has' [mins' [ins' eqs']]] := min_premise_spec m s'. + specialize (sub _ ins). specialize (has' _ sub). + now rewrite eqs. + Qed. + + Lemma premise_min_spec_aux s k : + premise_min s = k -> + (forall x, LevelExprSet.In x s -> (k <= x)%nat) /\ + (exists x, LevelExprSet.In x s /\ k = x). + Proof. + unfold premise_min. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. + now exists t0; split => //. + - destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [t0]) in H as [<-|inih]. + cbn. rewrite fold_left_comm. unfold level_expr_elt in *; lia. unfold level_expr_elt in *; lia. + specialize (ha _ inih). + cbn. rewrite fold_left_comm. lia. lia. + destruct hex as [minval [inmin ih]]. + cbn. rewrite fold_left_comm. lia. + destruct (Nat.leb_spec a minval). + exists a. split; [intuition|]. rewrite -ih in H. unfold level_expr_elt in *; lia. + exists minval. + cbn in inmin; split; [intuition auto|]. lia. + Qed. + + Lemma premise_min_spec (s : nonEmptyLevelExprSet) : + (forall x, LevelExprSet.In x s -> premise_min s <= x)%nat /\ + (exists x, LevelExprSet.In x s /\ premise_min s = x). + Proof. + now apply premise_min_spec_aux. + Qed. + + Lemma premise_min_subset (s s' : nonEmptyLevelExprSet) : + LevelExprSet.Subset s s' -> + (premise_min s' <= premise_min s)%nat. + Proof. + intros sub. + have [has [mins [ins eqs]]] := premise_min_spec s. + have [has' [mins' [ins' eqs']]] := premise_min_spec s'. + specialize (sub _ ins). specialize (has' _ sub). + lia. + Qed. + + Lemma fold_comm_assoc x y z : option_map2 Z.max x (option_map2 Z.max y z) = + option_map2 Z.max y (option_map2 Z.max x z). + Proof. + now rewrite (assoc (f := option_map2 Z.max)) (comm (f := option_map2 Z.max) x y) -assoc. + Qed. + Notation max_opt := (option_map2 Z.max). + + Lemma max_opt_spec x y z : max_opt x y = Some z -> exists x' y', x = Some x' /\ y = Some y' /\ z = Z.max x' y'. + Proof. + destruct x as [x|], y as [y|]; cbn; intuition eauto; try noconf H. + exists x, y. auto. + Qed. + + (* Lemma Zmax_opt_left x y : x ≤ max_opt x y. *) + (* Proof. *) + (* destruct x as [x|], y as [y|]; try constructor. lia. *) + (* Qed. *) +(* + Lemma Zmax_opt_right x y : min_opt x y ≤ y. + Proof. + destruct x as [x|], y as [y|]; constructor. lia. + Qed. *) + + + Lemma max_premise_value_spec_aux (m : model) s k : + max_premise_value m s = Some k -> + (forall x, LevelExprSet.In x s -> exists k', levelexpr_value m x = Some k' /\ Some k' ≤ Some k) /\ + (exists x, LevelExprSet.In x s /\ Some k = levelexpr_value m x). + Proof. + unfold max_premise_value. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + induction l in k |- *. + - cbn. + intros eq. + split. intros x [->|] => //. exists k. split => //. reflexivity. + now exists t0; split => //. + - cbn. rewrite fold_left_comm. intros; apply fold_comm_assoc. + intros heq. apply max_opt_spec in heq as [y' [z' [eqa [eqf ->]]]]. + specialize (IHl _ eqf). destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [t0]) in H as [<-|inih]. + { exists y'; intuition eauto. constructor; lia. } + { specialize (ha _ inih) as [k' []]. exists k'; intuition eauto. constructor. depelim H0; lia. } + destruct hex as [maxval [inmax ih]]. + cbn. + destruct (Z.leb_spec z' y'). + exists a. split; [intuition|]. rewrite eqa. f_equal. lia. + exists maxval. cbn in inmax; split; [intuition auto|]. rewrite -ih. f_equal; lia. + Qed. + + Lemma max_premise_value_spec (m : model) (s : nonEmptyLevelExprSet) k : + max_premise_value m s = Some k -> + (forall x, LevelExprSet.In x s -> exists k', levelexpr_value m x = Some k' /\ Some k' ≤ Some k) /\ + (exists x, LevelExprSet.In x s /\ Some k = levelexpr_value m x). + Proof. + apply (max_premise_value_spec_aux m s). + Qed. +End MoreNonEmpty. + +Lemma min_premise_pos_spec {m prem k} : + min_premise m prem = Some k -> + forall x, LevelExprSet.In x prem -> Some (Z.of_nat (levelexpr_k x) + k)%Z ≤ levelexpr_value m x. +Proof. + pose proof (min_premise_spec m prem) as [amin [exmin [inminpre eqminpre]]]. + intros hprem x hin. + specialize (amin _ hin). + unfold min_atom_value in amin. + destruct x as [l k']; cbn in *. unfold levelexpr_value; cbn. + destruct (level_value m l) eqn:he. + - depelim amin. + rewrite H0 in hprem. depelim hprem. constructor. lia. + constructor. + rewrite H in hprem; depelim hprem. + - depelim amin. rewrite H in hprem. depelim hprem. +Qed. + +Definition equal_model (m m' : model) := LevelMap.Equal m m'. + +#[local] Instance equal_model_equiv : Equivalence equal_model. +Proof. unfold equal_model. + split; try econstructor; eauto. + red. intros. now symmetry. + red; intros. now transitivity y. +Qed. + +#[local] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. +Proof. + intros x y eqm l ? <-. unfold level_value. + unfold equal_model in eqm. + destruct LevelMap.find eqn:hl. + - eapply LevelMap.find_2 in hl. + rewrite eqm in hl. + eapply LevelMap.find_1 in hl. now rewrite hl. + - eapply LevelMapFact.F.not_find_in_iff in hl. + rewrite eqm in hl. + eapply LevelMapFact.F.not_find_in_iff in hl. + now rewrite hl. +Qed. + +Lemma v_minus_w_bound_spec W m : + forall x, ~ LevelSet.In x W -> level_value m x ≤ Some (v_minus_w_bound W m). +Proof. + intros x him. + unfold v_minus_w_bound. + set (fm := LevelMapFact.filter _ _). + replace (level_value m x) with (level_value fm x). + 2:{ unfold level_value. + destruct LevelMap.find eqn:hl => //. + eapply LevelMap.find_2 in hl. + subst fm. cbn in hl. + eapply LevelMapFact.filter_iff in hl as []. 2:tc. + rewrite (LevelMap.find_1 H) //. + destruct (LevelMap.find _ m) eqn:hl' => //. + eapply LevelMap.find_2 in hl'. + assert (LevelMap.MapsTo x o fm). + eapply LevelMapFact.filter_iff. tc. + split => //. now rewrite [_ = true]not_mem. + now rewrite (LevelMap.find_1 H) in hl. } + clearbody fm. + eapply LevelMapFact.fold_rec. + - intros m' em. unfold level_value. + destruct LevelMap.find eqn:hl => //. + eapply LevelMap.find_2 in hl. + now apply em in hl. constructor. + - intros k e a m' m'' map nin hadd. + red in hadd. + unfold level_value. cbn. + rewrite hadd LevelMapFact.F.add_o. + destruct LevelMap.OT.eq_dec. do 2 red in e0. subst x. + intros hf. destruct e; cbn; constructor. lia. + destruct LevelMap.find => hf; depelim hf; constructor; lia. +Qed. + +Lemma clauses_levels_restrict_clauses cls W : + LevelSet.Subset (clauses_levels (cls ⇂ W)) W. +Proof. + intros x [cl []] % clauses_levels_spec. + eapply in_restrict_clauses in H as [hconc hprem incl]. + eapply clause_levels_spec in H0 as []. apply hprem, H. now subst x. +Qed. + +Lemma clauses_conclusions_levels cls : + clauses_conclusions cls ⊂_lset clauses_levels cls. +Proof. + intros x. + rewrite clauses_conclusions_spec clauses_levels_spec. + setoid_rewrite clause_levels_spec. + firstorder auto. +Qed. + +Record model_extension W m m' := + { model_ext_le : m ⩽ m'; + model_ext_same_domain : model_same_domain m m'; + model_ext_same_outside : model_map_outside W m m' }. + +#[local] Instance model_ext_reflexive W : Reflexive (model_extension W). +Proof. + intros m; split; reflexivity. +Qed. + +#[local] Instance model_ext_transitive W : Transitive (model_extension W). +Proof. + intros m m' m'' h h'; split; (etransitivity; [apply h|apply h']). +Qed. + +Lemma model_extension_weaken W W' m m' : + W ⊂_lset W' -> + model_extension W m m' -> + model_extension W' m m'. +Proof. + intros leW []; split => //. + eapply model_map_outside_weaken; tea. +Qed. + +Lemma model_ext_trans_weaken W W' m m' m'' : + W ⊂_lset W' -> + model_extension W m m' -> + model_extension W' m' m'' -> + model_extension W' m m''. +Proof. + intros leW mext mext'. eapply model_extension_weaken in mext; tea. + now etransitivity; tea. +Qed. + +Definition check_model_invariants cls w m w' m' (modified : bool) := + if modified then + [/\ w ⊂_lset w', + w' ⊂_lset (LevelSet.union w (clauses_conclusions cls)), + exists cl, + let cll := (levelexpr_level (concl cl)) in + [/\ Clauses.In cl cls, ~~ valid_clause m cl, + LevelSet.In cll w' & + opt_le Z.lt (level_value m cll) (level_value m' cll)] & + model_extension w' m m'] + else (w, m) = (w', m'). + +#[local] Instance clauses_conclusions_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_conclusions. +Proof. + intros cls cls' eq x. + rewrite !clauses_conclusions_spec. now setoid_rewrite eq. +Qed. + +#[local] Instance And3P_proper : Proper (iff ==> iff ==> iff ==> iff) ssrbool.and3. +Proof. + repeat intro. split; intros []; split; intuition auto. +Qed. + +#[local] Instance And4P_proper : Proper (iff ==> iff ==> iff ==> iff ==> iff) ssrbool.and4. +Proof. + repeat intro. split; intros []; split; intuition auto. +Qed. + +#[local] Instance check_model_invariants_proper : + Proper (Clauses.Equal ==> eq ==> eq ==> eq ==> eq ==> eq ==> iff) check_model_invariants. +Proof. + intros cls cls' eqcls. + repeat intro; subst. + unfold check_model_invariants. + destruct y3 => //. + now setoid_rewrite <-eqcls. +Qed. + +Lemma min_atom_value_levelexpr_value m l a lv : min_atom_value m l = Some a -> levelexpr_value m l = Some lv -> (a <= (lv - Z.of_nat l))%Z. +Proof. + destruct l as [l k]; cbn. unfold levelexpr_value. cbn. destruct level_value => //. + intros [= <-] [= <-]. lia. +Qed. + +Lemma clauses_conclusions_add cl cls : + clauses_conclusions (Clauses.add cl cls) =_lset + (LevelSet.singleton (level (concl cl)) ∪ + clauses_conclusions cls). +Proof. + intros x. + rewrite LevelSet.union_spec !clauses_conclusions_spec. + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.singleton_spec. + firstorder eauto. subst. now left. +Qed. + +Definition declared_model_level (m : model) l := LevelMap.In l m. + +Definition clause_conclusion cl := levelexpr_level (concl cl). + +Definition update_model_same_domain {m l k} : + declared_model_level m l -> + model_same_domain m (update_model m l k). +Proof. + unfold update_model, declared_model_level. + intros hin x. + rewrite LevelMapFact.F.add_in_iff. intuition auto. now subst. +Qed. + +Definition update_model_outside {m w l k} : + model_map_outside (LevelSet.add l w) m (update_model m l k). +Proof. + unfold update_model, model_map_outside. + intros l'. rewrite LevelSet.add_spec. + intros hin k'. + rewrite LevelMapFact.F.add_neq_mapsto_iff //. + intros heq. red in heq; subst l'. apply hin. now left. +Qed. + +Lemma opt_lt_le_trans x y z : + opt_le Z.lt x y -> + opt_le Z.le y z -> + opt_le Z.lt x z. +Proof. + intros [] H'; depelim H'; constructor. lia. +Qed. + +Lemma level_value_not_above_spec m l k : level_value_above m l k = false -> opt_le Z.lt (level_value m l) (Some k). +Proof. + unfold level_value_above; destruct level_value => // hlt; constructor. lia. +Qed. + +Lemma check_clause_model_modify' {cl cls w m w' m' w'' m'' modified modified'} : + check_model_invariants cls w m w' m' modified -> + declared_model_level m (clause_conclusion cl) -> + check_clause_model cl (modified, (w', m')) = (modified', (w'', m'')) -> + check_model_invariants (Clauses.add cl cls) w m w'' m'' modified'. +Proof. + intros inv declcl. + unfold check_clause_model. + destruct (update_value (w', m') cl) eqn:upd. + * intros [= <- <-]. subst. + destruct modified. 2:{ noconf inv. reflexivity. } + destruct inv. + split => //. + + rewrite clauses_conclusions_add; lsets. + + destruct H1 as [cl' []]. + exists cl'; split => //. now rewrite Clauses.add_spec. + * intros [= <- <-]. subst. + destruct modified. 2:{ noconf inv. reflexivity. } + destruct inv. + split => //. + + rewrite clauses_conclusions_add; lsets. + + destruct H1 as [cl' []]. + exists cl'; split => //. now rewrite Clauses.add_spec. + * intros [= <- ->]. + move: upd. + unfold update_value. + destruct min_premise as [hmin|] eqn:eqmin => //. + destruct cl as [prem [l k]] => /=. + destruct level_value_above eqn:hval => //. + intros [= <- <-]. + destruct modified; noconf inv. + { destruct inv. + split => //. + + lsets. + + rewrite clauses_conclusions_add. + intros x. rewrite LevelSet.add_spec !LevelSet.union_spec LevelSet.singleton_spec. + intuition eauto. cbn. apply H0 in H4. lsets. + + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. + destruct H1 as [cl []]; exists cl; split => //. eauto. eauto. + destruct (level_value m (concl cl)) as [vconcl|] eqn:hconcl; [|constructor]. + eapply opt_lt_le_trans; tea. + eapply model_le_values. + now eapply update_model_not_above. + + transitivity m'. + { eapply model_extension_weaken; tea. lsets. } + split. + { now eapply update_model_not_above. } + { eapply update_model_same_domain. + eapply H2, declcl. } + { eapply update_model_outside. } } + { split => //. + + lsets. + + rewrite clauses_conclusions_add. + intros x. rewrite LevelSet.add_spec !LevelSet.union_spec LevelSet.singleton_spec. + intuition eauto. + + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. + exists (prem, (l, k)). + split; tea; eauto. + - unfold valid_clause. cbn. now rewrite eqmin hval /=. + - cbn. rewrite level_value_update_model. now apply level_value_not_above_spec. + + split. + { now eapply update_model_not_above. } + { eapply update_model_same_domain. + eapply declcl. } + { eapply update_model_outside. } } +Qed. + +Definition model_of V (m : model) := + forall k, LevelSet.In k V -> LevelMap.In k m. + +Lemma model_of_subset V V' m : + model_of V m -> V' ⊂_lset V -> model_of V' m. +Proof. + rewrite /model_of. intros ih hv k. specialize (ih k). + now move/hv. +Qed. + +Definition total_model_of V (m : model) := + forall k, LevelSet.In k V -> exists x, LevelMap.MapsTo k (Some x) m. + +Lemma total_model_of_subset V V' m : + total_model_of V m -> V' ⊂_lset V -> total_model_of V' m. +Proof. + intros ih hv k. specialize (ih k). + now move/hv. +Qed. + +Lemma total_model_of_sub V m : total_model_of V m -> model_of V m. +Proof. + rewrite /total_model_of /model_of. + intros H k hin. specialize (H k hin) as [? ?]. + now exists (Some x). +Qed. +Coercion total_model_of_sub : total_model_of >-> model_of. + +Lemma clauses_conclusions_subset {cls cls'} : + Clauses.Subset cls cls' -> + clauses_conclusions cls ⊂_lset clauses_conclusions cls'. +Proof. + intros hsub x. rewrite !clauses_conclusions_spec. + intuition eauto. destruct H as [cl []]; exists cl; split; try clsets; auto. +Qed. + +Lemma check_model_aux_spec {cls w m w' m' modified} : + model_of (clauses_conclusions cls) m -> + check_model_aux cls (w, m) = (modified, (w', m')) -> + check_model_invariants cls w m w' m' modified. +Proof. + rewrite /check_model_aux /is_model. + revert modified w' m'. + eapply ClausesProp.fold_rec. + - intros s' e modified w' m' mof [= <- <- <-]. + split. + - intros x ? s' s'' inx nins' hadd ih modified w' m' mof. + destruct a as [modified'' [w'' m'']]. + assert (ms' : model_of (clauses_conclusions s') m). + { eapply model_of_subset; tea. + eapply clauses_conclusions_subset. red in hadd. intros ?. + specialize (hadd a). intuition auto. } + specialize (ih _ _ _ ms' eq_refl). + apply ClausesProp.Add_Equal in hadd. rewrite hadd. + eapply check_clause_model_modify' => //. + red. apply mof. + apply clauses_conclusions_spec. exists x; split => //. + apply hadd. clsets. +Qed. + +Lemma check_model_spec {cls w m w' m'} : + model_of (clauses_conclusions cls) m -> + check_model cls (w, m) = Some (w', m') -> + check_model_invariants cls w m w' m' true. +Proof. + intros mof. + unfold check_model. + destruct check_model_aux eqn:cm. + destruct p as []. + eapply check_model_aux_spec in cm => //. + destruct b => //. now intros [= <- <-]. +Qed. + +Lemma check_model_aux_not_model {cls w m w' m'} : + model_of (clauses_conclusions cls) m -> + check_model_aux cls (w, m) = (true, (w', m')) -> + ~~ is_model cls m. +Proof. + intros mof. + move/(check_model_aux_spec mof) => [] _ _ [cl [incl inval]] _ _ _. + unfold is_model. + apply clauses_for_all_neg. + intros hf. specialize (hf cl incl). cbn in hf. + rewrite /is_true hf in inval => //. +Qed. + +Lemma check_model_is_model {W cls m} : + model_of (clauses_conclusions cls) m -> + check_model cls (W, m) = None <-> is_model cls m. +Proof. + intros mof; unfold check_model, is_model. + destruct check_model_aux eqn:caux. + destruct b => //. intuition auto. congruence. + { destruct p; eapply check_model_aux_not_model in caux => //. + rewrite /is_model /= // in caux. now rewrite H in caux. } + intuition auto. + pose proof (check_model_aux_false caux). subst p. + now rewrite check_model_aux_model in caux. +Qed. + +Lemma check_model_update {W cls m wm'} : + model_of (clauses_conclusions cls) m -> + check_model cls (W, m) = Some wm' -> ~~ is_model cls m /\ m ⩽ wm'.2. +Proof. + intros mof; unfold check_model, is_model. + destruct check_model_aux eqn:caux. + destruct b => //. intros [= <-]. intuition auto. + destruct p. + now eapply check_model_aux_not_model in caux. + now eapply check_model_aux_model_le in caux. +Qed. + +Definition level_value_default m l := + match level_value m l with Some x => x | None => 0 end%Z. + +Definition measure_w W cls m w := + let bound := v_minus_w_bound W m in + let maxgain := max_gain (cls_diff cls W) in + (bound + Z.of_nat maxgain - level_value_default m w)%Z. + +Lemma min_premise_max_premise m prem k : + min_premise m prem = Some k -> + exists k', max_premise_value m prem = Some k'. +Proof. + unfold min_premise, max_premise_value. + destruct to_nonempty_list. + assert (forall l k, fold_left + (fun (min : option Z) (atom : LevelExpr.t) => + option_map2 Z.min (let '(l0, k0) := atom in match level_value m l0 with + | Some val => Some (val - Z.of_nat k0)%Z + | None => None + end) min) + l None = + Some k -> False). + { clear. induction l; cbn => //. cbn in *. + destruct a, level_value; cbn; auto. } + assert + (forall x y, fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (Some x) = Some k -> +exists k' : Z, + fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.max (levelexpr_value m atom) min) l (Some y) = Some k'). + { induction l; cbn. + - intros x y [= <-]. now eexists. + - intros x y. + unfold min_atom_value, levelexpr_value, levelexpr_level. destruct a; cbn. + destruct level_value => //=. eapply IHl. cbn. intros H'. exfalso. + eapply H; eauto. } + - unfold min_atom_value, levelexpr_value, levelexpr_level. destruct t; cbn. + destruct level_value => //=. apply H0. + intros; exfalso. now eapply H. +Qed. + +Lemma total_model_of_value_None W m l : + total_model_of W m -> + LevelSet.In l W -> + level_value m l = None -> False. +Proof. + intros tm inw. specialize (tm l inw) as [v hm]. + rewrite /level_value. + now rewrite (LevelMap.find_1 hm). +Qed. + +Lemma invalid_clause_measure W cls cl m : + total_model_of W m -> + ~~ valid_clause m cl -> + Clauses.In cl (cls_diff cls W) -> + (0 < measure_w W cls m (concl cl))%Z. +Proof. + intros hwv. unfold valid_clause. + (* case: Z.ltb_spec => // hprem. *) + destruct cl as [prem [l k]]; cbn. + destruct min_premise eqn:hmin => //. + move/negbTE/level_value_not_above_spec => hlt hin. + have hne := (non_W_atoms_ne _ _ _ hin). + cbn. unfold measure_w. unfold gain. + set (clsdiff := Clauses.diff _ _). + set (bound := v_minus_w_bound W m). + enough (level_value_default m l < bound + Z.of_nat (max_gain clsdiff))%Z. lia. + set (prem' := non_W_atoms W prem). + set (preml := {| t_set := prem'; t_ne := hne |}). + assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff)%nat. + { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. + unfold gain. cbn. + pose proof (premise_min_subset preml prem). + rewrite !Z2Nat.inj_sub //; try lia. rewrite !Nat2Z.id. + forward H. eapply non_W_atoms_subset. lia. } + eapply Z.lt_le_trans with (bound + Z.of_nat (Z.to_nat (gain (preml, (l, k)))))%Z; try lia. + unfold gain; cbn. + enough (level_value_default m l < v_minus_w_bound W m + Z.of_nat (k - premise_min preml))%Z. lia. + unfold level_value_default. destruct (level_value m l) as [vl|] eqn:hl; revgoals. + { eapply total_model_of_value_None in hl; tea => //. + eapply Clauses.diff_spec in hin as [hin _]. + now apply in_clauses_with_concl in hin as [hin _]. } + depelim hlt. + enough (Z.of_nat k + z <= v_minus_w_bound W m + Z.of_nat (k - premise_min preml))%Z. lia. + assert (min_premise m prem ≤ min_premise m preml)%Z. + { eapply min_premise_subset. eapply non_W_atoms_subset. } + rewrite hmin in H1. depelim H1. + transitivity (Z.of_nat k + y)%Z. lia. + pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. + have [maxpreml eqmax] := min_premise_max_premise m preml _ H2. + pose proof (max_premise_value_spec m preml _ eqmax) as [amax [exmax [inmaxpre eqmaxpre]]]. + pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. + assert (premise_min prem <= premise_min preml)%nat. + { eapply premise_min_subset. eapply non_W_atoms_subset. } + (* transitivity (v_minus_w_bound W m + (k - premise_min preml)). 2:lia. *) + assert (y <= maxpreml - Z.of_nat (premise_min preml))%Z. + { rewrite eqpminpre. rewrite H2 in eqminpre; symmetry in eqminpre. + (* eqmaxpre eqminpre. *) + pose proof (min_atom_value_levelexpr_value m exmin). + specialize (amax _ inminpre) as amax'. rewrite eqmaxpre in amax'. + destruct amax' as [vexmin [eqexmin ltexmin]]. + assert (expmin <= exmin)%nat. specialize (apmin _ inminpre). lia. + specialize (H4 _ _ eqminpre eqexmin). depelim ltexmin. etransitivity; tea. + rewrite -eqmaxpre in H6. noconf H6. + unfold level_expr_elt in *. lia. } + transitivity (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)))%Z. lia. + (* assert (Z.of_nat (premise_min preml) <= maxpreml)%Z. + { rewrite eqmaxpre. + move/min_premise_pos_spec: hprem => hprem. + transitivity exmax. apply apmin => //. eapply hprem. + now apply (non_W_atoms_subset W prem). } *) + assert (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)) = + (maxpreml + Z.of_nat k - Z.of_nat (premise_min preml)))%Z as ->. lia. + enough (maxpreml <= v_minus_w_bound W m)%Z. lia. + { have vm := v_minus_w_bound_spec W m exmax. unfold levelexpr_value in eqmaxpre. + rewrite -eqmaxpre in vm. + have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). + rewrite levelexprset_levels_spec in hlevels. + forward hlevels. + exists exmax.2. now destruct exmax. + rewrite LevelSet.diff_spec in hlevels. + destruct hlevels as [_ nw]. specialize (vm nw). now depelim vm. } +Qed. + +Definition levelset_m_eq : LevelSet.t × model -> LevelSet.t × model -> Prop := + fun x y => LevelSet.Equal x.1 y.1 /\ LevelMap.Equal x.2 y.2. + +#[local] Instance lmeq_eq : Equivalence levelset_m_eq. +Proof. + split. intros x. split => //. + intros x y []; split => //. now rewrite H. + intros x y z [] []; split => //. + all:etransitivity; tea. +Qed. + +Definition modified_levelset_m_eq : bool × LevelSet.t × model -> bool × LevelSet.t × model -> Prop := + fun x y => x.1 = y.1 /\ levelset_m_eq x.2 y.2. + +#[local] Instance mlm_eq : Equivalence modified_levelset_m_eq. +Proof. + split. intros x. split => //. + intros x y []; split => //. now symmetry. + intros x y z [] []; split => //. all:etransitivity; tea. +Qed. + +#[local] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. +Proof. + intros m m' eqm ? ? ->. unfold min_atom_value. + destruct y => //. + now rewrite eqm. +Qed. + +#[local] Instance fold_left_ext {A B} : Proper (`=2` ==> eq ==> eq ==> eq) (@fold_left A B). +Proof. + intros f g hfg ? ? -> ? ? ->. + induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). +Qed. + +#[local] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. +Proof. + intros m m' eq ? ? ->. + unfold min_premise. + destruct to_nonempty_list. + now setoid_rewrite eq. +Qed. + +#[local] Instance update_model_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> LevelMap.Equal) update_model. +Proof. + intros m m' hm ? ? -> ? ? ->. + unfold update_model. + now rewrite hm. +Qed. + +#[local] Instance level_value_above_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> eq) level_value_above. +Proof. + intros m m' hm ? ? -> ? ? ->. + unfold level_value_above. + now rewrite hm. +Qed. + +#[local] Instance check_clause_model_proper : Proper (eq ==> modified_levelset_m_eq ==> modified_levelset_m_eq) check_clause_model. +Proof. + intros x y eq [? []] [? []] []; cbn in *; subst. + unfold levelset_m_eq in H0. destruct H0; cbn in *; subst. + replace (min_premise m (premise y)) with (min_premise m0 (premise y)). + 2: now rewrite H0. + destruct min_premise. + destruct concl => //. + replace (level_value_above m t1 (Z.of_nat n + z)) with (level_value_above m0 t1 (Z.of_nat n + z)). + 2:now rewrite H0. + destruct level_value_above => //. + red. cbn. split => //. + red. cbn; split => //. now rewrite H. now rewrite H0. + red. cbn. split => //. +Qed. + +Module ClausesOrd := OrdProperties Clauses. + + +#[local] Instance check_model_aux_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model_aux. +Proof. + intros cls cls' eq. + intros wm wm' eq'. subst wm'. + unfold check_model_aux. + now eapply ClausesOrd.fold_equal; tc. +Qed. + +#[local] Instance check_model_aux_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> modified_levelset_m_eq) check_model_aux. +Proof. + intros cls cls' eq. + intros wm wm' eq'. + transitivity (check_model_aux cls' wm). + 2:{ unfold check_model_aux. + eapply (ClausesProp.fold_init (eqA := modified_levelset_m_eq)); tc. + red. cbn => //. } + unfold check_model_aux. + now eapply ClausesOrd.fold_equal; tc. +Qed. + +#[local] Instance check_model_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> R_opt levelset_m_eq) check_model. +Proof. + intros cls cls' eq. + intros wm wm' eq'. + unfold check_model. + destruct (check_model_aux cls wm) eqn:eqc. + destruct (check_model_aux cls' wm') eqn:eqc' => //. + pose proof (check_model_aux_proper cls cls' eq wm wm' eq'). + rewrite eqc eqc' in H. destruct H; cbn in *; subst. + red in H0. destruct H0. + destruct b0 => //. +Qed. + +#[local] Instance check_model_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model. +Proof. + intros cls cls' eq. + intros wm wm' eq'. + unfold check_model. + now subst wm'; rewrite eq. +Qed. + +Record valid_model_def (V : LevelSet.t) (m : model) (cls : clauses) := + { model_model : model; + model_of_V :> model_of V model_model; + model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; + model_ok :> is_model cls model_model; + model_extends : model_extension V m model_model; + }. +Arguments model_model {V m cls}. +Arguments model_of_V {V m cls}. +Arguments model_clauses_conclusions {V m cls}. +Arguments model_ok {V m cls}. +Arguments model_extends {V m cls}. +Extraction Inline model_model. + +Definition valid_model := valid_model_def. + +Inductive entails (cls : clauses) : clause -> Prop := +| clause_in (prems : nonEmptyLevelExprSet) (cl : LevelExpr.t) : LevelExprSet.In cl prems -> entails cls (prems, cl) +| clause_cut prems' concl' prems concl : + Clauses.In (prems', concl') cls -> + entails cls (add concl' prems, concl) -> + LevelExprSet.Subset prems' prems -> + entails cls (prems, concl). + +(* Definition succ_expr '((l, k) : LevelExpr.t) := (l, k + 1). +Definition succ_prems s := map (fun '(l, k) => (l, k + 1)) s. +Definition succ_clause '((prems, concl) : clause) := (succ_prems prems, succ_expr concl). +Lemma succ_clause_inj x y : succ_clause x = succ_clause y -> x = y. +Proof. Admitted. +Definition succ_clauses cls := ClausesProp.of_list (List.map (fun cl => succ_clause cl) (ClausesProp.to_list cls)). +Import SetoidList. +Lemma succ_clauses_spec cl cls : Clauses.In cl cls <-> Clauses.In (succ_clause cl) (succ_clauses cls). +Proof. + unfold succ_clauses. + rewrite ClausesProp.of_list_1 InA_In_eq in_map_iff. + firstorder eauto. + - exists cl; split => //. unfold ClausesProp.to_list. now eapply Clauses_In_elements. + - eapply Clauses_In_elements in H0. apply succ_clause_inj in H. now subst. +Qed. + +Lemma entails_plus cls c : entails cls c -> entails (succ_clauses cls) (succ_clause c). +Proof. + induction 1. + - constructor. apply map_spec. exists cl. split => //. + - eapply clause_cut with (succ_prems prems') (succ_expr concl'). + + now rewrite -(succ_clauses_spec (prems', concl')). + + admit. + + admit. +Admitted. + +Definition to_clauses (prems : nonEmptyLevelExprSet) (concl : nonEmptyLevelExprSet) : clauses := + LevelExprSet.fold (fun lk cls => Clauses.add (prems, lk) cls) concl Clauses.empty. + +Definition is_loop (cls : clauses) (t : nonEmptyLevelExprSet) := + let cls' := to_clauses t (succ_prems t) in + Clauses.For_all (fun cl' => entails cls cl') cls'. + *) +(* Definition is_looping (w : LevelSet.t) n (cls : clauses) := + let preml := LevelSet.elements w in + let prem := List.map (fun e => (e, n)) preml in + is_loop cls prem. *) + +Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := + | Loop + (* (w : LevelSet.t) (n : nat) (islooping : loop_on w n cls) *) + | Model (w : LevelSet.t) (m : valid_model V m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). +Arguments Loop {V U cls m}. +Arguments Model {V U cls m}. +Arguments lexprod {A B}. + +Definition option_of_result {V U m cls} (r : result V U m cls) : option model := + match r with + | Loop => None + | Model w m sub => Some m.(model_model) + end. + +Definition extends_model {W U cls m m'} : + m' ⩽ m -> + model_same_domain m' m -> + model_map_outside W m' m -> + result W U cls m -> result W U cls m'. +Proof. + intros leq ldom lout []. exact Loop. + econstructor 2; tea. + destruct m0. econstructor; tea. + - now transitivity m. +Qed. + +(* #[tactic="idtac"] +Equations? result_inclusion {V U m cls V'} (r : result V U cls m) + (prf : LevelSet.Subset V V') : result V' U cls m := + result_inclusion Loop _ := Loop; + result_inclusion (Model w m' sub) sub' := + Model w {| model_model := m'.(model_model) |} _. +Proof. + - + - transitivity V => //. now eapply m'.(model_clauses_conclusions). + - apply m'. + - apply m'. + - apply m'. + - intros x hin. apply m'. intros hv. + apply sub' in hv. now apply hin. + - intuition lsets. +Qed. *) + +Notation "#| V |" := (LevelSet.cardinal V). + +Notation loop_measure V W := (#|V|, #|V| - #|W|)%nat. + +Definition lexprod_rel := lexprod lt lt. + +#[local] Instance lexprod_rel_wf : WellFounded lexprod_rel. +Proof. + eapply (Acc_intro_generator 1000). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. +Defined. + +Section InnerLoop. + Context (V : LevelSet.t) (U : LevelSet.t) + (loop : forall (V' U' : LevelSet.t) (cls : clauses) (m : model) + (prf : [/\ clauses_conclusions cls ⊂_lset V', U' ⊂_lset V' & model_of V' m]), + lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls m). + + Definition sum_W W (f : LevelSet.elt -> nat) : nat := + LevelSet.fold (fun w acc => acc + f w)%nat W 0%nat. + + Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := + sum_W W (fun w => Z.to_nat (measure_w W cls m w)). + + Lemma maps_to_value_default {x k m} : LevelMap.MapsTo x k m -> level_value m x = k. + Proof. + intros h; apply LevelMap.find_1 in h. + now rewrite /level_value h. + Qed. + + Lemma measure_model W cls m : + total_model_of W m -> + let clsdiff := cls_diff cls W in + measure W cls m = 0%nat -> is_model clsdiff m. + Proof using. + clear loop V U. + unfold measure, sum_W, measure_w, is_model. + set (clsdiff := Clauses.diff _ _). + intros hv hm. + assert (LevelSet.For_all (fun w => Some (v_minus_w_bound W m + Z.of_nat (max_gain clsdiff)) ≤ level_value m w)%Z W). + { move: hm. + generalize (v_minus_w_bound W m) => vbound. + eapply LevelSetProp.fold_rec. + intros. intros x hin. firstorder eauto. + intros x a s' s'' inw nins' hadd ih heq. + forward ih by lia. + intros l hin. + specialize (hv _ inw) as [k lv]. rewrite /level_value_default (maps_to_value_default lv) in heq. + apply hadd in hin as []. + * subst x. rewrite (maps_to_value_default lv). constructor. lia. + * now apply ih. } + clear hm. + eapply ClausesFact.for_all_iff. tc. + intros cl hl. + unfold valid_clause. + destruct min_premise as [k0|] eqn:hk0 => //. + destruct cl as [prem [l k]] => /=. cbn in hk0. + rewrite /clsdiff in hl. + destruct (proj1 (Clauses.diff_spec _ _ _) hl) as [hlcls hl']. + eapply in_clauses_with_concl in hlcls as [lW incls]. + specialize (H _ lW). cbn -[clsdiff] in H. cbn in lW. + specialize (hv _ lW) as [vl hvl]. rewrite /level_value_above (maps_to_value_default hvl). + rewrite (maps_to_value_default hvl) in H; depelim H. + (* etransitivity; tea. *) + set (prem' := non_W_atoms W prem). + assert (ne : LevelExprSet.is_empty prem' = false). + { now eapply (non_W_atoms_ne W (prem, (l, k)) cls). } + set (preml := {| t_set := prem'; t_ne := ne |}). + assert (min_premise m prem ≤ min_premise m preml). + { eapply min_premise_subset. eapply non_W_atoms_subset. } + (* min_i (f(x_i)-k_i) <= max_i(f(x_i)) - min(k_i) *) + pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. + rewrite hk0 in H0. depelim H0. rename y into minpreml. + pose proof (min_premise_max_premise _ _ _ H1) as [maxpreml eqmaxp]. + pose proof (max_premise_value_spec m preml _ eqmaxp) as [amax [exmax [inmaxpre eqmaxpre]]]. + rewrite -eqmaxp in eqmaxpre. + pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. + assert (min_premise m preml ≤ Some (maxpreml - Z.of_nat (premise_min preml)))%Z. + { rewrite eqminpre in H1. + specialize (amax _ inminpre). destruct amax as [k' [lk' hk']]. + depelim hk'. + pose proof (min_atom_value_levelexpr_value m exmin _ _ H2 lk'). + rewrite eqminpre H2. constructor. etransitivity; tea. + rewrite eqmaxpre in eqmaxp. + assert (expmin <= exmin)%nat. specialize (apmin _ inminpre). lia. + unfold level_expr_elt in *. lia. } + apply Z.leb_le. rewrite H1 in H2. depelim H2. + transitivity (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)))%Z. lia. + assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff)%nat. + { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. + unfold gain. cbn. + pose proof (premise_min_subset preml prem). + rewrite !Z2Nat.inj_sub //; try lia. rewrite !Nat2Z.id. + forward H3. eapply non_W_atoms_subset. lia. } + transitivity (v_minus_w_bound W m + (gain (preml, (l, k))))%Z. + 2:lia. + unfold gain. cbn -[max_premise_value premise_min]. + (* assert (Z.of_nat (premise_min preml) <= maxpreml)%Z. + { + (* rewrite eqmaxpre. *) + move/min_premise_pos_spec: hk0 => hprem. + transitivity (Z.of_nat (levelexpr_k exmax)). + specialize (apmin _ inmaxpre). now apply inj_le. + rewrite eqmaxp in eqmaxpre. unfold levelexpr_value in eqmaxpre. + unfold levelexpr_k. + specialize (amax _ inmaxpre) as [k' [eqk' k'max]]. + eapply hprem. + now apply (non_W_atoms_subset W prem). } *) + assert (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)) = + (maxpreml + Z.of_nat k - Z.of_nat (premise_min preml)))%Z as ->. lia. + (* rewrite Z2Nat.inj_sub. lia. *) + (* rewrite !Nat2Z.id. *) + assert (maxpreml <= v_minus_w_bound W m)%Z. + { pose proof (v_minus_w_bound_spec W m exmax). + have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). + rewrite levelexprset_levels_spec in hlevels. + forward hlevels. + exists exmax.2. now destruct exmax. + rewrite LevelSet.diff_spec in hlevels. + destruct hlevels. + forward H4 by auto. + rewrite eqmaxp in eqmaxpre. unfold levelexpr_value in eqmaxpre. rewrite -eqmaxpre in H4. + now depelim H4. + } + lia. + Qed. + + Lemma level_value_default_def {m x v} : level_value m x = Some v -> level_value_default m x = v. + Proof. unfold level_value_default. now intros ->. Qed. + + Lemma w_values_ext m m' W : + m ⩽ m' -> total_model_of W m -> total_model_of W m'. + Proof. + intros ext hf x hin. + specialize (hf x hin) as [k hl]. + specialize (ext _ _ hl) as [? []]. + depelim H0. now exists y. + Qed. + + Lemma level_values_in_W m m' W x : + total_model_of W m -> + m ⩽ m' -> + LevelSet.In x W -> level_value m x ≤ level_value m' x -> + exists k k', level_value m x = Some k /\ level_value m' x = Some k' /\ (k <= k')%Z. + Proof. + intros hwv ext hin hleq. + specialize (hwv _ hin) as x'. destruct x' as [k hl]. rewrite (maps_to_value_default hl) in hleq. + eapply w_values_ext in hwv; tea. + specialize (hwv _ hin) as [k' hl']. + rewrite (maps_to_value_default hl') in hleq. depelim hleq. + do 2 eexists. intuition eauto. + now rewrite (maps_to_value_default hl). + now rewrite (maps_to_value_default hl'). + Qed. + + Lemma measure_le {W cls m m'} : + total_model_of W m -> + model_map_outside W m m' -> + m ⩽ m' -> + (measure W cls m' <= measure W cls m)%nat. + Proof. + intros hwv hout hle. + unfold measure, measure_w, sum_W. + rewrite (v_minus_w_bound_irrel _ _ hout). + rewrite !LevelSet.fold_spec. unfold flip. + eapply fold_left_le; unfold flip. 2:lia. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. + erewrite !level_value_default_def; tea. lia. + Qed. + + Lemma measure_lt {W cls m m'} : + total_model_of W m -> + model_map_outside W m m' -> + m ⩽ m' -> + (exists l, [/\ LevelSet.In l W, (0 < measure_w W cls m l)%Z & + opt_le Z.lt (level_value m l) (level_value m' l)])%Z -> + (measure W cls m' < measure W cls m)%nat. + Proof. + intros hwv hout hle. + unfold measure, measure_w, sum_W. + rewrite (v_minus_w_bound_irrel _ _ hout). + intros hlt. + rewrite !LevelSet.fold_spec. unfold flip. + eapply fold_left_ne_lt; unfold flip. + - unfold flip. intros; lia. + - unfold flip; intros; lia. + - destruct hlt as [l [hin _]]. intros he. rewrite -LevelSetProp.elements_Empty in he. lsets. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. + erewrite !level_value_default_def; tea. lia. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. + erewrite !level_value_default_def; tea. lia. + - destruct hlt as [l [hinl hbound hlev]]. + exists l. rewrite LevelSet_In_elements. split => //. + intros acc acc' accle. + eapply Nat.add_le_lt_mono => //. + depelim hlev. rewrite /level_value_default ?H0 ?H1 in hbound |- *. + lia. now eapply total_model_of_value_None in H; tea. + Qed. + + Lemma is_model_equal {cls cls' m} : Clauses.Equal cls cls' -> is_model cls m -> is_model cls' m. + Proof. now intros ->. Qed. + + Lemma union_diff_eq {cls cls'} : Clauses.Equal (Clauses.union cls (Clauses.diff cls' cls)) + (Clauses.union cls cls'). + Proof. clsets. Qed. + + Lemma union_restrict_with_concl {cls W} : + Clauses.Equal (Clauses.union (cls ⇂ W) (cls ↓ W)) (cls ↓ W). + Proof. + intros cl. rewrite Clauses.union_spec. + intuition auto. + eapply in_clauses_with_concl. + now eapply in_restrict_clauses in H0 as []. + Qed. + + Lemma maps_to_level_value x (m m' : model) : + (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> + level_value m x = level_value m' x. + Proof. + intros heq. + unfold level_value. + destruct LevelMap.find eqn:hl. + apply LevelMap.find_2 in hl. rewrite heq in hl. + rewrite (LevelMap.find_1 hl) //. + destruct (LevelMap.find x m') eqn:hl' => //. + apply LevelMap.find_2 in hl'. rewrite -heq in hl'. + now rewrite (LevelMap.find_1 hl') in hl. + Qed. + + Lemma measure_Z_lt x y : + (x < y)%Z -> + (0 < y)%Z -> + (Z.to_nat x < Z.to_nat y)%nat. + Proof. intros. lia. Qed. + + Lemma sum_pos W f : + (0 < sum_W W f)%nat -> + exists w, LevelSet.In w W /\ (0 < f w)%nat. + Proof. + unfold sum_W. + eapply LevelSetProp.fold_rec => //. + intros. lia. + intros. + destruct (Nat.ltb_spec 0 a). + - destruct (H2 H4) as [w [hin hlt]]. exists w. split => //. apply H1. now right. + - exists x. split => //. apply H1. now left. lia. + Qed. + + Lemma measure_pos {W cls m} : + (0 < measure W cls m)%nat -> + exists l, LevelSet.In l W /\ (0 < measure_w W cls m l)%Z. + Proof. + unfold measure. + move/sum_pos => [w [hin hlt]]. + exists w. split => //. lia. + Qed. + + Lemma model_of_diff cls W m : + model_of W m -> model_of (clauses_conclusions (cls_diff cls W)) m. + Proof. + intros; eapply model_of_subset; tea. + eapply clauses_conclusions_diff_left. + Qed. + Hint Resolve model_of_diff : core. + + Lemma check_model_spec_diff {cls w m w' m' w''} : + model_of w m -> + let cls := (cls_diff cls w) in + check_model cls (w'', m) = Some (w', m') -> + [/\ w'' ⊂_lset w', w' ⊂_lset (w'' ∪ w), + exists cl : clause, + let cll := levelexpr_level (concl cl) in + [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' + & (opt_le Z.lt (level_value m cll) (level_value m' cll))%Z] + & model_extension w' m m']. + Proof. + cbn; intros mof cm. + pose proof (clauses_conclusions_diff_left cls w (cls ⇂ w)). + apply check_model_spec in cm as []. + split => //. lsets. + eapply model_of_subset; tea. + Qed. + + Lemma model_of_ext {W W' m m'} : + model_of W m -> model_extension W' m m' -> model_of W m'. + Proof. + intros mof [_ dom _]. + intros k hin. apply dom. now apply mof. + Qed. + + Lemma total_model_of_ext {W W' m m'} : + total_model_of W m -> model_extension W' m m' -> total_model_of W m'. + Proof. + intros mof [_ dom _]. + intros k hin. destruct (mof k hin). destruct (dom k). + unfold LevelMap.In in H0. apply H0. apply dom. now apply mof. + Qed. + + Lemma clauses_partition_spec {cls W allW conclW} : + clauses_conclusions cls ⊂_lset W -> + Clauses.partition (premise_restricted_to W) cls = (allW, conclW) -> + (Clauses.Equal allW (cls ⇂ W)) /\ + (Clauses.Equal conclW (Clauses.diff cls (cls ⇂ W))). + Proof. + intros clW. + destruct Clauses.partition eqn:eqp. + intros [= <- <-]. + change t with (t, t0).1. + change t0 with (t, t0).2 at 2. + rewrite -eqp. clear t t0 eqp. + split. + - intros cl. rewrite Clauses.partition_spec1. + rewrite in_restrict_clauses Clauses.filter_spec. + rewrite /premise_restricted_to LevelSet.subset_spec. firstorder eauto. + apply clW, clauses_conclusions_spec. now exists cl. + - intros cl. rewrite Clauses.partition_spec2. + rewrite Clauses.filter_spec Clauses.diff_spec. + rewrite /premise_restricted_to. intuition auto. + move/negbTE: H1. eapply eq_true_false_abs. + eapply LevelSet.subset_spec. + now eapply in_restrict_clauses in H as []. + apply eq_true_not_negb. move/LevelSet.subset_spec => he. + apply H1. apply in_restrict_clauses. split => //. + apply clW, clauses_conclusions_spec. now exists cl. + Qed. + + Lemma clauses_conclusions_eq cls W : + clauses_conclusions cls ⊂_lset W -> + Clauses.Equal cls (cls ↓ W). + Proof. + intros cl x. + rewrite in_clauses_with_concl. intuition auto. + apply cl, clauses_conclusions_spec. now exists x. + Qed. + + Section innerloop_partition. + Context (W : LevelSet.t) (cls : clauses). + Context (premconclW conclW : clauses). + Context (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W, + Clauses.Equal premconclW (cls ⇂ W) & Clauses.Equal conclW (Clauses.diff (cls ↓ W) (cls ⇂ W))]). + + #[tactic="idtac"] + Equations? inner_loop_partition (m : model) (mW : total_model_of W m) : result W U cls m + by wf (measure W cls m) lt := + inner_loop_partition m mW with loop W LevelSet.empty premconclW m _ _ := { + (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) + | Loop => Loop + (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). + By invariant Wr ⊂ W *) + | Model Wr mr hsub with inspect (check_model conclW (Wr, model_model mr)) := { + | exist None eqm => Model W {| model_model := model_model mr |} _ + | exist (Some (Wconcl, mconcl)) eqm with inner_loop_partition mconcl _ := { + (* Here Wconcl ⊂ Wr by invariant *) + | Loop => Loop + | Model Wr' mr' hsub' => Model Wr' {| model_model := model_model mr' |} hsub' } + (* Here Wr' ⊂ W by invariant *) + (* We check if the new model [mr] for (cls ⇂ W) extends to a model of (cls ↓ W). *) + (* We're entitled to recursively compute a better model starting with mconcl, + as we have made the measure decrease: + some atom in W has been strictly updated in Wconcl. *) + } }. + Proof. + all:cbn [model_model]; clear loop inner_loop_partition. + all:try solve [try apply LevelSet.subset_spec; try reflexivity]. + all:try apply LevelSet.subset_spec in hsub. + all:auto. + all:try destruct prf as [WV neW UW clsW eqprem eqconcl]. + all:try solve [intuition auto]. + all:try rewrite eqconcl in eqm. + - split => //. rewrite eqprem. apply clauses_conclusions_restrict_clauses. lsets. exact mW. + - left. now eapply strict_subset_cardinal. + - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. + eapply model_of_ext. 2:tea. apply mr. + - eapply (check_model_spec_diff mr) in eqm as [subwwconcl subwconcl hm hext] => //. + pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). + destruct hm as [cll [hind nvalid inwconcl hl]]. + eapply Nat.lt_le_trans. + 2:{ eapply measure_le; eauto; try eapply mr. } + eapply measure_lt. + { eapply mr. } + { eapply model_map_outside_weaken. eapply hext. lsets. } + { apply hext. } + eapply invalid_clause_measure in nvalid; tea. + exists (levelexpr_level (concl cll)). + split => //. + eapply clauses_conclusions_diff_left; tea. + eapply clauses_conclusions_spec. exists cll; split => //. exact hind. apply mr. + - apply mr'. + (* - apply clauses_conclusions_clauses_with_concl. *) + - apply mr'. + - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. + eapply model_ext_trans_weaken. 2:apply mr. lsets. + transitivity mconcl. eapply model_extension_weaken. 2:tea. lsets. apply mr'. + - apply mr. + (* - eapply clauses_conclusions_clauses_with_concl. *) + - rewrite check_model_is_model in eqm. + 1:{ eapply model_of_diff, mr. } + have okm := (model_ok mr). + have mu := is_model_union okm eqm. + rewrite {1}eqprem in mu. + rewrite union_diff_eq in mu. + rewrite union_restrict_with_concl in mu. + now rewrite (clauses_conclusions_eq _ _ clsW). + - apply mr. + - split; lsets. + Qed. + End innerloop_partition. + + (* We first partition the clauses among those that mention only W and the ones that can mention other atoms. + We then call the loop on these two sets of clauses, which not need to change during the recursive calls. + *) + #[tactic="idtac"] + Equations? inner_loop (W : LevelSet.t) (cls : clauses) (m : model) + (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & model_of W m]) : + result W U cls m := + inner_loop W cls m prf with inspect (Clauses.partition (premise_restricted_to W) cls) := + | exist (premconclW, conclW) eqp => inner_loop_partition W cls premconclW conclW _ m _. + Proof. + - destruct prf as [subWV neW UW clsW mW]. + eapply (clauses_partition_spec clsW) in eqp as [eqprem eqconcl]. + split => //. now rewrite -(clauses_conclusions_eq _ _ clsW). + - apply prf. + Qed. + +End InnerLoop. + +Local Open Scope nat_scope. +Lemma diff_cardinal_inter V W : #|LevelSet.diff V W| = #|V| - #|LevelSet.inter V W|. +Proof. + pose proof (LevelSetProp.diff_inter_cardinal V W). lia. +Qed. + +Lemma diff_cardinal V W : W ⊂_lset V -> #|LevelSet.diff V W| = #|V| - #|W|. +Proof. + intros hsub. + rewrite diff_cardinal_inter LevelSetProp.inter_sym LevelSetProp.inter_subset_equal //. +Qed. + +Lemma is_modelP m cls : reflect (Clauses.For_all (valid_clause m) cls) (is_model cls m). +Proof. + case E: is_model; constructor. + - now move: E; rewrite /is_model -ClausesFact.for_all_iff. + - intros hf. apply ClausesFact.for_all_iff in hf; tc. unfold is_model in E; congruence. +Qed. + +Lemma is_model_invalid_clause cl cls m : is_model cls m -> ~~ valid_clause m cl -> ~ Clauses.In cl cls. +Proof. + move/is_modelP => ism /negP valid hin. + now specialize (ism _ hin). +Qed. + +Lemma strict_subset_leq_right U V W : + strict_subset U V -> V ⊂_lset W -> strict_subset U W. +Proof. + intros [] le. split. lsets. intros eq. rewrite -eq in le. + apply H0. lsets. +Qed. + +Lemma strict_subset_diff_incl V W W' : + strict_subset W' W -> + W ⊂_lset V -> + W' ⊂_lset V -> + strict_subset (LevelSet.diff V W) (LevelSet.diff V W'). +Proof. + intros [] lew lew'. + split. lsets. + intros eq. + apply H0. lsets. +Qed. + +(* To help equations *) +Opaque lexprod_rel_wf. + +Lemma check_model_spec_V {V cls w m w' m'} : + model_of V m -> clauses_conclusions cls ⊂_lset V -> + check_model cls (w, m) = Some (w', m') -> + check_model_invariants cls w m w' m' true. +Proof. + cbn; intros mof incl cm. + apply check_model_spec in cm => //. + eapply model_of_subset; tea. +Qed. + +Lemma valid_model_of {V W m cls} (m' : valid_model W m cls) : + model_of V m -> model_of V (model_model m'). +Proof. + intros mof. eapply model_of_ext; tea. eapply m'. +Qed. + +#[tactic="idtac"] +Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (m : model) + (prf : [/\ clauses_conclusions cls ⊂_lset V, U ⊂_lset V & model_of V m]) : result V U cls m + by wf (loop_measure V U) lexprod_rel := + loop V U cls m prf with inspect (check_model cls (U, m)) := + | exist None eqm => Model U {| model_model := m |} _ + | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { + | exist true eq := Loop + (* Loop on cls ↓ W, with |W| < |V| *) + | exist false neq with inner_loop V U loop W (cls ↓ W) m' _ := + { | Loop := Loop + | Model Wc mwc hsub' + (* We get a model for (cls ↓ W), we check if it extends to all clauses. + By invariant |Wc| cannot be larger than |W|. *) + with inspect (check_model cls (Wc, mwc.(model_model))) := + { | exist None eqm' => Model Wc {| model_model := mwc.(model_model) |} _ + | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { + | exist true _ := Loop + | exist false neq' with loop V Wcls cls mcls _ := { + (* Here Wcls < V, we've found a model for all of the clauses with conclusion + in W, which can now be fixed. We concentrate on the clauses whose + conclusion is different. Clearly |W| < |V|, but |Wcls| is not + necessarily < |V| *) + | Loop := Loop + | Model Wvw mcls' hsub'' := Model Wvw {| model_model := model_model mcls' |} _ } } } + } + } + . +Proof. + all:clear loop. + all:try solve [intuition auto]. + all:try eapply levelset_neq in neq. + all:have cls_sub := clauses_conclusions_levels cls. + all:destruct prf as [clsV UV mof]. + - apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. + split => //. split => //. lsets. + destruct hcl as [l [hl _]]. intros he. lsets. + apply clauses_conclusions_clauses_with_concl. + eapply model_of_ext; tea. eapply model_of_subset; tea. lsets. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply check_model_spec in eqm' as []. + 2:{ eapply model_of_subset. 2:exact clsV. + exact (valid_model_of mwc (model_of_ext mof ext)). } + split. lsets. lsets. + exact (model_of_ext (valid_model_of mwc (model_of_ext mof ext)) H2). + - right. + eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply check_model_spec in eqm' as []. + 2:{ eapply model_of_subset. 2:exact clsV. + exact (valid_model_of mwc (model_of_ext mof ext)). } + destruct hsub' as [UWc WcW]. + assert (Wcls ⊂_lset V). lsets. + rewrite -!diff_cardinal //. + eapply strict_subset_cardinal. + assert (strict_subset Wc Wcls). + { split => //. + destruct H1 as [cl [clcls nvalid hcll hv]]. + pose proof (model_ok mwc). + eapply is_model_invalid_clause in H1; tea. + assert (~ LevelSet.In (levelexpr_level (concl cl)) W). + { intros hin. rewrite in_clauses_with_concl in H1. intuition auto. } + move/(_ (levelexpr_level (concl cl))) => [] wcwcls wclswc. + now apply H4, WcW, wclswc. } + eapply (strict_subset_leq_right _ (LevelSet.diff V Wc)). + 2:{ clear -UWc WcW UW WU H3 H4. lsets. } + apply strict_subset_diff_incl => //. clear -H H3; lsets. + - eapply mcls'. + - auto. + - exact mcls'. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply check_model_spec in eqm' as []. + 2:{ eapply model_of_subset. 2:exact clsV. + exact (valid_model_of mwc (model_of_ext mof ext)). } + assert (WV : W ⊂_lset V). + { clear -UV clsV WU; lsets. } + eapply model_ext_trans_weaken => //. 2:tea. auto. + transitivity mcls; [|apply mcls']. + transitivity (model_model mwc). 2:{ eapply model_extension_weaken; [|tea]. lsets. } + eapply model_extension_weaken. 2:apply mwc. auto. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply check_model_spec in eqm' as []. + 2:{ eapply model_of_subset. 2:exact clsV. + exact (valid_model_of mwc (model_of_ext mof ext)). } + split. lsets. lsets. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + refine (valid_model_of mwc _). + refine (model_of_ext mof ext). + - auto. + - rewrite check_model_is_model // in eqm'. + eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + refine (valid_model_of mwc _). + eapply model_of_subset. + refine (model_of_ext mof ext). auto. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + transitivity m'. eapply model_extension_weaken; [|tea]. lsets. + eapply model_extension_weaken. 2:apply mwc. lsets. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + split; lsets. + - exact mof. + - exact clsV. + - apply check_model_is_model in eqm; eauto. + eapply model_of_subset; tea. + - reflexivity. + - split; lsets. +Qed. + +Transparent lexprod_rel_wf. + +Definition zero_model levels := + LevelSet.fold (fun l acc => LevelMap.add l 0 acc) levels (LevelMap.empty _). + +Definition add_max l k m := + match LevelMap.find l m with + | Some k' => + if (k' LevelMap.add l k m + end. + +#[local] Instance proper_levelexprset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) + levels. +Proof. + intros s s' eq l. + rewrite !levelexprset_levels_spec. + firstorder eauto. +Qed. + +Lemma In_add_max l l' k acc : + LevelMap.In (elt:=Z) l (add_max l' k acc) <-> + (l = l' \/ LevelMap.In l acc). +Proof. + unfold add_max. + destruct LevelMap.find eqn:hl. + case: Z.ltb_spec. + - rewrite LevelMapFact.F.add_in_iff /Level.eq. + firstorder eauto. + - intros. intuition auto. subst. + now rewrite LevelMapFact.F.in_find_iff hl. + - LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. +Qed. + +Lemma In_fold_add_max k n a : + LevelMap.In (elt:=Z) k + (LevelExprSet.fold + (fun '(l, k0) (acc : LevelMap.t Z) => add_max l (Z.of_nat k0) acc) n a) <-> + (LevelSet.In k (levels n)) \/ LevelMap.In k a. +Proof. + eapply LevelExprSetProp.fold_rec. + - intros s' he. + rewrite (LevelExprSetProp.empty_is_empty_1 he). + cbn. unfold levels. rewrite LevelExprSetProp.fold_empty. rewrite LevelSetFact.empty_iff. intuition auto. + - intros. + destruct x as [l k']. + rewrite In_add_max. + rewrite H2 !levelexprset_levels_spec. + split. + * intros []; subst. + left. exists k'. apply H1. now left. + destruct H3 as [[k'' ?]|?]. left; exists k''. apply H1. now right. + now right. + * red in H1. setoid_rewrite H1. + intros [[k'' []]|]. noconf H3. now left. + right. now left; exists k''. right; right. apply H3. +Qed. + + +(* To handle the constraint inference problem, + we must start with a model where all atoms [l + k] + appearing in premises are true. Otherwise the + [l := 0] model is minimal for [l+1-> l+2]. + Starting with [l := 1], we see that the minimal model above it + has [l := ∞]. + We also ensure that all levels in the conclusions are in the model. + + *) + +Definition min_model_map (m : LevelMap.t Z) cls : LevelMap.t Z := + Clauses.fold (fun '(cl, concl) acc => + LevelExprSet.fold (fun '(l, k) acc => + add_max l (Z.of_nat k) acc) cl (add_max (levelexpr_level concl) 0%Z acc)) cls m. + +Lemma min_model_map_levels m cls k : + LevelMap.In k (min_model_map m cls) <-> + LevelSet.In k (clauses_levels cls) \/ LevelMap.In k m. +Proof. + rewrite /min_model_map. + rewrite clauses_levels_spec. + eapply ClausesProp.fold_rec. + - intros s' he. intuition auto. + destruct H0 as [cl []]. + clsets. + - intros x a s' s'' inx ninx hadd ih. + destruct x as [cl k']. + rewrite In_fold_add_max In_add_max. rewrite ih. + intuition auto. left. exists (cl, k'); intuition auto. + apply hadd. now left. + rewrite clause_levels_spec. now left. + subst. left. exists (cl, k'). split. apply hadd; now left. + rewrite clause_levels_spec. now right. + destruct H as [cl'' []]. left. exists cl''. + intuition auto. apply hadd. now right. + destruct H3 as [cl'' []]. + apply hadd in H0 as []; subst. + rewrite clause_levels_spec in H3. destruct H3; subst. + cbn in H0. now left. right. now left. + right. right. left; exists cl''. split => //. +Qed. + +Definition min_model m cls : model := min_model_map m cls. + +Definition init_model cls := min_model (LevelMap.empty _) cls. + +Lemma init_model_levels cls k : + LevelMap.In k (init_model cls) <-> LevelSet.In k (clauses_levels cls). +Proof. + rewrite min_model_map_levels. intuition auto. + now rewrite LevelMapFact.F.empty_in_iff in H0. +Qed. + +Definition init_w (levels : LevelSet.t) : LevelSet.t := LevelSet.empty. + +(* We don't need predecessor clauses as they are trivially satisfied *) +(* Definition add_predecessors (V : LevelSet.t) cls := + LevelSet.fold (fun l acc => + Clauses.add (NonEmptySetFacts.singleton (l, 1), (l, 0)) acc) V cls. *) + +Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). + +Equations? infer (cls : clauses) : infer_result (clauses_levels cls) cls := + infer cls := loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (And3 _ _ _). +Proof. + - now eapply clauses_conclusions_levels. + - lsets. + - red. now eapply init_model_levels. +Qed. + +Local Open Scope Z_scope. +Lemma max_min max min k : min <= 0 -> max >= 0 -> k <= max -> k >= min -> (max - k - min) >= 0. +Proof. lia. Qed. + +Definition valuation_of_model (m : model) : LevelMap.t nat := + let '(min, max) := LevelMap.fold (fun l k '(min, max) => (Z.min min k, Z.max k max)) m (0, 0)%Z in + LevelMap.fold (fun l k acc => LevelMap.add l (Z.to_nat (max - k - min)) acc) m (LevelMap.empty _). +Close Scope Z_scope. + +Local Open Scope string_scope2. + +Definition print_level_Z_map (m : LevelMap.t Z) := + let list := LevelMap.elements m in + print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_Z w) nl list. + +Definition print_result {V cls} (m : infer_result V cls) := + match m return string with + | Loop => "looping" + | Model w m _ => "satisfiable with model: " ^ print_level_Z_map m.(model_model) ^ nl ^ " W = " ^ + print_lset w + ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model m.(model_model)) + end. + +Definition valuation_of_result {V cls} (m : infer_result V cls) := + match m with + | Loop => "looping" + | Model w m _ => print_level_nat_map (valuation_of_model m.(model_model)) + end. + +Definition to_string_expr (e : LevelExpr.t) : string := + let '(l, n) := e in Level.to_string l ^ (if n is 0 then "" else "+" ^ string_of_nat n). + +Definition print_premise (l : nonEmptyLevelExprSet) : string := + let (e, exprs) := NonEmptySetFacts.to_nonempty_list l in + to_string_expr e ^ + match exprs with + | [] => "" + | l => ", " ^ print_list to_string_expr ", " exprs + end. + +Definition print_clauses (cls : clauses) := + let list := Clauses.elements cls in + print_list (fun '(l, r) => + print_premise l ^ " → " ^ to_string_expr r) nl list. + +Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) + (prf : clauses_conclusions cls ⊂_lset V /\ clauses_conclusions cls' ⊂_lset V /\ model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := + | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m _. +Proof. + split. 2:lsets. + intros x. rewrite clauses_conclusions_spec. + intros [cl [hcl hl]]. + rewrite Clauses.union_spec in hcl. destruct hcl. + - apply H, clauses_conclusions_spec. exists cl => //. + - apply H0, clauses_conclusions_spec. exists cl => //. + - exact H1. +Qed. + +(* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by + setting a minimal value for the new atoms in [clauses_levels cls \ V] + such that the new clauses [cls] do not hold vacuously. +*) +Equations? infer_extension {V init cls} (m : valid_model V init cls) (cls' : clauses) : + result (LevelSet.union (clauses_levels cls') V) LevelSet.empty (Clauses.union cls cls') (min_model m.(model_model) cls') := + infer_extension m cls' := + infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model m.(model_model) cls') cls cls' _. +Proof. + repeat split. + - pose proof (model_clauses_conclusions m). lsets. + - pose proof (clauses_conclusions_levels cls'). lsets. + - red. intros. + unfold min_model. rewrite min_model_map_levels. + pose proof (model_of_V m k). + apply LevelSet.union_spec in H as []; auto. +Qed. + +Definition enforce_clauses {V init cls} (m : valid_model V init cls) cls' : option model := + match infer_extension m cls' with + | Loop => None + | Model w m _ => Some m.(model_model) + end. + +Definition enforce_clause {V init cls} (m : valid_model V init cls) cl : option model := + enforce_clauses m (Clauses.singleton cl). + +Inductive constraint_type := UnivEq | UnivLe. + +Notation constraint := (nonEmptyLevelExprSet * constraint_type * nonEmptyLevelExprSet)%type. + +Definition enforce_constraint (cstr : constraint) (cls : clauses) : clauses := + let '(l, d, r) := cstr in + match d with + | UnivLe => + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) l cls + | UnivEq => + let cls := + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) l cls + in + let cls' := + LevelExprSet.fold (fun rk acc => Clauses.add (l, rk) acc) r cls + in cls' + end. + +Definition clauses_of_list := ClausesProp.of_list. +Definition list_of_clauses := Clauses.elements. +Definition valuation := LevelMap.t nat. + +Definition premises_model_map (m : LevelMap.t Z) cls : LevelMap.t Z := + Clauses.fold (fun '(cl, concl) acc => + LevelExprSet.fold (fun '(l, k) acc => + add_max l (Z.of_nat k) acc) cl acc) cls m. + +Definition clauses_premises_levels (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls LevelSet.empty. + +Lemma clauses_premises_levels_spec_aux l cls acc : + LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls acc) <-> + (exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl))) \/ LevelSet.In l acc. +Proof. + eapply ClausesProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k [hin hl]]. clsets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.union_spec. + split. + * intros [hin'|]. + left. exists x. split => //. + apply hadd. now left. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. + * intros [[k [ins'' ?]]|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma clauses_premises_levels_spec l cls : + LevelSet.In l (clauses_premises_levels cls) <-> + exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl)). +Proof. + unfold clauses_premises_levels. + rewrite clauses_premises_levels_spec_aux. + intuition auto. lsets. +Qed. + +Lemma premises_model_map_levels m cls k : + LevelMap.In k (premises_model_map m cls) <-> + LevelSet.In k (clauses_premises_levels cls) \/ LevelMap.In k m. +Proof. + rewrite /premises_model_map. + rewrite clauses_premises_levels_spec. + eapply ClausesProp.fold_rec. + - intros s' he. intuition auto. + destruct H0 as [cl []]. + clsets. + - intros x a s' s'' inx ninx hadd ih. + destruct x as [cl k']. + rewrite In_fold_add_max ih. + intuition auto. + * left. exists (cl, k'); intuition auto. + apply hadd. now left. + * destruct H as [cl'' []]. left. exists cl''. + intuition auto. apply hadd. now right. + * destruct H3 as [cl'' []]. + apply hadd in H0 as []; subst. + now left. right. now left. +Qed. + +Definition premises_model m cls : model := premises_model_map m cls. + +Variant checking_result (cls : clauses) (cl : clause) : Type := + | DoesNotHold : ~ entails cls cl -> checking_result cls cl + | Entails : entails cls cl -> checking_result cls cl. + +Equations? check {V init cls} (m : valid_model V init cls) (cl : clause) : + checking_result cls cls := + check m cl := + infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model m.(model_model) cls') cls cls' _. +Proof. + repeat split. + - pose proof (model_clauses_conclusions m). lsets. + - pose proof (clauses_conclusions_levels cls'). lsets. + - red. intros. + unfold min_model. rewrite min_model_map_levels. + pose proof (model_of_V m k). + apply LevelSet.union_spec in H as []; auto. +Qed. + + +End LoopChecking. From b6eef8dc15167523ff0ec88c24f4ef5e64d31e70 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 23 Jul 2025 21:12:57 +0200 Subject: [PATCH 006/164] Improved semantics, correctness proof of infer --- template-rocq/theories/PartialLoopChecking.v | 854 +++++++++++++++++-- 1 file changed, 760 insertions(+), 94 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 41cc163fb..537bdd0d0 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -1433,13 +1433,12 @@ Local Open Scope Z_scope. Section MoreNonEmpty. Import LevelExprSet. - Import NonEmptySetFacts. - - Lemma In_elements {x} {s : nonEmptyLevelExprSet} : In x s <-> List.In x (elements s). + Lemma In_elements {x} {s : LevelExprSet.t} : In x s <-> List.In x (elements s). Proof. split. now move/LevelExprSetFact.elements_1/InA_In_eq. now move/InA_In_eq/LevelExprSetFact.elements_2. Qed. + Import NonEmptySetFacts. Notation min_opt := (option_map2 Z.min). Lemma Zmin_opt_left x y : min_opt x y ≤ x. @@ -1635,6 +1634,13 @@ Proof. - depelim amin. rewrite H in hprem. depelim hprem. Qed. +Lemma min_premise_pos_spec_inv {m} {prem: nonEmptyLevelExprSet} : + (forall x, LevelExprSet.In x prem -> exists k, levelexpr_value m x = Some k) -> + exists k, min_premise m prem = Some k. +Proof. + intros hprem. +Admitted. + Definition equal_model (m m' : model) := LevelMap.Equal m m'. #[local] Instance equal_model_equiv : Equivalence equal_model. @@ -1743,6 +1749,9 @@ Proof. now etransitivity; tea. Qed. +Definition total_model_of V (m : model) := + forall k, LevelSet.In k V -> exists x, LevelMap.MapsTo k (Some x) m. + Definition check_model_invariants cls w m w' m' (modified : bool) := if modified then [/\ w ⊂_lset w', @@ -1751,9 +1760,10 @@ Definition check_model_invariants cls w m w' m' (modified : bool) := let cll := (levelexpr_level (concl cl)) in [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' & - opt_le Z.lt (level_value m cll) (level_value m' cll)] & - model_extension w' m m'] - else (w, m) = (w', m'). + opt_le Z.lt (level_value m cll) (level_value m' cll)], + model_extension w' m m' & + total_model_of w' m'] + else (w, m) = (w', m') /\ total_model_of w m. #[local] Instance clauses_conclusions_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_conclusions. Proof. @@ -1771,6 +1781,11 @@ Proof. repeat intro. split; intros []; split; intuition auto. Qed. +#[local] Instance And5P_proper : Proper (iff ==> iff ==> iff ==> iff ==> iff ==> iff) ssrbool.and5. +Proof. + repeat intro. split; intros []; split; intuition auto. +Qed. + #[local] Instance check_model_invariants_proper : Proper (Clauses.Equal ==> eq ==> eq ==> eq ==> eq ==> eq ==> iff) check_model_invariants. Proof. @@ -1834,6 +1849,18 @@ Proof. unfold level_value_above; destruct level_value => // hlt; constructor. lia. Qed. +Lemma total_model_of_update w m l k : total_model_of w m -> total_model_of (LevelSet.add l w) (update_model m l k). +Proof. + rewrite /total_model_of => hint l'. rewrite LevelSet.add_spec. + intros [->|hadd]. + - exists k. now apply LevelMap.add_1. + - specialize (hint _ hadd). unfold update_model. + destruct hint as [x hx]. + destruct (eqb_spec l l'). subst. + now exists k; apply LevelMap.add_1. + now exists x; eapply LevelMap.add_2. +Qed. + Lemma check_clause_model_modify' {cl cls w m w' m' w'' m'' modified modified'} : check_model_invariants cls w m w' m' modified -> declared_model_level m (clause_conclusion cl) -> @@ -1844,14 +1871,14 @@ Proof. unfold check_clause_model. destruct (update_value (w', m') cl) eqn:upd. * intros [= <- <-]. subst. - destruct modified. 2:{ noconf inv. reflexivity. } + destruct modified. 2:{ cbn in inv |- *. intuition. } destruct inv. split => //. + rewrite clauses_conclusions_add; lsets. + destruct H1 as [cl' []]. exists cl'; split => //. now rewrite Clauses.add_spec. * intros [= <- <-]. subst. - destruct modified. 2:{ noconf inv. reflexivity. } + destruct modified. 2:{ cbn in inv |- *; intuition. } destruct inv. split => //. + rewrite clauses_conclusions_add; lsets. @@ -1870,7 +1897,7 @@ Proof. + lsets. + rewrite clauses_conclusions_add. intros x. rewrite LevelSet.add_spec !LevelSet.union_spec LevelSet.singleton_spec. - intuition eauto. cbn. apply H0 in H4. lsets. + intuition eauto. cbn. apply H0 in H5. lsets. + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. destruct H1 as [cl []]; exists cl; split => //. eauto. eauto. destruct (level_value m (concl cl)) as [vconcl|] eqn:hconcl; [|constructor]. @@ -1883,8 +1910,9 @@ Proof. { now eapply update_model_not_above. } { eapply update_model_same_domain. eapply H2, declcl. } - { eapply update_model_outside. } } - { split => //. + { eapply update_model_outside. } + + now eapply total_model_of_update. } + { destruct inv as [inv htot]; noconf inv. split => //. + lsets. + rewrite clauses_conclusions_add. intros x. rewrite LevelSet.add_spec !LevelSet.union_spec LevelSet.singleton_spec. @@ -1898,7 +1926,8 @@ Proof. { now eapply update_model_not_above. } { eapply update_model_same_domain. eapply declcl. } - { eapply update_model_outside. } } + { eapply update_model_outside. } + + now eapply total_model_of_update. } Qed. Definition model_of V (m : model) := @@ -1911,9 +1940,6 @@ Proof. now move/hv. Qed. -Definition total_model_of V (m : model) := - forall k, LevelSet.In k V -> exists x, LevelMap.MapsTo k (Some x) m. - Lemma total_model_of_subset V V' m : total_model_of V m -> V' ⊂_lset V -> total_model_of V' m. Proof. @@ -1939,21 +1965,22 @@ Qed. Lemma check_model_aux_spec {cls w m w' m' modified} : model_of (clauses_conclusions cls) m -> + total_model_of w m -> check_model_aux cls (w, m) = (modified, (w', m')) -> check_model_invariants cls w m w' m' modified. Proof. rewrite /check_model_aux /is_model. revert modified w' m'. eapply ClausesProp.fold_rec. - - intros s' e modified w' m' mof [= <- <- <-]. - split. - - intros x ? s' s'' inx nins' hadd ih modified w' m' mof. + - intros s' e modified w' m' mof tot [= <- <- <-]. + split => //. + - intros x ? s' s'' inx nins' hadd ih modified w' m' mof tot. destruct a as [modified'' [w'' m'']]. assert (ms' : model_of (clauses_conclusions s') m). { eapply model_of_subset; tea. eapply clauses_conclusions_subset. red in hadd. intros ?. specialize (hadd a). intuition auto. } - specialize (ih _ _ _ ms' eq_refl). + specialize (ih _ _ _ ms' tot eq_refl). apply ClausesProp.Add_Equal in hadd. rewrite hadd. eapply check_clause_model_modify' => //. red. apply mof. @@ -1963,10 +1990,11 @@ Qed. Lemma check_model_spec {cls w m w' m'} : model_of (clauses_conclusions cls) m -> + total_model_of w m -> check_model cls (w, m) = Some (w', m') -> check_model_invariants cls w m w' m' true. Proof. - intros mof. + intros mof tot. unfold check_model. destruct check_model_aux eqn:cm. destruct p as []. @@ -1976,11 +2004,12 @@ Qed. Lemma check_model_aux_not_model {cls w m w' m'} : model_of (clauses_conclusions cls) m -> + total_model_of w m -> check_model_aux cls (w, m) = (true, (w', m')) -> ~~ is_model cls m. Proof. - intros mof. - move/(check_model_aux_spec mof) => [] _ _ [cl [incl inval]] _ _ _. + intros mof tot. + move/(check_model_aux_spec mof tot) => [] _ _ [cl [incl inval]] _ _ _ tot'. unfold is_model. apply clauses_for_all_neg. intros hf. specialize (hf cl incl). cbn in hf. @@ -1989,9 +2018,10 @@ Qed. Lemma check_model_is_model {W cls m} : model_of (clauses_conclusions cls) m -> + total_model_of W m -> check_model cls (W, m) = None <-> is_model cls m. Proof. - intros mof; unfold check_model, is_model. + intros mof tot; unfold check_model, is_model. destruct check_model_aux eqn:caux. destruct b => //. intuition auto. congruence. { destruct p; eapply check_model_aux_not_model in caux => //. @@ -2003,9 +2033,10 @@ Qed. Lemma check_model_update {W cls m wm'} : model_of (clauses_conclusions cls) m -> + total_model_of W m -> check_model cls (W, m) = Some wm' -> ~~ is_model cls m /\ m ⩽ wm'.2. Proof. - intros mof; unfold check_model, is_model. + intros mof tot; unfold check_model, is_model. destruct check_model_aux eqn:caux. destruct b => //. intros [= <-]. intuition auto. destruct p. @@ -2251,18 +2282,20 @@ Proof. now subst wm'; rewrite eq. Qed. -Record valid_model_def (V : LevelSet.t) (m : model) (cls : clauses) := +Record valid_model_def (V W : LevelSet.t) (m : model) (cls : clauses) := { model_model : model; model_of_V :> model_of V model_model; + model_of_W : total_model_of W model_model; model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; model_ok :> is_model cls model_model; model_extends : model_extension V m model_model; }. -Arguments model_model {V m cls}. -Arguments model_of_V {V m cls}. -Arguments model_clauses_conclusions {V m cls}. -Arguments model_ok {V m cls}. -Arguments model_extends {V m cls}. +Arguments model_model {V W m cls}. +Arguments model_of_V {V W m cls}. +Arguments model_of_W {V W m cls}. +Arguments model_clauses_conclusions {V W m cls}. +Arguments model_ok {V W m cls}. +Arguments model_extends {V W m cls}. Extraction Inline model_model. Definition valid_model := valid_model_def. @@ -2275,8 +2308,8 @@ Inductive entails (cls : clauses) : clause -> Prop := LevelExprSet.Subset prems' prems -> entails cls (prems, concl). -(* Definition succ_expr '((l, k) : LevelExpr.t) := (l, k + 1). -Definition succ_prems s := map (fun '(l, k) => (l, k + 1)) s. +Definition succ_expr '((l, k) : LevelExpr.t) := (l, k + 1)%nat. +Definition succ_prems s := map succ_expr s. Definition succ_clause '((prems, concl) : clause) := (succ_prems prems, succ_expr concl). Lemma succ_clause_inj x y : succ_clause x = succ_clause y -> x = y. Proof. Admitted. @@ -2307,7 +2340,7 @@ Definition to_clauses (prems : nonEmptyLevelExprSet) (concl : nonEmptyLevelExprS Definition is_loop (cls : clauses) (t : nonEmptyLevelExprSet) := let cls' := to_clauses t (succ_prems t) in Clauses.For_all (fun cl' => entails cls cl') cls'. - *) + (* Definition is_looping (w : LevelSet.t) n (cls : clauses) := let preml := LevelSet.elements w in let prem := List.map (fun e => (e, n)) preml in @@ -2316,7 +2349,7 @@ Definition is_loop (cls : clauses) (t : nonEmptyLevelExprSet) := Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := | Loop (* (w : LevelSet.t) (n : nat) (islooping : loop_on w n cls) *) - | Model (w : LevelSet.t) (m : valid_model V m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). + | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). Arguments Loop {V U cls m}. Arguments Model {V U cls m}. Arguments lexprod {A B}. @@ -2370,7 +2403,7 @@ Defined. Section InnerLoop. Context (V : LevelSet.t) (U : LevelSet.t) (loop : forall (V' U' : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V', U' ⊂_lset V' & model_of V' m]), + (prf : [/\ clauses_conclusions cls ⊂_lset V', U' ⊂_lset V', model_of V' m & total_model_of U' m]), lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls m). Definition sum_W W (f : LevelSet.elt -> nat) : nat := @@ -2628,6 +2661,7 @@ Section InnerLoop. Lemma check_model_spec_diff {cls w m w' m' w''} : model_of w m -> + total_model_of w'' m -> let cls := (cls_diff cls w) in check_model cls (w'', m) = Some (w', m') -> [/\ w'' ⊂_lset w', w' ⊂_lset (w'' ∪ w), @@ -2637,11 +2671,11 @@ Section InnerLoop. & (opt_le Z.lt (level_value m cll) (level_value m' cll))%Z] & model_extension w' m m']. Proof. - cbn; intros mof cm. + cbn; intros mof tot cm. pose proof (clauses_conclusions_diff_left cls w (cls ⇂ w)). apply check_model_spec in cm as []. split => //. lsets. - eapply model_of_subset; tea. + eapply model_of_subset; tea. exact tot. Qed. Lemma model_of_ext {W W' m m'} : @@ -2654,9 +2688,8 @@ Section InnerLoop. Lemma total_model_of_ext {W W' m m'} : total_model_of W m -> model_extension W' m m' -> total_model_of W m'. Proof. - intros mof [_ dom _]. - intros k hin. destruct (mof k hin). destruct (dom k). - unfold LevelMap.In in H0. apply H0. apply dom. now apply mof. + intros mof [ext _ _]. + intros k hin. destruct (mof k hin). specialize (ext _ _ H) as [k' []]. depelim H1. now exists y. Qed. Lemma clauses_partition_spec {cls W allW conclW} : @@ -2696,6 +2729,12 @@ Section InnerLoop. apply cl, clauses_conclusions_spec. now exists x. Qed. + Lemma valid_model_total W W' m cls : + forall vm : valid_model W W' m cls, total_model_of W m -> total_model_of W (model_model vm). + Proof. + intros []; cbn => htot. eapply total_model_of_ext; tea. + Qed. + Section innerloop_partition. Context (W : LevelSet.t) (cls : clauses). Context (premconclW conclW : clauses). @@ -2731,33 +2770,42 @@ Section InnerLoop. all:try solve [intuition auto]. all:try rewrite eqconcl in eqm. - split => //. rewrite eqprem. apply clauses_conclusions_restrict_clauses. lsets. exact mW. + intros k. now rewrite LevelSetFact.empty_iff. - left. now eapply strict_subset_cardinal. - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. - eapply model_of_ext. 2:tea. apply mr. + eapply total_model_of_ext. 2:tea. pose proof (model_extends mr). + eapply total_model_of_ext; tea. + destruct hsub. eapply total_model_of_subset; tea. + eapply valid_model_total; tea. - eapply (check_model_spec_diff mr) in eqm as [subwwconcl subwconcl hm hext] => //. pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). destruct hm as [cll [hind nvalid inwconcl hl]]. eapply Nat.lt_le_trans. 2:{ eapply measure_le; eauto; try eapply mr. } eapply measure_lt. - { eapply mr. } + { eapply valid_model_total; tea. } { eapply model_map_outside_weaken. eapply hext. lsets. } { apply hext. } eapply invalid_clause_measure in nvalid; tea. exists (levelexpr_level (concl cll)). split => //. eapply clauses_conclusions_diff_left; tea. - eapply clauses_conclusions_spec. exists cll; split => //. exact hind. apply mr. + eapply clauses_conclusions_spec. exists cll; split => //. exact hind. + { eapply valid_model_total; tea. } + destruct hsub. eapply total_model_of_subset; tea. + { eapply valid_model_total; tea. } - apply mr'. (* - apply clauses_conclusions_clauses_with_concl. *) - apply mr'. - - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. + - apply mr'. + - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. 2:apply mr. eapply model_ext_trans_weaken. 2:apply mr. lsets. transitivity mconcl. eapply model_extension_weaken. 2:tea. lsets. apply mr'. - apply mr. - (* - eapply clauses_conclusions_clauses_with_concl. *) + - now eapply valid_model_total. - rewrite check_model_is_model in eqm. - 1:{ eapply model_of_diff, mr. } + 1:{ eapply model_of_diff. apply mr. } + apply mr. have okm := (model_ok mr). have mu := is_model_union okm eqm. rewrite {1}eqprem in mu. @@ -2774,7 +2822,7 @@ Section InnerLoop. *) #[tactic="idtac"] Equations? inner_loop (W : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & model_of W m]) : + (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & total_model_of W m]) : result W U cls m := inner_loop W cls m prf with inspect (Clauses.partition (premise_restricted_to W) cls) := | exist (premconclW, conclW) eqp => inner_loop_partition W cls premconclW conclW _ m _. @@ -2836,15 +2884,16 @@ Opaque lexprod_rel_wf. Lemma check_model_spec_V {V cls w m w' m'} : model_of V m -> clauses_conclusions cls ⊂_lset V -> + total_model_of w m -> check_model cls (w, m) = Some (w', m') -> check_model_invariants cls w m w' m' true. Proof. - cbn; intros mof incl cm. + cbn; intros mof incl tot cm. apply check_model_spec in cm => //. eapply model_of_subset; tea. Qed. -Lemma valid_model_of {V W m cls} (m' : valid_model W m cls) : +Lemma valid_model_of {V W W' m cls} (m' : valid_model W W' m cls) : model_of V m -> model_of V (model_model m'). Proof. intros mof. eapply model_of_ext; tea. eapply m'. @@ -2852,7 +2901,7 @@ Qed. #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V, U ⊂_lset V & model_of V m]) : result V U cls m + (prf : [/\ clauses_conclusions cls ⊂_lset V, U ⊂_lset V, model_of V m & total_model_of U m]) : result V U cls m by wf (loop_measure V U) lexprod_rel := loop V U cls m prf with inspect (check_model cls (U, m)) := | exist None eqm => Model U {| model_model := m |} _ @@ -2888,15 +2937,16 @@ Proof. split => //. split => //. lsets. destruct hcl as [l [hl _]]. intros he. lsets. apply clauses_conclusions_clauses_with_concl. - eapply model_of_ext; tea. eapply model_of_subset; tea. lsets. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. eapply check_model_spec in eqm' as []. 2:{ eapply model_of_subset. 2:exact clsV. exact (valid_model_of mwc (model_of_ext mof ext)). } - split. lsets. lsets. - exact (model_of_ext (valid_model_of mwc (model_of_ext mof ext)) H2). + split => //. lsets. + exact (model_of_ext (valid_model_of mwc (model_of_ext mof ext)) H4) => //. + eapply total_model_of_subset; [|apply hsub']. + eapply valid_model_total; tea. - right. - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. eapply check_model_spec in eqm' as []. 2:{ eapply model_of_subset. 2:exact clsV. exact (valid_model_of mwc (model_of_ext mof ext)). } @@ -2906,20 +2956,22 @@ Proof. eapply strict_subset_cardinal. assert (strict_subset Wc Wcls). { split => //. - destruct H1 as [cl [clcls nvalid hcll hv]]. + destruct H3 as [cl [clcls nvalid hcll hv]]. pose proof (model_ok mwc). - eapply is_model_invalid_clause in H1; tea. + eapply is_model_invalid_clause in H3; tea. assert (~ LevelSet.In (levelexpr_level (concl cl)) W). - { intros hin. rewrite in_clauses_with_concl in H1. intuition auto. } + { intros hin. rewrite in_clauses_with_concl in H3. intuition auto. } move/(_ (levelexpr_level (concl cl))) => [] wcwcls wclswc. - now apply H4, WcW, wclswc. } + now apply H7, WcW, wclswc. } eapply (strict_subset_leq_right _ (LevelSet.diff V Wc)). 2:{ clear -UWc WcW UW WU H3 H4. lsets. } - apply strict_subset_diff_incl => //. clear -H H3; lsets. + apply strict_subset_diff_incl => //. clear -H1 H6; lsets. + eapply total_model_of_subset; [|apply hsub']. eapply valid_model_total; tea. - eapply mcls'. + - apply mcls'. - auto. - exact mcls'. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. eapply check_model_spec in eqm' as []. 2:{ eapply model_of_subset. 2:exact clsV. exact (valid_model_of mwc (model_of_ext mof ext)). } @@ -2929,26 +2981,30 @@ Proof. transitivity mcls; [|apply mcls']. transitivity (model_model mwc). 2:{ eapply model_extension_weaken; [|tea]. lsets. } eapply model_extension_weaken. 2:apply mwc. auto. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply total_model_of_subset; [|apply hsub']. eapply valid_model_total; tea. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. eapply check_model_spec in eqm' as []. 2:{ eapply model_of_subset. 2:exact clsV. exact (valid_model_of mwc (model_of_ext mof ext)). } - split. lsets. lsets. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + split. 1-2:clear -hsub' hsub'' UV H1; lsets. + eapply total_model_of_subset; [|apply hsub']; apply valid_model_total; tea. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. refine (valid_model_of mwc _). refine (model_of_ext mof ext). + - apply mwc. - auto. - rewrite check_model_is_model // in eqm'. - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. refine (valid_model_of mwc _). eapply model_of_subset. - refine (model_of_ext mof ext). auto. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + refine (model_of_ext mof ext). auto. apply mwc. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. transitivity m'. eapply model_extension_weaken; [|tea]. lsets. eapply model_extension_weaken. 2:apply mwc. lsets. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. + - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. split; lsets. - exact mof. + - exact H. - exact clsV. - apply check_model_is_model in eqm; eauto. eapply model_of_subset; tea. @@ -2959,14 +3015,14 @@ Qed. Transparent lexprod_rel_wf. Definition zero_model levels := - LevelSet.fold (fun l acc => LevelMap.add l 0 acc) levels (LevelMap.empty _). + LevelSet.fold (fun l acc => LevelMap.add l (Some 0%Z) acc) levels (LevelMap.empty _). Definition add_max l k m := match LevelMap.find l m with - | Some k' => - if (k' + if (k' LevelMap.add l k m + | _ => LevelMap.add l (Some k) m end. #[local] Instance proper_levelexprset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) @@ -2978,23 +3034,154 @@ Proof. Qed. Lemma In_add_max l l' k acc : - LevelMap.In (elt:=Z) l (add_max l' k acc) <-> + LevelMap.In (elt:=option Z) l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). Proof. unfold add_max. destruct LevelMap.find eqn:hl. - case: Z.ltb_spec. + destruct o. + { case: Z.ltb_spec. - rewrite LevelMapFact.F.add_in_iff /Level.eq. firstorder eauto. - intros. intuition auto. subst. - now rewrite LevelMapFact.F.in_find_iff hl. - - LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. + now rewrite LevelMapFact.F.in_find_iff hl. } + { LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. } + { LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. } Qed. +Definition is_max k' k l acc := + match LevelMap.find l acc with + | Some (Some k'') => k' = Some (Z.max k k'') + | _ => k' = Some k + end. + +Lemma MapsTo_add_max l l' k k' acc : + LevelMap.MapsTo (elt:=option Z) l k' (add_max l' k acc) <-> + if eqb l l' then is_max k' k l acc else LevelMap.MapsTo l k' acc. +Proof. + unfold add_max. + destruct LevelMap.find eqn:hl. + destruct o. + { case: Z.ltb_spec. + - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. + destruct (eqb_spec l l'). + { unfold is_max. + firstorder eauto. subst k' l'. rewrite hl. f_equal. lia. congruence. subst l'. + rewrite hl in H0. subst k'. + left. split; auto. f_equal; lia. } + intros. firstorder eauto. congruence. + - intros. unfold is_max. + destruct (eqb_spec l l'); subst. rewrite hl. firstorder eauto. apply LevelMap.find_1 in H. rewrite hl in H. noconf H. + f_equal; lia. subst k'. apply LevelMap.find_2. rewrite hl. f_equal. f_equal. lia. reflexivity. + } + - rewrite LevelMapFact.F.add_mapsto_iff. intuition auto; subst. + destruct (eqb_spec l l'); subst. unfold is_max. now rewrite hl. congruence. + destruct (eqb_spec l l'); subst. unfold is_max. now rewrite hl. congruence. + destruct (eqb_spec l l'); subst. unfold is_max in H; rewrite hl in H. subst k'. left; intuition eauto. reflexivity. + right. intuition eauto. + - rewrite LevelMapFact.F.add_mapsto_iff. intuition auto; subst. + destruct (eqb_spec l l'); subst. unfold is_max. now rewrite hl. congruence. + destruct (eqb_spec l l'); subst. unfold is_max. now rewrite hl. congruence. + destruct (eqb_spec l l'); subst. unfold is_max in H. rewrite hl in H; subst. + left; intuition auto. reflexivity. + right. intuition auto. +Qed. + +Definition opt_max (x y : option nat) : option nat := + match x, y with + | Some x, Some y => Some (Nat.max x y) + | None, Some x => Some x + | Some x, None => Some x + | None, None => None + end. + +Definition find_max (ls : LevelExprSet.t) (l : Level.t) := + LevelExprSet.fold (fun '(l', k) acc => if eqb l l' then opt_max (Some k) acc else acc) ls None. + +Inductive find_max_spec ls l : option nat -> Prop := +| find_max_ex m : LevelExprSet.In (l, m) ls -> (forall k, LevelExprSet.In (l, k) ls -> k <= m) -> find_max_spec ls l (Some m) +| find_max_absent : ~ (exists k, LevelExprSet.In (l, k) ls) -> find_max_spec ls l None. + +Lemma find_max_correct ls l : find_max_spec ls l (find_max ls l). +Proof. + unfold find_max. + apply: (LevelExprSetProp.fold_rec (P := fun ls a => find_max_spec ls l a)). + - intros s' ise; constructor. intros [k hin]. now apply ise in hin. + - intros x a s' s'' hin hnotin hadd hspec. + destruct x as [l' k]. + destruct (eqb_spec l l'); subst. + * depelim hspec. + { constructor. destruct (Nat.max_spec k m) as [[hle hm]|[hle hm]]. + + rewrite hm. apply hadd; right; apply H. + + rewrite hm. apply hadd; left; reflexivity. + + intros k' hin'. apply hadd in hin' as []. + { noconf H1. lia. } + { specialize (H0 _ H1). lia. } } + { constructor. apply hadd; now left. + intros k0 hin'. apply hadd in hin' as []. + { noconf H0; reflexivity. } + { elim H. now exists k0. } } + * depelim hspec; constructor; eauto. + + apply hadd; now right. + + intros k' hin'. apply hadd in hin' as []. + { noconf H2. congruence. } + now apply H0 in H2. + + intros [k0 hk0]. apply hadd in hk0 as []. + { noconf H1; congruence. } + apply H. now exists k0. +Qed. + +Definition update_max acc l k0 := + option_map2 Z.max (level_value acc l) (Some (Z.of_nat k0)). + +(* Lemma update_max_spec acc l k : update_max acc l k0 = *) + +Definition add_max_list l acc := + List.fold_right (fun '(l, k0) acc => + LevelMap.add l (update_max acc l k0) acc) acc l. + +Definition maximal_pre (l : Level.t) (n : nat) les := + forall n', In (l, n') les -> n' <= n. + +Definition maximal_map (l : Level.t) (n : nat) m := + forall n', LevelMap.MapsTo l (Some n') m -> (n' <= Z.of_nat n)%Z. +(* +Lemma In_fold_add_max l k les a : + let map := add_max_list les a in + LevelMap.MapsTo (elt:=option Z) l k map <-> + ((exists kl, In (l, kl) les /\ Some (Z.of_nat kl) = k + /\ maximal_pre l kl les /\ maximal_map l kl a) \/ + (LevelMap.MapsTo l k a /\ (match k with Some k' => maximal_pre l (Z.to_nat k') les | None => True end))). +Proof. + cbn; intros. + unfold add_max_list. + induction les in a |- *. + - cbn. admit. + - cbn. destruct a0. + rewrite LevelMapFact.F.add_mapsto_iff. intuition auto. + { red in H; subst k0. } + + +Lemma In_fold_add_max l k les a : + let map := add_max_list les a in + LevelMap.MapsTo (elt:=option Z) l k map <-> + ((exists kl, In (l, kl) les /\ Some (Z.of_nat kl) = k + /\ maximal_pre l kl les /\ maximal_map l kl a) \/ + (LevelMap.MapsTo l k a /\ (match k with Some k' => maximal_pre l (Z.to_nat k') les | None => True end))). +Proof. + cbn. unfold add_max_list. + induction les in a |- *; cbn. admit. + cbn. destruct a0. + rewrite MapsTo_add_max. + destruct (eqb_spec l k0). subst. + + +*) + Lemma In_fold_add_max k n a : - LevelMap.In (elt:=Z) k + LevelMap.In (elt:=option Z) k (LevelExprSet.fold - (fun '(l, k0) (acc : LevelMap.t Z) => add_max l (Z.of_nat k0) acc) n a) <-> + (fun '(l, k0) acc => add_max l (Z.of_nat k0) acc) n a) <-> (LevelSet.In k (levels n)) \/ LevelMap.In k a. Proof. eapply LevelExprSetProp.fold_rec. @@ -3016,6 +3203,87 @@ Proof. Qed. +Lemma MapsTo_fold_add_max l n a : + let map := LevelExprSet.fold (fun '(l, k0) acc => add_max l (Z.of_nat k0) acc) n a in + (forall k, LevelMap.MapsTo (elt:=option Z) l k map -> + ((exists kl, LevelExprSet.In (l, kl) n /\ Some (Z.of_nat kl) = k /\ + (forall kl', LevelExprSet.In (l, kl') n -> kl' <= kl) /\ + (forall kl', LevelMap.MapsTo l kl' a -> kl' ≤ Some (Z.of_nat kl))) \/ + (LevelMap.MapsTo l k a /\ (forall kl', LevelExprSet.In (l, kl') n -> Some (Z.of_nat kl') ≤ k)))) + /\ (forall l, ~ LevelMap.In l map -> ~ (exists k, LevelExprSet.In (l, k) n) /\ ~ (LevelMap.In l a)). +Proof. + eapply LevelExprSetProp.fold_rec. + - intros s' he. cbn. + setoid_rewrite (LevelExprSetProp.empty_is_empty_1 he). + intuition auto. right. split; eauto. + intros kl. now move/LevelExprSet.empty_spec. + destruct H0. now apply LevelExprSet.empty_spec in H0. + (* destruct H0 as [? [he' _]]. now rewrite LevelExprSetFact.empty_iff in he'. *) + - cbn; intros. + destruct x as [xl k']. split. + 2:{ intros l0 hnin. destruct H2 as [_ H2]. specialize (H2 l0). split. + { intros [k hex]. eapply H1 in hex as [hin|hin]. noconf hin. apply hnin. + eapply In_add_max. now left. + unshelve eapply (proj1 (H2 _)). + intros hin'. apply hnin. rewrite In_add_max. now right. now exists k. } + { apply H2 => hin. elim hnin. rewrite In_add_max. now right. } } + intros. + rewrite MapsTo_add_max in H3. + destruct (eqb_spec l xl); subst. + * unfold is_max in H3 at 1. + destruct LevelMap.find eqn:hfind. + { destruct o. + - subst k. pose proof (LevelMap.find_2 hfind). destruct H2 as [H2 Hnotin]. destruct (H2 _ H3). + left. destruct H4 as [kl [hkl hleq]]. destruct hleq as [hleq hmax]. + noconf hleq. destruct (Z.max_spec (Z.of_nat k') (Z.of_nat kl)) as [[]|[]]. + { exists kl. split. apply H1. now right. split. f_equal. lia. split. intros. + apply H1 in H6 as []. noconf H6. lia. now apply hmax. destruct hmax as [_ hmax]. + intros. now apply hmax. } + { exists k'. split. apply H1. now left. split. f_equal; lia. destruct hmax as [hmax hmax']; split. + intros kl' hin. apply H1 in hin as []; subst. noconf H6. lia. specialize (hmax _ H6). lia. + intros. transitivity (Some (Z.of_nat kl)). now apply hmax'. constructor; lia. } + destruct (H2 _ H3) as [[kl [hkl hleq]]|]. noconf hleq. + destruct hleq as [hleq hmax]. noconf hleq. + destruct (Z.max_spec (Z.of_nat k') (Z.of_nat kl)) as [[]|[]]. + { left. exists kl. split. apply H1. now right. destruct hmax as [hmax hmax']. split. f_equal. lia. split. + intros. apply H1 in H7 as []. noconf H7. lia. now apply hmax. apply hmax'. } + { left. exists k'. split. apply H1. now left. destruct hmax as [hmax hmax']. split. f_equal. lia. split. + intros kl' hin. apply H1 in hin as []. noconf H7. lia. specialize (hmax _ H7). lia. + intros. transitivity (Some (Z.of_nat kl)) => //. 2:constructor; lia. now eapply hmax'. } + destruct H4. clear H5. + destruct (Z.max_spec (Z.of_nat k') z) as [[]|[]]. + { right. split. now rewrite H7. + intros kl' hin. apply H1 in hin as [hin|hin]; noconf hin. constructor; lia. + specialize (H6 _ hin). depelim H6; constructor; lia. } + { left. exists k'. split. apply H1. now left. split. f_equal. lia. split. + intros kl' hin. apply H1 in hin as []. noconf H8. lia. + specialize (H6 _ H8). depelim H6. lia. + intros. transitivity (Some z). 2:constructor; lia. eapply (LevelMapFact.F.MapsTo_fun H4) in H8. subst kl'. reflexivity. } + - eapply LevelMap.find_2 in hfind. destruct H2 as [H2 hnotin]. specialize (H2 _ hfind) as []. + subst k. destruct H2 as [kl [? []]]. congruence. + destruct H2. subst k. + left. exists k'. split; eauto. firstorder. split; eauto. split. + { intros. eapply H1 in H3 as [hin|hin]; noconf hin. lia. + specialize (H4 _ hin). depelim H4. } + { intros kl' hin. apply (LevelMapFact.F.MapsTo_fun H2) in hin. subst; constructor. } } + subst k. left. exists k'. split; eauto. firstorder. split. reflexivity. + destruct H2 as [hl hnotin]. eapply LevelMapFact.F.not_find_in_iff in hfind. + apply hnotin in hfind as hfind'. + split. + { intros. eapply H1 in H2 as [hin|hin]; noconf hin. reflexivity. + destruct hfind' as [hfind' _]. + elim hfind'. now exists kl'. } + { intros kl' hin. destruct hfind' as []. now elim H3; exists kl'. } + * destruct H2 as [H2 hfind]. destruct (H2 _ H3) as [[lk [hkl hleq]]|]. + + left. depelim hleq. destruct H6 as [hinl hinacc]. exists lk. split; [firstorder|]. split => //. + split => //. + { intros kl' hin. apply H1 in hin as [hin|hin]. noconf hin. congruence. subst k. now apply hinl. } + + right. intuition auto. + eapply H1 in H5 as [hin|hin]; noconf hin. congruence. + now eapply H7. +Qed. + + (* To handle the constraint inference problem, we must start with a model where all atoms [l + k] appearing in premises are true. Otherwise the @@ -3023,10 +3291,9 @@ Qed. Starting with [l := 1], we see that the minimal model above it has [l := ∞]. We also ensure that all levels in the conclusions are in the model. - *) -Definition min_model_map (m : LevelMap.t Z) cls : LevelMap.t Z := +Definition min_model_map (m : LevelMap.t (option Z)) cls : LevelMap.t (option Z) := Clauses.fold (fun '(cl, concl) acc => LevelExprSet.fold (fun '(l, k) acc => add_max l (Z.of_nat k) acc) cl (add_max (levelexpr_level concl) 0%Z acc)) cls m. @@ -3058,6 +3325,66 @@ Proof. right. right. left; exists cl''. split => //. Qed. +Definition maximal_prem l n cls := + Clauses.For_all (fun cl => forall n', LevelExprSet.In (l, n') (premise cl) -> n' <= n) cls. + +Lemma min_model_mapsto_gen m cls : + forall l, LevelSet.In l (clauses_levels cls) -> + exists k, LevelMap.MapsTo l (Some k) (min_model_map m cls) /\ + (exists cl, Clauses.In cl cls /\ + exists n, k = Z.of_nat n /\ LevelExprSet.In (l,n) (premise cl) /\ + (* (forall cl', Clauses.In cl cls -> forall l k, LevelExprSet.In (l, k) (premise cl') -> k <= n) *) + maximal_prem l n cls) \/ LevelMap.MapsTo l (Some k) m. +Proof. + rewrite /min_model_map. + eapply ClausesProp.fold_rec. + - intros s' he. intuition auto. admit. + - intros x a s' s'' inx ninx hadd ih. + destruct x as [prem cl]. + intros. + Admitted. +(* + pose proof (MapsTo_fold_add_max l prem (add_max cl 0 a)) as [hf hneq]. + apply hf in H. clear hf. + destruct H as [[kl [inkl leq]]|]. + { destruct leq as [eq [leqprems leqacc]]; noconf eq. + destruct (Nat.ltb_spec kl ) + left. exists (prem, cl). split. apply hadd. now left. exists kl. + split => //. split => //. red. + intros x hin. apply hadd in hin as []; subst. cbn. exact leqprems. + intros n hin. + specialize (ih (Z.of_nat n)). destruct ih as [_ ih]. + forward ih. left. exists x. split => //. exists kl. split => //. + intros n' hin. + rewrite In_fold_add_max In_add_max. rewrite ih. + intuition auto. left. exists (cl, k'); intuition auto. + apply hadd. now left. + rewrite clause_levels_spec. now left. + subst. left. exists (cl, k'). split. apply hadd; now left. + rewrite clause_levels_spec. now right. + destruct H as [cl'' []]. left. exists cl''. + intuition auto. apply hadd. now right. + destruct H3 as [cl'' []]. + apply hadd in H0 as []; subst. + rewrite clause_levels_spec in H3. destruct H3; subst. + cbn in H0. now left. right. now left. + right. right. left; exists cl''. split => //. +Qed. +*) +Lemma min_model_mapsto cls : + forall l, LevelSet.In l (clauses_levels cls) -> + exists k, LevelMap.MapsTo l (Some k) (min_model_map (LevelMap.empty _) cls) /\ + (exists cl, Clauses.In cl cls /\ + exists n, k = Z.of_nat n /\ LevelExprSet.In (l,n) (premise cl) /\ + (* (forall cl', Clauses.In cl cls -> forall l k, LevelExprSet.In (l, k) (premise cl') -> k <= n) *) + maximal_prem l n cls). +Proof. + intros. + eapply (min_model_mapsto_gen (LevelMap.empty _)) in H as [k []]. + exists k. intuition eauto. + now eapply LevelMapFact.F.empty_mapsto_iff in H. +Qed. + Definition min_model m cls : model := min_model_map m cls. Definition init_model cls := min_model (LevelMap.empty _) cls. @@ -3079,27 +3406,73 @@ Definition init_w (levels : LevelSet.t) : LevelSet.t := LevelSet.empty. Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). Equations? infer (cls : clauses) : infer_result (clauses_levels cls) cls := - infer cls := loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (And3 _ _ _). + infer cls := loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (And4 _ _ _ _). Proof. - now eapply clauses_conclusions_levels. - lsets. - red. now eapply init_model_levels. + - red. intros k. now rewrite LevelSetFact.empty_iff. Qed. Local Open Scope Z_scope. Lemma max_min max min k : min <= 0 -> max >= 0 -> k <= max -> k >= min -> (max - k - min) >= 0. Proof. lia. Qed. +Definition model_min m := + LevelMap.fold (fun l k acc => + match k with + | Some k => Z.min acc k + | None => acc + end) m 0%Z. + +Lemma model_min_spec m : forall l k, LevelMap.MapsTo l k m -> (Some (model_min m) ≤ k). +Proof. Admitted. + +Definition model_max m := + LevelMap.fold (fun l k acc => + match k with + | Some k => Z.max acc k + | None => acc + end) m 0%Z. + +Lemma model_max_spec m : forall l k, LevelMap.MapsTo l k m -> (k ≤ Some (model_max m))%Z. +Proof. Admitted. + Definition valuation_of_model (m : model) : LevelMap.t nat := - let '(min, max) := LevelMap.fold (fun l k '(min, max) => (Z.min min k, Z.max k max)) m (0, 0)%Z in - LevelMap.fold (fun l k acc => LevelMap.add l (Z.to_nat (max - k - min)) acc) m (LevelMap.empty _). + let min := model_min m in + let max := model_max m in + LevelMap.fold (fun l k acc => LevelMap.add l (Z.to_nat (max - option_get 0%Z k - min)) acc) m (LevelMap.empty _). Close Scope Z_scope. +Lemma valuation_of_model_spec m : + forall l k, LevelMap.MapsTo l (Some k) m -> + let v := (model_max m - k - model_min m)%Z in + (v >= 0)%Z /\ LevelMap.MapsTo l (Z.to_nat v) (valuation_of_model m). +Proof. Admitted. +(* Lemma valuation_of_model_pos l k model : LevelMap.MapsTo l (Z.to_nat k) (valuation_of_model model) -> (k >= 0)%Z. +Proof. + unfold valuation_of_model. + revert l k. + eapply LevelMapFact.fold_rec. + - intros. now rewrite LevelMapFact.F.empty_mapsto_iff in H0. + - intros l0 k0 e m' m'' me nk hadd hind l k. + rewrite LevelMapFact.F.add_mapsto_iff. + intros []. + * destruct H. red in H; subst. + destruct k0. + { have hmax := (model_max_spec model l (Some z) me). depelim hmax. + have hmin := (model_min_spec model l (Some z) me). depelim hmin. + assert (0 <= model_max model)%Z. admit. + assert (model_min model <= 0)%Z. admit. + assert (model_max model - option_get 0%Z (Some z) - model_min model = k)%Z. admit. + cbn in H4. + lia. *) + Local Open Scope string_scope2. -Definition print_level_Z_map (m : LevelMap.t Z) := +Definition print_level_Z_map (m : LevelMap.t (option Z)) := let list := LevelMap.elements m in - print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_Z w) nl list. + print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ (match w with None => "undefined" | Some z => string_of_Z z end)) nl list. Definition print_result {V cls} (m : infer_result V cls) := match m return string with @@ -3142,13 +3515,14 @@ Proof. - apply H, clauses_conclusions_spec. exists cl => //. - apply H0, clauses_conclusions_spec. exists cl => //. - exact H1. + - intros x. now rewrite LevelSetFact.empty_iff. Qed. (* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by setting a minimal value for the new atoms in [clauses_levels cls \ V] such that the new clauses [cls] do not hold vacuously. *) -Equations? infer_extension {V init cls} (m : valid_model V init cls) (cls' : clauses) : +Equations? infer_extension {V W init cls} (m : valid_model V W init cls) (cls' : clauses) : result (LevelSet.union (clauses_levels cls') V) LevelSet.empty (Clauses.union cls cls') (min_model m.(model_model) cls') := infer_extension m cls' := infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model m.(model_model) cls') cls cls' _. @@ -3162,13 +3536,13 @@ Proof. apply LevelSet.union_spec in H as []; auto. Qed. -Definition enforce_clauses {V init cls} (m : valid_model V init cls) cls' : option model := +Definition enforce_clauses {V W init cls} (m : valid_model V W init cls) cls' : option model := match infer_extension m cls' with | Loop => None | Model w m _ => Some m.(model_model) end. -Definition enforce_clause {V init cls} (m : valid_model V init cls) cl : option model := +Definition enforce_clause {V W init cls} (m : valid_model V W init cls) cl : option model := enforce_clauses m (Clauses.singleton cl). Inductive constraint_type := UnivEq | UnivLe. @@ -3193,7 +3567,7 @@ Definition clauses_of_list := ClausesProp.of_list. Definition list_of_clauses := Clauses.elements. Definition valuation := LevelMap.t nat. -Definition premises_model_map (m : LevelMap.t Z) cls : LevelMap.t Z := +Definition premises_model_map (m : LevelMap.t (option Z)) cls : LevelMap.t (option Z) := Clauses.fold (fun '(cl, concl) acc => LevelExprSet.fold (fun '(l, k) acc => add_max l (Z.of_nat k) acc) cl acc) cls m. @@ -3256,16 +3630,308 @@ Proof. now left. right. now left. Qed. -Definition premises_model m cls : model := premises_model_map m cls. Variant checking_result (cls : clauses) (cl : clause) : Type := | DoesNotHold : ~ entails cls cl -> checking_result cls cl | Entails : entails cls cl -> checking_result cls cl. -Equations? check {V init cls} (m : valid_model V init cls) (cl : clause) : - checking_result cls cls := - check m cl := - infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model m.(model_model) cls') cls cls' _. +Definition undefined_model levels : LevelMap.t (option Z) := + LevelSet.fold (fun elt acc => LevelMap.add elt None acc) levels (LevelMap.empty _). + +Definition premises_model V cl : LevelSet.t * model := + let levels := LevelSet.union (clause_levels cl) V in + (levels, premises_model_map (undefined_model levels) (Clauses.singleton cl)). + +Program Definition loop_check {V init cls} (m : valid_model V V init cls) (cl : clause) : result (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 := + loop (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 _. +Next Obligation. + destruct m. split => //. 1-2:lsets. admit. + - now intros x; rewrite LevelSetFact.empty_iff. +Admitted. + +Equations check {V init cls} (m : valid_model V V init cls) (cl : clause) : bool := + check m cl with loop_check m cl := + | Loop => false (* Actually impossible *) + | Model W v _ => + let '(concl, k) := concl cl in + match LevelMap.find concl v.(model_model) with + | Some None => false + | Some (Some v) => (Z.of_nat k <=? v)%Z + | None => false + end. + +Definition enabled_clause (m : model) (cl : clause) := + isSome (min_premise m (premise cl)). + +Definition enabled_clauses (m : model) (cls : clauses) := + Clauses.for_all (enabled_clause m) cls. + +Section Semantics. + + Section Interpretation. + Context (V : LevelMap.t nat). + + Definition interp_level l := + match LevelMap.find l V with + | Some x => x + | None => 0%nat + end. + + Definition interp_expr '(l, k) := (interp_level l + k)%nat. + Definition interp_prems prems := + let '(hd, tl) := to_nonempty_list prems in + fold_right (fun lk acc => Nat.max (interp_expr lk) acc) (interp_expr hd) tl. + + Definition clause_sem (cl : clause) : Prop := + let '(prems, concl) := cl in + interp_prems prems >= interp_expr concl. + + Definition clauses_sem (cls : clauses) : Prop := + Clauses.For_all clause_sem cls. + End Interpretation. + + (* There exists a valuation making all clauses true in the natural numbers *) + Definition satisfiable (cls : clauses) := + exists V, clauses_sem V cls. + + (* Any valuation making all clauses valid in the natural numbers also satisfies the clause cl *) + Definition entails_sem (cls : clauses) (cl : clause) := + forall V, clauses_sem V cls -> clause_sem V cl. +End Semantics. + +Definition correct_model (cls : clauses) (m : model) := + enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. + +Equations? infer_model (cls : clauses) : option model := +infer_model cls with loop (clauses_levels cls) LevelSet.empty cls (init_model cls) _ := + | Loop => None + | Model w vm heq => Some vm.(model_model). +Proof. + split. + - apply clauses_conclusions_levels. + - lsets. + - apply infer_obligation_3. + - apply infer_obligation_4. +Qed. + +Definition infer_correctness cls := forall m, infer_model cls = Some m -> correct_model cls m. + +Lemma enabled_clauses_ext m m' cls : m ⩽ m' -> enabled_clauses m cls -> enabled_clauses m' cls. +Proof. Admitted. + +Lemma interp_prems_ge v (prems : nonEmptyLevelExprSet) : + forall prem, LevelExprSet.In prem prems -> + interp_expr v prem <= interp_prems v prems. +Proof. + intros. + unfold interp_prems. + have he := to_nonempty_list_spec prems. + destruct to_nonempty_list. + pose proof to_nonempty_list_spec'. + rewrite In_elements in H. rewrite -he in H. clear H0 he. clear -H. + destruct H. subst t. + - induction l. cbn. auto. + cbn. lia. + - induction l in H |- *. + now cbn in H. + cbn in H. destruct H; subst; cbn. + * cbn. lia. + * specialize (IHl H). lia. +Qed. + +Lemma valid_clause_model model cl : + enabled_clause model cl -> + valid_clause model cl -> + clause_sem (valuation_of_model model) cl. +Proof. + unfold enabled_clause, valid_clause. + destruct min_premise eqn:hmin => //= _. + destruct cl as [prems [concl k]]; cbn. + unfold level_value_above. + destruct level_value eqn:hl => //. + move/Z.leb_le. + intros hrel. + unfold interp_level. unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. subst o. + eapply LevelMap.find_2 in hfind. + have conclm := valuation_of_model_spec _ _ _ hfind. + set (v := (model_max _ - _ - _)%Z) in *. + cbn in conclm. destruct conclm as [vpos conclm]. + eapply LevelMap.find_1 in conclm. rewrite conclm. + subst v. + pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. + rewrite hmin in premeq. + eapply Nat.le_trans. 2:{ eapply interp_prems_ge; tea. } + unfold interp_expr. destruct prem as [prem k']. + symmetry in premeq. + move: premeq. unfold min_atom_value. + unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. + destruct o => //. intros [= <-]. + eapply LevelMap.find_2 in findp. + have premm := valuation_of_model_spec _ _ _ findp. + unfold interp_level. + destruct premm as [vppos vpmap]. + eapply LevelMap.find_1 in vpmap. rewrite vpmap. lia. +Qed. + +Lemma infer_correct cls : infer_correctness cls. +Proof. + intros m. + funelim (infer_model cls) => //. + intros [= <-]. clear Heq Heqcall. destruct vm as [model ofV ovW clsconcl ism mext], heq; cbn in *. + set (V := clauses_levels cls) in *. + assert (total_model_of V model). + { intros l inl. apply model_ext_le in mext. red in mext. + (* eapply clauses_levels_spec in inl as [cl [hcl hin]]. *) + unfold init_model in mext. + have [kmin [hm incl]] := min_model_mapsto cls l inl. + eapply mext in hm as [kmodel [mapmodel hmodel]]. + depelim hmodel. now exists y. } + unfold correct_model. + have encl : enabled_clauses model cls. + { eapply enabled_clauses_ext. apply mext. + unfold enabled_clauses. eapply Clauses.for_all_spec. tc. + intros x hin. unfold enabled_clause. + pose proof (@min_premise_spec (init_model cls) (premise x)) as [premmin [prem [premin premeq]]]. + have inV : LevelSet.In prem (clauses_levels cls). + { rewrite clauses_levels_spec. exists x; split => //. rewrite /clause_levels. + eapply LevelSet.union_spec; left. rewrite levelexprset_levels_spec. exists prem.2. + destruct prem. exact premin. } + have [kmin [hm incl]] := min_model_mapsto cls prem inV. + unfold init_model. rewrite premeq. unfold min_atom_value. + destruct prem as [l k]. + eapply LevelMap.find_1 in hm. unfold level_value. now rewrite hm. } + split => //. + unfold clauses_sem. + intros cl hin. + eapply valid_clause_model. eapply Clauses.for_all_spec in encl; tc. now eapply encl in hin. + eapply Clauses.for_all_spec in ism; tc. now specialize (ism _ hin). +Qed. + +Lemma min_premise_some_pres {m m' prems k} : m ⩽ m' -> min_premise m prems = Some k -> exists k', min_premise m' prems = Some k'. +Proof. + intros ext minp. + apply (@min_premise_pos_spec_inv m' prems). + intros x hin. + pose proof (min_premise_spec m prems) as [le eq]. specialize (le x hin). + rewrite minp in le. depelim le. + move: H0; rewrite /min_atom_value /levelexpr_value /level_value. destruct x as [l k']. + destruct LevelMap.find eqn:hfind => //. destruct o => //; intros [= <-]. + eapply LevelMap.find_2 in hfind. eapply ext in hfind as [? [map2 hsome]]. + eapply LevelMap.find_1 in map2. rewrite map2. depelim hsome. now exists y. +Qed. + +Lemma min_premise_spec' {m prems z} : min_premise m prems = Some z -> + (forall l k, LevelExprSet.In (l, k) prems -> + exists v, level_value m l = Some v /\ z <= (v - Z.of_nat k))%Z. +Proof. + intros hmin. + have [hall hhmin'] := min_premise_spec m prems. + intros l k hin; specialize (hall _ hin). rewrite hmin in hall. + depelim hall. destruct level_value => //. noconf H0. exists z0. split => //. +Qed. + +Lemma nonEmptyLevelExprSet_elim {P : nonEmptyLevelExprSet -> Prop} : + (forall le, P (singleton le)) -> + (forall le prems, P prems -> P (add le prems)) -> + forall prems, P prems. +Proof. + intros hs ha. + intros []. + revert t_set0 t_ne0. + apply: LevelExprSetProp.set_induction; eauto. + - move=> s /LevelExprSetFact.is_empty_1 he ne; exfalso => //. congruence. + - intros s s' IH x nin hadd hne. + destruct (LevelExprSet.is_empty s) eqn:hem in |- . + eapply LevelExprSetFact.is_empty_2 in hem. + assert (singleton x = {| t_set := s'; t_ne := hne |}) as <- => //. + unfold singleton. apply eq_univ'. cbn. + intros a. specialize (hadd a). rewrite hadd. + rewrite LevelExprSet.singleton_spec. firstorder. subst. reflexivity. + specialize (IH hem). + specialize (ha x _ IH). + assert (LevelExprSet.Equal (add x {| t_set := s; t_ne := hem|}) {| t_set := s'; t_ne := hne |}). + 2:{ apply eq_univ' in H. now rewrite -H. } + intros x'. specialize (hadd x'). rewrite LevelExprSet.add_spec. + cbn. firstorder. subst x'. now left. +Qed. + +Lemma min_premise_pres m m' prems : m ⩽ m' -> min_premise m prems ≤ min_premise m' prems. +Proof. + intros ext. + destruct (min_premise m prems) eqn:hmin. + have leq := min_premise_spec' hmin. 2:constructor. + have [leq' e'] := min_premise_spec m' prems. + destruct (min_premise_spec m prems) as [_ [minz [inminz eqminz]]]. + rewrite hmin in eqminz. + rewrite eqminz. destruct e' as [min' []]. rewrite H0. + transitivity (min_atom_value m min'). + 2:{ unfold min_atom_value. destruct min'. + unfold level_value. destruct (LevelMap.find t m) eqn:hfind. destruct o => //. 2:constructor. + apply LevelMap.find_2 in hfind. apply ext in hfind as [k' [hfind hle]]. + apply LevelMap.find_1 in hfind. rewrite hfind. depelim hle. constructor. lia. constructor. + } + destruct min'. specialize (leq _ _ H) as [? []]. + unfold min_atom_value at 2. rewrite H1. rewrite -eqminz. constructor. lia. +Qed. + +(* If a clause checks, then it should be valid in any extension of the model *) +Lemma check_entails {V init cls} (m : valid_model V V init cls) (cl : clause) : + check m cl = true -> forall m', model_model m ⩽ m' -> valid_clause m' cl. +Proof. + funelim (check m cl) => //. + destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *. + destruct LevelMap.find as [[conclval_v|]|] eqn:hfind => //. + (* Found a value *) + unfold valid_clause, level_value_above. cbn. + move/Z.leb_le => hgt. + intros m' ext. + destruct min_premise eqn:hmin => //. + pose proof (min_premise_spec m' prems) as [minle mineq]. + unfold level_value. + set (all_levels := clause_levels _ ∪ V) in *. + set (undef_model := premises_model_map _ _) in *. + have vcheck := model_ok v. + unfold is_model in vcheck. + assert (model_model v ⩽ model_model m). admit. + assert (model_model v ⩽ m'). etransitivity; tea. + eapply LevelMap.find_2 in hfind. + apply H0 in hfind as [k' [hmk' neq]]. depelim neq. rename y into conclval_m'. + eapply LevelMap.find_1 in hmk'. rewrite hmk'. eapply Z.leb_le. transitivity conclval_v => //. + destruct (Z.leb_spec z 0). lia. + (* If min_premise m' z > 0 in the final model, it means prems -> prems + 1, + i.e. there is a loop, which is impossible. + We start with min_premise undef_model prems = Some 0 by definition. + Any increase of [z]'s value means a consequence of [z] + was found requiring to increase its value. But then it must mean [z -> z + 1]. + *) + exfalso. + have me := model_extends v. + have me' := model_ext_le _ _ _ me. + assert (not (exists x, is_loop cls x)). admit. + apply H3. + destruct mineq as [minelt [hprems hmin']]. + exists (singleton minelt). + unfold is_loop, to_clauses. + intros x hin. + rewrite LevelExprSet.fold_spec in hin. + move: hin. + assert (LevelExprSet.elements (succ_prems (singleton minelt)) = [succ_expr minelt]). admit. + rewrite H4 //=. unfold flip. move/Clauses.add_spec. intros [->|] => //. 2:{ now apply Clauses.empty_spec in H5. } + destruct minelt as [min k']. cbn. + + + + + assert (min_premise undef_model prems = Some z). + { + (min_premise_pres _ _ _ ) + + + + } + + + Proof. repeat split. - pose proof (model_clauses_conclusions m). lsets. From 49d9c3ddd9de02be1aca48df03f3bd8d64d09a53 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 24 Jul 2025 12:42:47 +0200 Subject: [PATCH 007/164] more precise check_model invariants --- template-rocq/theories/PartialLoopChecking.v | 192 +++++++++++++++---- 1 file changed, 160 insertions(+), 32 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 537bdd0d0..4bd42be79 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -760,6 +760,11 @@ Proof. firstorder auto. Qed. +Lemma restrict_clauses_subset (cls : clauses) (concls : LevelSet.t) : Clauses.Subset (restrict_clauses cls concls) cls. +Proof. + intros x; rewrite in_restrict_clauses; now intros []. +Qed. + Definition clauses_with_concl (cls : clauses) (concl : LevelSet.t) := Clauses.filter (fun '(prem, concla) => LevelSet.mem (level concla) concl) cls. @@ -1752,6 +1757,11 @@ Qed. Definition total_model_of V (m : model) := forall k, LevelSet.In k V -> exists x, LevelMap.MapsTo k (Some x) m. +(** The values of levels in U result from consequences of existing constraints *) +Definition is_update U cls m := + forall l, LevelSet.In l U -> exists prems k v, Clauses.In (prems, (l, k)) cls /\ + min_premise m prems = Some v /\ level_value_above m l (Z.of_nat k + v). + Definition check_model_invariants cls w m w' m' (modified : bool) := if modified then [/\ w ⊂_lset w', @@ -2300,20 +2310,48 @@ Extraction Inline model_model. Definition valid_model := valid_model_def. -Inductive entails (cls : clauses) : clause -> Prop := -| clause_in (prems : nonEmptyLevelExprSet) (cl : LevelExpr.t) : LevelExprSet.In cl prems -> entails cls (prems, cl) -| clause_cut prems' concl' prems concl : - Clauses.In (prems', concl') cls -> - entails cls (add concl' prems, concl) -> - LevelExprSet.Subset prems' prems -> - entails cls (prems, concl). -Definition succ_expr '((l, k) : LevelExpr.t) := (l, k + 1)%nat. -Definition succ_prems s := map succ_expr s. -Definition succ_clause '((prems, concl) : clause) := (succ_prems prems, succ_expr concl). +Definition add_expr n '((l, k) : LevelExpr.t) := (l, k + n)%nat. + +Lemma add_expr_add_expr n n' lk : add_expr n (add_expr n' lk) = add_expr (n + n') lk. +Proof. destruct lk; unfold add_expr. f_equal; lia. Qed. +Definition add_prems n s := map (add_expr n) s. + +Lemma map_map f g x : map f (map g x) = map (f ∘ g) x. +Proof. + apply eq_univ'. + intros lk. + rewrite !map_spec. setoid_rewrite map_spec. + firstorder eauto. subst. firstorder. +Qed. + +Lemma add_prems_add_prems n n' lk : add_prems n (add_prems n' lk) = add_prems (n + n') lk. +Proof. destruct lk; unfold add_prems. + rewrite map_map. apply eq_univ'. + intros x; rewrite /= !map_spec. cbn in *. + firstorder eauto. subst. exists x0. + firstorder eauto. now rewrite add_expr_add_expr. + subst. exists x0. + firstorder eauto. now rewrite add_expr_add_expr. +Qed. + +Definition add_clause n '((prems, concl) : clause) := (add_prems n prems, add_expr n concl). + +Lemma add_clause_add_clause n n' cl : add_clause n (add_clause n' cl) = add_clause (n + n') cl. +Proof. + destruct cl. + unfold add_clause. + now rewrite add_prems_add_prems add_expr_add_expr. +Qed. + +Notation succ_expr := (add_expr 1). +Notation succ_prems := (add_prems 1). +Notation succ_clause := (add_clause 1). + Lemma succ_clause_inj x y : succ_clause x = succ_clause y -> x = y. Proof. Admitted. -Definition succ_clauses cls := ClausesProp.of_list (List.map (fun cl => succ_clause cl) (ClausesProp.to_list cls)). +Definition add_clauses n cls := ClausesProp.of_list (List.map (fun cl => add_clause n cl) (ClausesProp.to_list cls)). +Notation succ_clauses := (add_clauses 1). Import SetoidList. Lemma succ_clauses_spec cl cls : Clauses.In cl cls <-> Clauses.In (succ_clause cl) (succ_clauses cls). Proof. @@ -2324,15 +2362,58 @@ Proof. - eapply Clauses_In_elements in H0. apply succ_clause_inj in H. now subst. Qed. +Inductive in_pred_closure cls : clause -> Prop := +| incls cl n : Clauses.In cl cls -> in_pred_closure cls (add_clause n cl) +| predcl x k : in_pred_closure cls (singleton (x, k + 1)%nat, (x, k)). +Derive Signature for in_pred_closure. + +Inductive entails (cls : clauses) : clause -> Prop := +| clause_in (prems : nonEmptyLevelExprSet) (cl : LevelExpr.t) : LevelExprSet.In cl prems -> entails cls (prems, cl) +| clause_cut prems' concl' prems concl : + in_pred_closure cls (prems', concl') -> + entails cls (add concl' prems, concl) -> + LevelExprSet.Subset prems' prems -> + entails cls (prems, concl). + +Lemma entails_equal cls (prems prems' : nonEmptyLevelExprSet) concl : + LevelExprSet.Equal prems prems' -> + entails cls (prems, concl) -> entails cls (prems', concl). +Proof. + intros he en. + replace prems' with prems => //. + now apply eq_univ'. +Qed. + Lemma entails_plus cls c : entails cls c -> entails (succ_clauses cls) (succ_clause c). Proof. induction 1. - constructor. apply map_spec. exists cl. split => //. - eapply clause_cut with (succ_prems prems') (succ_expr concl'). - + now rewrite -(succ_clauses_spec (prems', concl')). - + admit. - + admit. -Admitted. + + depelim H. + * have -> : (succ_prems prems', succ_expr concl') = add_clause n (succ_clause cl). + { destruct cl as [prems'' concl'']. cbn in H0. noconf H0. + rewrite add_prems_add_prems add_expr_add_expr add_clause_add_clause. + now rewrite Nat.add_1_r. } + constructor. now rewrite -succ_clauses_spec. + * have eq : (succ_prems (singleton (x, (k + 1)%nat))) = (singleton (x, k + 1 + 1)%nat). + { apply eq_univ'. unfold succ_prems. + intros le. rewrite map_spec LevelExprSet.singleton_spec. + split. + { intros [? [hin ->]]. + rewrite LevelExprSet.singleton_spec in hin. red in hin; subst x0. + reflexivity. } + { unfold LevelExprSet.E.eq. intros ->. + exists (x, k + 1)%nat. split. + now rewrite LevelExprSet.singleton_spec. reflexivity. } } + rewrite eq. constructor 2. + + unfold succ_clause in IHentails. + eapply entails_equal; tea. + intros x. rewrite /succ_prems. rewrite map_spec add_spec. + setoid_rewrite add_spec. rewrite map_spec. + firstorder eauto. subst. now left. + + intros x. rewrite /succ_prems !map_spec. + intros [e [hin ->]]. exists e. firstorder. +Qed. Definition to_clauses (prems : nonEmptyLevelExprSet) (concl : nonEmptyLevelExprSet) : clauses := LevelExprSet.fold (fun lk cls => Clauses.add (prems, lk) cls) concl Clauses.empty. @@ -2346,9 +2427,44 @@ Definition is_loop (cls : clauses) (t : nonEmptyLevelExprSet) := let prem := List.map (fun e => (e, n)) preml in is_loop cls prem. *) +Definition levelexprset_of_levels (ls : LevelSet.t) : LevelExprSet.t := + LevelSet.fold (fun x => LevelExprSet.add (x, 0%nat)) ls LevelExprSet.empty. + +Lemma levelexprset_of_levels_spec (ls : LevelSet.t) l : + LevelExprSet.In (l, 0%nat) (levelexprset_of_levels ls) <-> LevelSet.In l ls. +Proof. + rewrite /levelexprset_of_levels. + eapply LevelSetProp.fold_rec. + - intros s' he. rewrite LevelExprSetFact.empty_iff. firstorder. + - intros x a s' s'' hin hnin hadd ih. + rewrite LevelExprSet.add_spec; unfold LevelExprSet.E.eq. + firstorder eauto. noconf H1. firstorder. + apply hadd in H1. firstorder. subst. now left. +Qed. + +#[program] +Definition of_level_set (ls : LevelSet.t) (hne : ~ LevelSet.Empty ls) : nonEmptyLevelExprSet := + {| t_set := levelexprset_of_levels ls |}. +Next Obligation. + apply not_Empty_is_empty => he. apply hne. + intros l nin. specialize (he (l,0%nat)). apply he. + now rewrite levelexprset_of_levels_spec. +Qed. + +Definition entails_clauses cls cl := + Clauses.For_all (entails cls) cl. + +Definition loop_on_univ cls prems := entails_clauses cls (to_clauses prems (succ_prems prems)). + +Definition loop_on W (hne : ~ LevelSet.Empty W) cls := + loop_on_univ cls (of_level_set W hne). + +Lemma loop_on_subset {W hne cls cls'} : Clauses.Subset cls cls' -> loop_on W hne cls -> loop_on W hne cls'. +Proof. +Admitted. + Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := - | Loop - (* (w : LevelSet.t) (n : nat) (islooping : loop_on w n cls) *) + | Loop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne cls) | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). Arguments Loop {V U cls m}. Arguments Model {V U cls m}. @@ -2356,8 +2472,8 @@ Arguments lexprod {A B}. Definition option_of_result {V U m cls} (r : result V U m cls) : option model := match r with - | Loop => None | Model w m sub => Some m.(model_model) + | Loop w hne isloop => None end. Definition extends_model {W U cls m m'} : @@ -2366,10 +2482,11 @@ Definition extends_model {W U cls m m'} : model_map_outside W m' m -> result W U cls m -> result W U cls m'. Proof. - intros leq ldom lout []. exact Loop. - econstructor 2; tea. - destruct m0. econstructor; tea. - - now transitivity m. + intros leq ldom lout []. + - eapply Loop; tea. + - econstructor 2; tea. + destruct m0. econstructor; tea. + now transitivity m. Qed. (* #[tactic="idtac"] @@ -2403,7 +2520,7 @@ Defined. Section InnerLoop. Context (V : LevelSet.t) (U : LevelSet.t) (loop : forall (V' U' : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V', U' ⊂_lset V', model_of V' m & total_model_of U' m]), + (prf : [/\ clauses_conclusions cls ⊂_lset V', U' ⊂_lset V', model_of V' m, total_model_of U' m & is_update U' cls m ]), lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls m). Definition sum_W W (f : LevelSet.elt -> nat) : nat := @@ -2746,14 +2863,14 @@ Section InnerLoop. by wf (measure W cls m) lt := inner_loop_partition m mW with loop W LevelSet.empty premconclW m _ _ := { (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) - | Loop => Loop + | Loop W ne isl => Loop W ne (loop_on_subset _ isl) (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). By invariant Wr ⊂ W *) | Model Wr mr hsub with inspect (check_model conclW (Wr, model_model mr)) := { | exist None eqm => Model W {| model_model := model_model mr |} _ | exist (Some (Wconcl, mconcl)) eqm with inner_loop_partition mconcl _ := { (* Here Wconcl ⊂ Wr by invariant *) - | Loop => Loop + | Loop W ne isl => Loop W ne isl | Model Wr' mr' hsub' => Model Wr' {| model_model := model_model mr' |} hsub' } (* Here Wr' ⊂ W by invariant *) (* We check if the new model [mr] for (cls ⇂ W) extends to a model of (cls ↓ W). *) @@ -2771,7 +2888,9 @@ Section InnerLoop. all:try rewrite eqconcl in eqm. - split => //. rewrite eqprem. apply clauses_conclusions_restrict_clauses. lsets. exact mW. intros k. now rewrite LevelSetFact.empty_iff. + now intros l; rewrite LevelSetFact.empty_iff. - left. now eapply strict_subset_cardinal. + - destruct prf. transitivity (cls ⇂ W) => //. now rewrite H3. eapply restrict_clauses_subset. - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. eapply total_model_of_ext. 2:tea. pose proof (model_extends mr). eapply total_model_of_ext; tea. @@ -2901,38 +3020,47 @@ Qed. #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V, U ⊂_lset V, model_of V m & total_model_of U m]) : result V U cls m + (prf : [/\ clauses_conclusions cls ⊂_lset V, U ⊂_lset V, model_of V m, total_model_of U m & is_update U cls m]) : result V U cls m by wf (loop_measure V U) lexprod_rel := loop V U cls m prf with inspect (check_model cls (U, m)) := | exist None eqm => Model U {| model_model := m |} _ | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { - | exist true eq := Loop + | exist true eq := Loop W _ _ (* Loop on cls ↓ W, with |W| < |V| *) | exist false neq with inner_loop V U loop W (cls ↓ W) m' _ := - { | Loop := Loop + { | Loop W' ne isloop := Loop W' ne (loop_on_subset _ isloop) | Model Wc mwc hsub' (* We get a model for (cls ↓ W), we check if it extends to all clauses. By invariant |Wc| cannot be larger than |W|. *) with inspect (check_model cls (Wc, mwc.(model_model))) := { | exist None eqm' => Model Wc {| model_model := mwc.(model_model) |} _ | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { - | exist true _ := Loop + | exist true _ := Loop Wcls _ _ | exist false neq' with loop V Wcls cls mcls _ := { (* Here Wcls < V, we've found a model for all of the clauses with conclusion in W, which can now be fixed. We concentrate on the clauses whose conclusion is different. Clearly |W| < |V|, but |Wcls| is not necessarily < |V| *) - | Loop := Loop + | Loop W' ne isloop := Loop W' ne isloop | Model Wvw mcls' hsub'' := Model Wvw {| model_model := model_model mcls' |} _ } } } } } . Proof. - all:clear loop. + all:cbn; clear loop. all:try solve [intuition auto]. all:try eapply levelset_neq in neq. all:have cls_sub := clauses_conclusions_levels cls. all:destruct prf as [clsV UV mof]. + - apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //; + destruct hcl as [? []]. now intros he; apply he in H4. + - set (neW := ssr_have _ _); clearbody neW. + do 2 red. eapply LevelSet.equal_spec in eq. + apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. + destruct hcl as [cl [incl vcl conclinW hle]]. + red in H. + + - apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. split => //. split => //. lsets. destruct hcl as [l [hl _]]. intros he. lsets. @@ -3897,7 +4025,7 @@ Proof. eapply LevelMap.find_2 in hfind. apply H0 in hfind as [k' [hmk' neq]]. depelim neq. rename y into conclval_m'. eapply LevelMap.find_1 in hmk'. rewrite hmk'. eapply Z.leb_le. transitivity conclval_v => //. - destruct (Z.leb_spec z 0). lia. + destruct (Z.leb_spec z 0). (* If min_premise m' z > 0 in the final model, it means prems -> prems + 1, i.e. there is a loop, which is impossible. We start with min_premise undef_model prems = Some 0 by definition. From 6d821b2f48e63484c0fba570e4b462c11ee3a0d4 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 26 Jul 2025 21:13:31 +0200 Subject: [PATCH 008/164] Before generalizing strict_update --- template-rocq/theories/PartialLoopChecking.v | 625 +++++++++++++------ 1 file changed, 443 insertions(+), 182 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 4bd42be79..788d673c8 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -199,6 +199,13 @@ Module LevelExprSetDecide := WDecide (LevelExprSet). Ltac lesets := LevelExprSetDecide.fsetdec. Infix "⊂_leset" := LevelExprSet.Subset (at level 70). +Lemma levelset_not_Empty_is_empty s : + LevelSet.is_empty s = false -> ~ LevelSet.Empty s. +Proof. + intros H he. red in he. apply negbT in H. unshelve eapply (contraNnot _ H). + 3:exact he. intros ha. now apply LevelSetFact.is_empty_1. +Qed. + Module NonEmptySetFacts. #[program] Definition singleton (e : LevelExpr.t) : nonEmptyLevelExprSet := {| t_set := LevelExprSet.singleton e |}. @@ -695,28 +702,31 @@ Definition check_clause_model cl '(modified, wm) := | Holds => (modified, wm) end. -Definition check_model_aux (cls : clauses) (wm : LevelSet.t × model) : bool × (LevelSet.t × model) := +Definition check_model_aux (cls : clauses) (wm : LevelSet.t × model) : bool × LevelSet.t × model := Clauses.fold check_clause_model cls (false, wm). (* If check_model = None then we have a model of all clauses, othewise, we return Some (W', m') where W ⊂ W' and the model has been updated for at least one atom l ∈ W'. *) -Definition check_model (cls : clauses) (wm : LevelSet.t × model) := - let '(modified, wm) := check_model_aux cls wm in - if modified then Some wm else None. +Definition check_model (cls : clauses) (m : model) : option (LevelSet.t × model) := + let '(modified, (w, m)) := check_model_aux cls (LevelSet.empty, m) in + match LevelSet.is_empty w with + | true => None + | false => Some (w, m) + end. Lemma check_model_aux_subset {cls w v} : - forall b w' v', check_model_aux cls (w, v) = (b, (w', v')) -> LevelSet.Subset w w'. + forall modified w' v', check_model_aux cls (w, v) = (modified, (w', v')) -> LevelSet.Subset w w'. Proof. - intros w' v'. - unfold check_model, check_model_aux, check_clause_model. revert w' v'. + intros modified w' v'. + unfold check_model, check_model_aux, check_clause_model. revert modified w' v'. eapply ClausesProp.fold_rec => //. { intros. noconf H0. reflexivity. } intros x a s' s'' hin nin hadd IH. - intros b w' v'. destruct a. - destruct p as []. + intros modified' w' v'. destruct a. unfold update_value. destruct x as [prem [l k]]; cbn. + destruct p. destruct min_premise as [k0|] eqn:hk0. 2:apply IH. destruct level_value_above. @@ -727,14 +737,14 @@ Proof. now right. Qed. -Lemma check_model_subset {cls w v} : - forall w' v', check_model cls (w, v) = Some (w', v') -> LevelSet.Subset w w'. +Lemma check_model_subset {cls v} : + forall w' v', check_model cls v = Some (w', v') -> ~ LevelSet.Empty w'. Proof. intros w' v'. unfold check_model. - destruct check_model_aux eqn:cm. - destruct p as [W m]. + destruct check_model_aux eqn:cm. destruct p. eapply check_model_aux_subset in cm. - destruct b => //. now intros [= <- <-]. + destruct LevelSet.is_empty eqn:hem => //. + eapply levelset_not_Empty_is_empty in hem. now intros [= <- <-]. Qed. Definition premise_restricted_to W cl := @@ -1052,14 +1062,21 @@ Proof. destruct Z.leb => //. Qed. -Lemma check_model_aux_false {cls acc acc'} : check_model_aux cls acc = (false, acc') -> acc = acc'. +Lemma check_model_aux_false {cls w acc w' acc'} : check_model_aux cls (w, acc) = (false, (w', acc')) -> w = w' /\ acc = acc'. Proof. unfold check_model_aux, check_clause_model. + revert w' acc'. eapply ClausesProp.fold_rec. - - intros s emp [=] => //. - - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. - intros IH. + - intros s emp w' acc' [=] => //. + - intros cl [w'' m''] cls' cls'' incl nincls' incls''. + intros IH w' acc'. destruct update_value eqn:upd => //. + * intros [= -> ->]. now specialize (IH _ _ eq_refl). + * intros [= -> ->]. now specialize (IH _ _ eq_refl). +Qed. +Lemma level_value_not_above_spec m l k : level_value_above m l k = false -> opt_le Z.lt (level_value m l) (Some k). +Proof. + unfold level_value_above; destruct level_value => // hlt; constructor. lia. Qed. (* Lemma check_model_aux_true {cls acc acc'} : check_model_aux cls acc = (true, acc') -> acc = acc'. @@ -1086,7 +1103,7 @@ Proof. intros IH. split. * move: (@update_value_valid w' m' cl). - destruct update_value eqn:upd => //; intros vcl [= -> <-] ; + destruct update_value eqn:upd => //. 1-2:intros vcl [= -> <-]; destruct IH as [IH _]; specialize (IH eq_refl). intros x hx; apply incls'' in hx as []; subst. exact vcl. now apply IH. intros x hx; apply incls'' in hx as []; subst. exact vcl. now apply IH. @@ -1269,7 +1286,14 @@ Lemma level_value_MapsTo {l k} {m : model} : LevelMap.MapsTo l k m -> level_value m l = k. Proof. unfold level_value. - move=> mapto; rewrite (LevelMap.find_1 mapto) //. + move=> mapto; rewrite (LevelMap.find_1 mapto) //. +Qed. + +Lemma level_value_MapsTo' {l k} {m : model} : + level_value m l = Some k -> LevelMap.MapsTo l (Some k) m. +Proof. + unfold level_value. destruct LevelMap.find eqn:hfind => //. + eapply LevelMap.find_2 in hfind. now intros ->. Qed. Infix "⊂_clset" := Clauses.Subset (at level 70). @@ -1655,6 +1679,7 @@ Proof. unfold equal_model. red; intros. now transitivity y. Qed. + #[local] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. Proof. intros x y eqm l ? <-. unfold level_value. @@ -1757,10 +1782,18 @@ Qed. Definition total_model_of V (m : model) := forall k, LevelSet.In k V -> exists x, LevelMap.MapsTo k (Some x) m. -(** The values of levels in U result from consequences of existing constraints *) -Definition is_update U cls m := - forall l, LevelSet.In l U -> exists prems k v, Clauses.In (prems, (l, k)) cls /\ - min_premise m prems = Some v /\ level_value_above m l (Z.of_nat k + v). +Definition strict_update m '(prems, (l, k)) m' := + exists v, min_premise m prems = Some v + /\ ~~ level_value_above m l (Z.of_nat k + v) /\ level_value_above m' l (Z.of_nat k + v). + +Definition has_strict_update cls m l m' := exists prems k, Clauses.In (prems, (l, k)) cls /\ strict_update m (prems, (l, k)) m'. + +Definition has_strict_update_W cls m W m' := + (forall l, LevelSet.In l W -> has_strict_update cls m l m'). + +(** The values of levels in W result from consequences of existing constraints *) +Definition is_update cls m W m' := + has_strict_update_W cls m W m' /\ model_map_outside W m m'. Definition check_model_invariants cls w m w' m' (modified : bool) := if modified then @@ -1775,6 +1808,73 @@ Definition check_model_invariants cls w m w' m' (modified : bool) := total_model_of w' m'] else (w, m) = (w', m') /\ total_model_of w m. +Lemma nEmpty_exists ls : ~ (LevelSet.Empty ls) -> exists l, LevelSet.In l ls. +Proof. + intros ne. + destruct (LevelSet.choose ls) eqn:isempty. exists e. + now apply LevelSet.choose_spec1 in isempty. + now apply LevelSet.choose_spec2 in isempty. +Qed. + +Lemma inLevelSet (ls : LevelSet.t) l : LevelSet.In l ls \/ ~ (LevelSet.In l ls). +Proof. + lsets. +Qed. + +Lemma level_value_above_MapsTo m l k : level_value_above m l k -> exists k', LevelMap.MapsTo l k' m /\ Some k ≤ k'. +Proof. + unfold level_value_above. + destruct level_value eqn:hl => //. + move/Z.leb_le => hle; exists (Some z). + eapply level_value_MapsTo' in hl. split => //. constructor; lia. +Qed. + +Lemma level_value_above_MapsTo' m l k k' : LevelMap.MapsTo l k' m -> Some k ≤ k' -> level_value_above m l k. +Proof. + unfold level_value_above. + intros H; apply LevelMap.find_1 in H. rewrite /level_value H. + intros hleq; depelim hleq. now apply Z.leb_le. +Qed. + +Axiom todo : forall {A}, A. + +Lemma is_update_check_model_invariants cls m W m' : ~ LevelSet.Empty W -> is_update cls m W m' -> check_model_invariants cls LevelSet.empty m W m' true. +Proof. + unfold is_update. intros hw [hupd hnupd]. + unfold check_model_invariants. + eapply nEmpty_exists in hw as [l hl]. + split. + - lsets. + - intros hl' hin'. + specialize (hupd _ hin') as [prems [k [v [clin [minp [nabove above]]]]]]. + rewrite LevelSet.union_spec. right. + rewrite clauses_conclusions_spec. eexists; split; eauto. + - specialize (hupd l hl) as [prems [k [v [clin [minp [nabove above]]]]]]. + eexists; split; tea. rewrite /valid_clause. rewrite minp //=. + cbn. move: nabove; unfold level_value_above. + destruct level_value eqn:hlev; try constructor. + move: above. unfold level_value_above. + destruct (level_value m' l) => //. + move/Z.leb_le => hle. constructor. + rewrite -Z.ltb_antisym in nabove. move/Z.ltb_lt: nabove. lia. + - split. + { intros l' k hm. + destruct (inLevelSet W l'). + specialize (hupd _ H) as [prems [k' [v' [clin [minp [nabove above]]]]]]. + eapply negbTE in nabove. + eapply level_value_not_above_spec in nabove. + rewrite (level_value_MapsTo hm) in nabove. + eapply level_value_above_MapsTo in above as [k'0 [mk'0 le']]. + exists k'0. split => //. depelim le'. depelim nabove; constructor; lia. + specialize (hnupd _ H). exists k. split; [|reflexivity]. + now rewrite -hnupd. } + red. + intros l'. apply todo. + exact hnupd. + - intros l' hl'. specialize (hupd _ hl') as [prems [k' [v' [clin [minp [nabove above]]]]]]. + eapply level_value_above_MapsTo in above as [k2 [mk' leqk']]. depelim leqk'. now exists y. +Qed. + #[local] Instance clauses_conclusions_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_conclusions. Proof. intros cls cls' eq x. @@ -1854,11 +1954,6 @@ Proof. intros [] H'; depelim H'; constructor. lia. Qed. -Lemma level_value_not_above_spec m l k : level_value_above m l k = false -> opt_le Z.lt (level_value m l) (Some k). -Proof. - unfold level_value_above; destruct level_value => // hlt; constructor. lia. -Qed. - Lemma total_model_of_update w m l k : total_model_of w m -> total_model_of (LevelSet.add l w) (update_model m l k). Proof. rewrite /total_model_of => hint l'. rewrite LevelSet.add_spec. @@ -1871,6 +1966,123 @@ Proof. now exists x; eapply LevelMap.add_2. Qed. +Lemma update_value_spec w m cl w' m' : + update_value (w, m) cl = DoesntHold (w', m') -> + LevelSet.Equal w' (LevelSet.add (clause_conclusion cl) w) /\ strict_update m cl m'. +Proof. + unfold update_value. + destruct min_premise eqn:hmin => //. + destruct cl as [prems [concl k]]; cbn. + destruct level_value_above eqn:habove => //. + intros [= <-]. + intuition auto. reflexivity. + rewrite hmin. exists z; split => //. + rewrite habove. split => //. + subst m'. unfold level_value_above. + rewrite level_value_update_model. eapply Z.leb_le. lia. +Qed. + +Definition levelset_m_eq : LevelSet.t × model -> LevelSet.t × model -> Prop := + fun x y => LevelSet.Equal x.1 y.1 /\ LevelMap.Equal x.2 y.2. + +#[local] Instance lmeq_eq : Equivalence levelset_m_eq. +Proof. + split. intros x. split => //. + intros x y []; split => //. now rewrite H. + intros x y z [] []; split => //. + all:etransitivity; tea. +Qed. + +Definition modified_levelset_m_eq : bool × LevelSet.t × model -> bool × LevelSet.t × model -> Prop := + fun x y => x.1 = y.1 /\ levelset_m_eq x.2 y.2. + +#[local] Instance mlm_eq : Equivalence modified_levelset_m_eq. +Proof. + split. intros x. split => //. + intros x y []; split => //. now symmetry. + intros x y z [] []; split => //. all:etransitivity; tea. +Qed. + +#[local] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. +Proof. + intros m m' eqm ? ? ->. unfold min_atom_value. + destruct y => //. + now rewrite eqm. +Qed. + +#[local] Instance fold_left_ext {A B} : Proper (`=2` ==> eq ==> eq ==> eq) (@fold_left A B). +Proof. + intros f g hfg ? ? -> ? ? ->. + induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). +Qed. + +#[local] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. +Proof. + intros m m' eq ? ? ->. + unfold min_premise. + destruct to_nonempty_list. + now setoid_rewrite eq. +Qed. + +#[local] Instance update_model_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> LevelMap.Equal) update_model. +Proof. + intros m m' hm ? ? -> ? ? ->. + unfold update_model. + now rewrite hm. +Qed. + +#[local] Instance level_value_above_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> eq) level_value_above. +Proof. + intros m m' hm ? ? -> ? ? ->. + unfold level_value_above. + now rewrite hm. +Qed. + +#[local] Instance check_clause_model_proper : Proper (eq ==> modified_levelset_m_eq ==> modified_levelset_m_eq) check_clause_model. +Proof. + intros x y eq [? []] [? []] []; cbn in *; subst. + unfold levelset_m_eq in H0. destruct H0; cbn in *; subst. + replace (min_premise m (premise y)) with (min_premise m0 (premise y)). + 2: now rewrite H0. + destruct min_premise. + destruct concl => //. + replace (level_value_above m t1 (Z.of_nat n + z)) with (level_value_above m0 t1 (Z.of_nat n + z)). + 2:now rewrite H0. + destruct level_value_above => //. + red. cbn. split => //. + red. cbn; split => //. now rewrite H. now rewrite H0. + red. cbn. split => //. +Qed. + +Instance has_strict_update_proper : Proper (Clauses.Equal ==> LevelMap.Equal ==> eq ==> LevelMap.Equal ==> iff) has_strict_update. +Proof. + intros ? ? eqcl ? ? eqm ? ? eqs ? ? eqm'. + unfold has_strict_update, strict_update. subst y1. + setoid_rewrite eqcl. setoid_rewrite eqm. now setoid_rewrite eqm'. +Qed. + +Instance has_strict_update_W_proper : Proper (Clauses.Equal ==> LevelMap.Equal ==> LevelSet.Equal ==> LevelMap.Equal ==> iff) has_strict_update_W. +Proof. + intros ? ? eqcl ? ? eqm ? ? eqs ? ? eqm'. + unfold has_strict_update_W. + now setoid_rewrite eqcl; setoid_rewrite eqm; setoid_rewrite eqs; setoid_rewrite eqm'. +Qed. + +Instance model_map_outside_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) model_map_outside. +Proof. + intros ? ? eqcl ? ? eqm ? ? eqs. + unfold model_map_outside. + setoid_rewrite eqcl. now setoid_rewrite eqm; setoid_rewrite eqs. +Qed. + +#[local] Instance proper_levelexprset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) + levels. +Proof. + intros s s' eq l. + rewrite !levelexprset_levels_spec. + firstorder eauto. +Qed. + Lemma check_clause_model_modify' {cl cls w m w' m' w'' m'' modified modified'} : check_model_invariants cls w m w' m' modified -> declared_model_level m (clause_conclusion cl) -> @@ -1940,6 +2152,208 @@ Proof. + now eapply total_model_of_update. } Qed. + +Lemma min_premise_some_pres {m m' prems k} : m ⩽ m' -> min_premise m prems = Some k -> exists k', min_premise m' prems = Some k'. +Proof. + intros ext minp. + apply (@min_premise_pos_spec_inv m' prems). + intros x hin. + pose proof (min_premise_spec m prems) as [le eq]. specialize (le x hin). + rewrite minp in le. depelim le. + move: H0; rewrite /min_atom_value /levelexpr_value /level_value. destruct x as [l k']. + destruct LevelMap.find eqn:hfind => //. destruct o => //; intros [= <-]. + eapply LevelMap.find_2 in hfind. eapply ext in hfind as [? [map2 hsome]]. + eapply LevelMap.find_1 in map2. rewrite map2. depelim hsome. now exists y. +Qed. + +Lemma min_premise_spec' {m prems z} : min_premise m prems = Some z -> + (forall l k, LevelExprSet.In (l, k) prems -> + exists v, level_value m l = Some v /\ z <= (v - Z.of_nat k))%Z. +Proof. + intros hmin. + have [hall hhmin'] := min_premise_spec m prems. + intros l k hin; specialize (hall _ hin). rewrite hmin in hall. + depelim hall. destruct level_value => //. noconf H0. exists z0. split => //. +Qed. + +Lemma nonEmptyLevelExprSet_elim {P : nonEmptyLevelExprSet -> Prop} : + (forall le, P (singleton le)) -> + (forall le prems, P prems -> P (add le prems)) -> + forall prems, P prems. +Proof. + intros hs ha. + intros []. + revert t_set0 t_ne0. + apply: LevelExprSetProp.set_induction; eauto. + - move=> s /LevelExprSetFact.is_empty_1 he ne; exfalso => //. congruence. + - intros s s' IH x nin hadd hne. + destruct (LevelExprSet.is_empty s) eqn:hem in |- . + eapply LevelExprSetFact.is_empty_2 in hem. + assert (singleton x = {| t_set := s'; t_ne := hne |}) as <- => //. + unfold singleton. apply eq_univ'. cbn. + intros a. specialize (hadd a). rewrite hadd. + rewrite LevelExprSet.singleton_spec. firstorder. subst. reflexivity. + specialize (IH hem). + specialize (ha x _ IH). + assert (LevelExprSet.Equal (add x {| t_set := s; t_ne := hem|}) {| t_set := s'; t_ne := hne |}). + 2:{ apply eq_univ' in H. now rewrite -H. } + intros x'. specialize (hadd x'). rewrite LevelExprSet.add_spec. + cbn. firstorder. subst x'. now left. +Qed. + +Lemma min_premise_pres {m m'} prems : m ⩽ m' -> min_premise m prems ≤ min_premise m' prems. +Proof. + intros ext. + destruct (min_premise m prems) eqn:hmin. + have leq := min_premise_spec' hmin. 2:constructor. + have [leq' e'] := min_premise_spec m' prems. + destruct (min_premise_spec m prems) as [_ [minz [inminz eqminz]]]. + rewrite hmin in eqminz. + rewrite eqminz. destruct e' as [min' []]. rewrite H0. + transitivity (min_atom_value m min'). + 2:{ unfold min_atom_value. destruct min'. + unfold level_value. destruct (LevelMap.find t m) eqn:hfind. destruct o => //. 2:constructor. + apply LevelMap.find_2 in hfind. apply ext in hfind as [k' [hfind hle]]. + apply LevelMap.find_1 in hfind. rewrite hfind. depelim hle. constructor. lia. constructor. + } + destruct min'. specialize (leq _ _ H) as [? []]. + unfold min_atom_value at 2. rewrite H1. rewrite -eqminz. constructor. lia. +Qed. + +Lemma level_value_above_mon m m' l k : m ⩽ m' -> level_value_above m l k -> level_value_above m' l k. +Proof. + intros ext; move/level_value_above_MapsTo => [v [hm hleq]]. + eapply ext in hm. destruct hm as [v' [hm' leq']]. depelim hleq. depelim leq'. + eapply level_value_above_MapsTo'; tea. now constructor; lia. +Qed. + +Lemma strict_update_ext_right m cl m' m'' : strict_update m cl m' -> m' ⩽ m'' -> strict_update m cl m''. +Proof. + destruct cl as [prems [concl k]]. unfold strict_update. + intros [minp [eqminp [ha hna]]] leq. + exists minp. split => //. split => //. + eapply level_value_above_mon; tea. +Qed. + +Definition enabled_clause (m : model) (cl : clause) := + isSome (min_premise m (premise cl)). + +Definition enabled_clauses (m : model) (cls : clauses) := + Clauses.for_all (enabled_clause m) cls. + +(* Lemma strict_update_ext_left m cl m' m'' : strict_update m cl m ⩽ m' -> strict_update m' cl m'' -> strict_update m cl m''. +Proof. + destruct cl as [prems [concl k]]. unfold strict_update. + intros leq [minp [eqminp [ha hna]]]. + exists minp. split => //. split => //. + eapply level_value_above_mon; tea. +Qed. + *) + +Lemma strict_update_outside w m m' m'' cl : + m ⩽ m' -> m' ⩽ m'' -> + model_map_outside w m m' -> + enabled_clause m cl -> + ~ LevelSet.In (clause_conclusion cl) w -> strict_update m' cl m'' -> strict_update m cl m''. +Proof. + intros mext mext' wout enabled nout. + apply wout in nout. + destruct cl as [prems [concl k]]. + unfold strict_update. + intros [v [minv []]]. + cbn in nout. + unfold enabled_clause in enabled. cbn in enabled. destruct min_premise eqn:hmin => //. exists z; split=> //. + split => //. + have hp := (min_premise_pres prems mext). rewrite hmin minv in hp. depelim hp. + 2:{ eapply level_value_above_mon; tea. eapply level_value_above_MapsTo'; tea. rewrite -nout. } + Admitted. + +Definition has_strict_update_from cls m l m' := + exists prems k, Clauses.In (prems, (l, k)) cls /\ + exists minter, m ⩽ minter /\ strict_update minter (prems, (l, k)) m'. + +Definition has_strict_update_from_W cls m W m' := + forall l, LevelSet.In l W -> has_strict_update_from cls m l m'. + +Lemma has_strict_update_W_trans cls m w m' cl m'' : + m' ⩽ m'' -> + has_strict_update_from_W cls m w m' -> + model_map_outside w m m' -> + strict_update m' cl m'' -> + has_strict_update_from_W (Clauses.add cl cls) m (LevelSet.add (clause_conclusion cl) w) m''. +Proof. + intros mleq updW outw su. + destruct cl as [prems [concl k]]. + intros l; rewrite LevelSet.add_spec. + destruct (inLevelSet w concl). + - intros [->|inw]. + * cbn. + apply updW in H. + destruct H as [prems' [k' [hin hstr]]]. + unfold has_strict_update_from. setoid_rewrite Clauses.add_spec. + do 2 eexists; split. right. exact hin. + destruct hstr as [minter [leqinter hstr]]. + exists m'. split. + Admitted. + { transitivity minter => //. red. } + move: su hstr. unfold strict_update. + intros [v [minv []]] [minter [leqinter [v' [minv' []]]]]. + exists m'. split. + { transitivity minter => //. + {} + exists v'. split => //. split => //. eapply level_value_above_mon; tea. + * eapply updW in inw. + destruct inw as [prems' [k' [hin hstr]]]. + red. do 2 eexists; split. rewrite Clauses.add_spec. right; tea. + move: su hstr. unfold strict_update. + intros [v [minv []]] [v' [minv' []]]. + exists v'. split => //. split => //. eapply level_value_above_mon; tea. + - intros [->|inw]. + * unfold has_strict_update. cbn -[strict_update]. + exists prems, k. split. rewrite Clauses.add_spec. now left. + + + have minp := min_premise_pres prems' mleq. + rewrite minv' in minp. depelim minp. + + + exists v. split => //. 2:split => //. *) +Admitted. + +Lemma check_clause_model_update {cl cls w m w' m' m'' modified modified'} : + is_update cls m w m' -> + declared_model_level m (clause_conclusion cl) -> + check_clause_model cl (modified, (w, m')) = (modified', (w', m'')) -> + is_update (Clauses.add cl cls) m w' m''. +Proof. + intros isupd hdecl. + unfold check_clause_model. + destruct update_value eqn:upd. + * intros [= <- <-]. subst m''. + red. unfold has_strict_update_W, has_strict_update. setoid_rewrite Clauses.add_spec. + destruct isupd. intuition eauto. + specialize (H _ H1) as [? [? [? ?]]]; intuition auto. do 3 eexists; intuition eauto. + * intros [= <- <-]. subst m''. + red. unfold has_strict_update_W, has_strict_update. setoid_rewrite Clauses.add_spec. + destruct isupd. intuition eauto. + specialize (H _ H1) as [? [? [? ?]]]; intuition auto. do 3 eexists; intuition eauto. + * intros [= <- ->]. + red. + eapply update_value_spec in upd as [hw' hsupd]. + destruct isupd as [hupd hnupd]. setoid_rewrite hw'. clear w' hw'. + destruct cl as [prems [concl k]]; cbn. + split. + { cbn. intros l [hl|hl]. subst l. + do 2 eexists. repeat split; eauto. cbn -[strict_update]. + specialize (hupd l ) + move: upd; unfold update_value. + destruct min_premise eqn:hmin. + have sub := update_value pose proof (inLe) + + } + specialize (H _ H1) as [? [? [? ?]]]; intuition auto. do 3 eexists; intuition eauto. + + Definition model_of V (m : model) := forall k, LevelSet.In k V -> LevelMap.In k m. @@ -2176,78 +2590,6 @@ Proof. destruct hlevels as [_ nw]. specialize (vm nw). now depelim vm. } Qed. -Definition levelset_m_eq : LevelSet.t × model -> LevelSet.t × model -> Prop := - fun x y => LevelSet.Equal x.1 y.1 /\ LevelMap.Equal x.2 y.2. - -#[local] Instance lmeq_eq : Equivalence levelset_m_eq. -Proof. - split. intros x. split => //. - intros x y []; split => //. now rewrite H. - intros x y z [] []; split => //. - all:etransitivity; tea. -Qed. - -Definition modified_levelset_m_eq : bool × LevelSet.t × model -> bool × LevelSet.t × model -> Prop := - fun x y => x.1 = y.1 /\ levelset_m_eq x.2 y.2. - -#[local] Instance mlm_eq : Equivalence modified_levelset_m_eq. -Proof. - split. intros x. split => //. - intros x y []; split => //. now symmetry. - intros x y z [] []; split => //. all:etransitivity; tea. -Qed. - -#[local] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. -Proof. - intros m m' eqm ? ? ->. unfold min_atom_value. - destruct y => //. - now rewrite eqm. -Qed. - -#[local] Instance fold_left_ext {A B} : Proper (`=2` ==> eq ==> eq ==> eq) (@fold_left A B). -Proof. - intros f g hfg ? ? -> ? ? ->. - induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). -Qed. - -#[local] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. -Proof. - intros m m' eq ? ? ->. - unfold min_premise. - destruct to_nonempty_list. - now setoid_rewrite eq. -Qed. - -#[local] Instance update_model_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> LevelMap.Equal) update_model. -Proof. - intros m m' hm ? ? -> ? ? ->. - unfold update_model. - now rewrite hm. -Qed. - -#[local] Instance level_value_above_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> eq) level_value_above. -Proof. - intros m m' hm ? ? -> ? ? ->. - unfold level_value_above. - now rewrite hm. -Qed. - -#[local] Instance check_clause_model_proper : Proper (eq ==> modified_levelset_m_eq ==> modified_levelset_m_eq) check_clause_model. -Proof. - intros x y eq [? []] [? []] []; cbn in *; subst. - unfold levelset_m_eq in H0. destruct H0; cbn in *; subst. - replace (min_premise m (premise y)) with (min_premise m0 (premise y)). - 2: now rewrite H0. - destruct min_premise. - destruct concl => //. - replace (level_value_above m t1 (Z.of_nat n + z)) with (level_value_above m0 t1 (Z.of_nat n + z)). - 2:now rewrite H0. - destruct level_value_above => //. - red. cbn. split => //. - red. cbn; split => //. now rewrite H. now rewrite H0. - red. cbn. split => //. -Qed. - Module ClausesOrd := OrdProperties Clauses. @@ -3152,15 +3494,6 @@ Definition add_max l k m := else m | _ => LevelMap.add l (Some k) m end. - -#[local] Instance proper_levelexprset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) - levels. -Proof. - intros s s' eq l. - rewrite !levelexprset_levels_spec. - firstorder eauto. -Qed. - Lemma In_add_max l l' k acc : LevelMap.In (elt:=option Z) l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). @@ -3788,12 +4121,6 @@ Equations check {V init cls} (m : valid_model V V init cls) (cl : clause) : bool | None => false end. -Definition enabled_clause (m : model) (cl : clause) := - isSome (min_premise m (premise cl)). - -Definition enabled_clauses (m : model) (cls : clauses) := - Clauses.for_all (enabled_clause m) cls. - Section Semantics. Section Interpretation. @@ -3935,72 +4262,6 @@ Proof. eapply Clauses.for_all_spec in ism; tc. now specialize (ism _ hin). Qed. -Lemma min_premise_some_pres {m m' prems k} : m ⩽ m' -> min_premise m prems = Some k -> exists k', min_premise m' prems = Some k'. -Proof. - intros ext minp. - apply (@min_premise_pos_spec_inv m' prems). - intros x hin. - pose proof (min_premise_spec m prems) as [le eq]. specialize (le x hin). - rewrite minp in le. depelim le. - move: H0; rewrite /min_atom_value /levelexpr_value /level_value. destruct x as [l k']. - destruct LevelMap.find eqn:hfind => //. destruct o => //; intros [= <-]. - eapply LevelMap.find_2 in hfind. eapply ext in hfind as [? [map2 hsome]]. - eapply LevelMap.find_1 in map2. rewrite map2. depelim hsome. now exists y. -Qed. - -Lemma min_premise_spec' {m prems z} : min_premise m prems = Some z -> - (forall l k, LevelExprSet.In (l, k) prems -> - exists v, level_value m l = Some v /\ z <= (v - Z.of_nat k))%Z. -Proof. - intros hmin. - have [hall hhmin'] := min_premise_spec m prems. - intros l k hin; specialize (hall _ hin). rewrite hmin in hall. - depelim hall. destruct level_value => //. noconf H0. exists z0. split => //. -Qed. - -Lemma nonEmptyLevelExprSet_elim {P : nonEmptyLevelExprSet -> Prop} : - (forall le, P (singleton le)) -> - (forall le prems, P prems -> P (add le prems)) -> - forall prems, P prems. -Proof. - intros hs ha. - intros []. - revert t_set0 t_ne0. - apply: LevelExprSetProp.set_induction; eauto. - - move=> s /LevelExprSetFact.is_empty_1 he ne; exfalso => //. congruence. - - intros s s' IH x nin hadd hne. - destruct (LevelExprSet.is_empty s) eqn:hem in |- . - eapply LevelExprSetFact.is_empty_2 in hem. - assert (singleton x = {| t_set := s'; t_ne := hne |}) as <- => //. - unfold singleton. apply eq_univ'. cbn. - intros a. specialize (hadd a). rewrite hadd. - rewrite LevelExprSet.singleton_spec. firstorder. subst. reflexivity. - specialize (IH hem). - specialize (ha x _ IH). - assert (LevelExprSet.Equal (add x {| t_set := s; t_ne := hem|}) {| t_set := s'; t_ne := hne |}). - 2:{ apply eq_univ' in H. now rewrite -H. } - intros x'. specialize (hadd x'). rewrite LevelExprSet.add_spec. - cbn. firstorder. subst x'. now left. -Qed. - -Lemma min_premise_pres m m' prems : m ⩽ m' -> min_premise m prems ≤ min_premise m' prems. -Proof. - intros ext. - destruct (min_premise m prems) eqn:hmin. - have leq := min_premise_spec' hmin. 2:constructor. - have [leq' e'] := min_premise_spec m' prems. - destruct (min_premise_spec m prems) as [_ [minz [inminz eqminz]]]. - rewrite hmin in eqminz. - rewrite eqminz. destruct e' as [min' []]. rewrite H0. - transitivity (min_atom_value m min'). - 2:{ unfold min_atom_value. destruct min'. - unfold level_value. destruct (LevelMap.find t m) eqn:hfind. destruct o => //. 2:constructor. - apply LevelMap.find_2 in hfind. apply ext in hfind as [k' [hfind hle]]. - apply LevelMap.find_1 in hfind. rewrite hfind. depelim hle. constructor. lia. constructor. - } - destruct min'. specialize (leq _ _ H) as [? []]. - unfold min_atom_value at 2. rewrite H1. rewrite -eqminz. constructor. lia. -Qed. (* If a clause checks, then it should be valid in any extension of the model *) Lemma check_entails {V init cls} (m : valid_model V V init cls) (cl : clause) : From c6b5f95154b2970f62ba86c58d98521d72d12397 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 29 Jul 2025 02:24:04 +0200 Subject: [PATCH 009/164] Before removing U set --- template-rocq/theories/PartialLoopChecking.v | 1696 ++++++++++-------- 1 file changed, 946 insertions(+), 750 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 788d673c8..8025823d0 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -47,6 +47,7 @@ Module Type LevelOrderedType. Parameter reflect_eq : ReflectEq t. #[local] Existing Instance reflect_eq. + Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. Parameter to_string : t -> string. @@ -57,6 +58,10 @@ Module Type FMapOTInterface (E : UsualOrderedType). Include FMapInterface.Sfun OT. End FMapOTInterface. +Module Type LevelSet_fun (Level : LevelOrderedType). + Include SWithLeibniz with Module E := Level. +End LevelSet_fun. + Module Type LevelExprItf (Level : LevelOrderedType). Include UsualOrderedType with Definition t := (Level.t * nat)%type. Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. @@ -76,7 +81,7 @@ Module Type LevelExprSet_fun (Level : LevelOrderedType) (LevelExpr : LevelExprIt End LevelExprSet_fun. Module Type LoopCheckingItf (Level : LevelOrderedType) - (LevelSet : MSetInterface.SetsOn Level) + (LevelSet : LevelSet_fun Level) (LevelExpr : LevelExprItf Level) (LevelExprSet : LevelExprSet_fun Level LevelExpr) (LevelMap : FMapOTInterface Level). @@ -130,7 +135,7 @@ End LoopCheckingItf. Module LoopChecking (* Signature of levels: decidable, ordered type *) (Level : LevelOrderedType) - (LevelSet : MSetInterface.SetsOn Level) + (LevelSet : LevelSet_fun Level) (LevelExpr : LevelExprItf Level) (LevelExprSet : LevelExprSet_fun Level LevelExpr) (LevelMap : FMapOTInterface Level) <: LoopCheckingItf Level LevelSet LevelExpr LevelExprSet LevelMap. @@ -200,10 +205,13 @@ Ltac lesets := LevelExprSetDecide.fsetdec. Infix "⊂_leset" := LevelExprSet.Subset (at level 70). Lemma levelset_not_Empty_is_empty s : - LevelSet.is_empty s = false -> ~ LevelSet.Empty s. + LevelSet.is_empty s = false <-> ~ LevelSet.Empty s. Proof. - intros H he. red in he. apply negbT in H. unshelve eapply (contraNnot _ H). - 3:exact he. intros ha. now apply LevelSetFact.is_empty_1. + split. + - intros H he. red in he. apply negbT in H. unshelve eapply (contraNnot _ H). + 3:exact he. intros ha. now apply LevelSetFact.is_empty_1. + - intros ne. destruct LevelSet.is_empty eqn:he => //. + eapply LevelSetFact.is_empty_2 in he. contradiction. Qed. Module NonEmptySetFacts. @@ -608,6 +616,8 @@ Proof. now rewrite LevelSet.union_spec LevelSet.singleton_spec. Qed. +Definition clause_conclusion cl := levelexpr_level (concl cl). + Definition model := LevelMap.t (option Z). Definition level_value (m : model) (level : Level.t) : option Z := @@ -679,11 +689,10 @@ Inductive update_result := Definition update_model (m : model) l v : model := LevelMap.add l (Some v) m. -Definition update_value (wm : LevelSet.t × model) (cl : clause) : update_result := - let (w, m) := wm in +Definition update_value (m : model) (cl : clause) : option model := let k0 := min_premise m (premise cl) in match k0 with - | None => VacuouslyTrue + | None => None | Some k0 => let (l, k) := concl cl in (* Does the conclusion also hold? @@ -691,60 +700,377 @@ Definition update_value (wm : LevelSet.t × model) (cl : clause) : update_result we do it already while checking the clause. In the paper, a second pass computes this. *) - if level_value_above m l (Z.of_nat k + k0) then Holds - else DoesntHold (LevelSet.add l w, update_model m l (Z.of_nat k + k0)) + if level_value_above m l (Z.of_nat k + k0) then None + else Some (update_model m l (Z.of_nat k + k0)) end. -Definition check_clause_model cl '(modified, wm) := - match update_value wm cl with - | VacuouslyTrue => (modified, wm) - | DoesntHold wm' => (true, wm') - | Holds => (modified, wm) +Definition check_clause_model cl '(modified, m) := + match update_value m cl with + | None => (modified, m) + | Some m => (clause_conclusion cl :: modified, m) end. -Definition check_model_aux (cls : clauses) (wm : LevelSet.t × model) : bool × LevelSet.t × model := - Clauses.fold check_clause_model cls (false, wm). +Definition check_model_aux (cls : clauses) (wm : list Level.t × model) : list Level.t × model := + Clauses.fold check_clause_model cls wm. (* If check_model = None then we have a model of all clauses, othewise, we return Some (W', m') where W ⊂ W' and the model has been updated for at least one atom l ∈ W'. *) -Definition check_model (cls : clauses) (m : model) : option (LevelSet.t × model) := - let '(modified, (w, m)) := check_model_aux cls (LevelSet.empty, m) in - match LevelSet.is_empty w with - | true => None - | false => Some (w, m) +Definition check_model (cls : clauses) (wm : LevelSet.t × model) : option (LevelSet.t × model) := + let '(modified, m) := check_model_aux cls ([], wm.2) in + match modified return option (LevelSet.t × model) with + | [] => None + | l => Some ((LevelSet.union (LevelSetProp.of_list l) wm.1), m) + end. + +Definition strict_update m '(prems, (l, k)) m' := + exists v, min_premise m prems = Some v + /\ ~~ level_value_above m l (Z.of_nat k + v) /\ + LevelMap.Equal m' (LevelMap.add l (Some (Z.of_nat k + v)) m). + +Inductive strictly_updates cls : LevelSet.t -> model -> model -> Prop := +| update_one m cl m' : Clauses.In cl cls -> + strict_update m cl m' -> strictly_updates cls (LevelSet.singleton (clause_conclusion cl)) m m' +| update_trans {ls ls' m m' m''} : + strictly_updates cls ls m m' -> + strictly_updates cls ls' m' m'' -> + strictly_updates cls (LevelSet.union ls ls') m m''. + +Lemma strictly_updates_step cls w m m' m'' : + strictly_updates cls w m m' -> + forall cl, Clauses.In cl cls -> strict_update m' cl m'' -> + strictly_updates cls (LevelSet.add (clause_conclusion cl) w) m m''. +Proof. + induction 1. + - intros. + replace (LevelSet.add (clause_conclusion cl0) (LevelSet.singleton (clause_conclusion cl))) + with (LevelSet.union (LevelSet.singleton (clause_conclusion cl)) (LevelSet.singleton (clause_conclusion cl0))). + eapply update_trans; eapply update_one; tea. + eapply LevelSet.eq_leibniz. red. lsets. + - intros. + specialize (IHstrictly_updates2 _ H1 H2). + replace (LevelSet.add (clause_conclusion cl) (LevelSet.union ls ls')) + with (LevelSet.union ls (LevelSet.add (clause_conclusion cl) ls')). + eapply update_trans; tea. + eapply LevelSet.eq_leibniz. red. lsets. +Qed. + +Lemma strictly_updates_weaken cls w cls' : + Clauses.Subset cls cls' -> + forall m m', strictly_updates cls w m m' -> strictly_updates cls' w m m'. +Proof. + intros hcls m m'. + induction 1. constructor => //. now eapply hcls. + econstructor 2; tea. +Qed. + +Lemma strictly_updates_W_trans cls m w m' cl m'' : + strictly_updates cls w m m' -> + strict_update m' cl m'' -> + strictly_updates (Clauses.add cl cls) (LevelSet.add (clause_conclusion cl) w) m m''. +Proof. + intros updW su. + destruct cl as [prems [concl k]]. + eapply strictly_updates_step; tea. + - eapply strictly_updates_weaken; tea. clsets. + - rewrite Clauses.add_spec. left; reflexivity. +Qed. + +#[local] Instance Clauses_For_All_proper : Proper (eq ==> Clauses.Equal ==> iff) Clauses.For_all. +Proof. + intros x y -> cl cl' eqcl. + unfold Clauses.For_all. now setoid_rewrite eqcl. +Qed. + +#[local] Instance Clauses_for_all_proper : Proper (eq ==> Clauses.Equal ==> eq) Clauses.for_all. +Proof. + intros x y -> cl cl' eqcl. + apply iff_is_true_eq_bool. + rewrite /is_true -!ClausesFact.for_all_iff. now rewrite eqcl. +Qed. + +#[local] Instance is_model_proper : Proper (Clauses.Equal ==> eq ==> eq) is_model. +Proof. + intros cl cl' eqcl x y ->. unfold is_model. now rewrite eqcl. +Qed. + + +Definition equal_model (m m' : model) := LevelMap.Equal m m'. + +#[local] Instance equal_model_equiv : Equivalence equal_model. +Proof. unfold equal_model. + split; try econstructor; eauto. + red. intros. now symmetry. + red; intros. now transitivity y. +Qed. + + +#[local] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. +Proof. + intros x y eqm l ? <-. unfold level_value. + unfold equal_model in eqm. + destruct LevelMap.find eqn:hl. + - eapply LevelMap.find_2 in hl. + rewrite eqm in hl. + eapply LevelMap.find_1 in hl. now rewrite hl. + - eapply LevelMapFact.F.not_find_in_iff in hl. + rewrite eqm in hl. + eapply LevelMapFact.F.not_find_in_iff in hl. + now rewrite hl. +Qed. + +#[local] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. +Proof. + intros m m' eqm ? ? ->. unfold min_atom_value. + destruct y => //. + now rewrite eqm. +Qed. + +#[local] Instance fold_left_ext {A B} : Proper (`=2` ==> eq ==> eq ==> eq) (@fold_left A B). +Proof. + intros f g hfg ? ? -> ? ? ->. + induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). +Qed. + +#[local] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. +Proof. + intros m m' eq ? ? ->. + unfold min_premise. + destruct to_nonempty_list. + now setoid_rewrite eq. +Qed. + +#[local] Instance update_model_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> LevelMap.Equal) update_model. +Proof. + intros m m' hm ? ? -> ? ? ->. + unfold update_model. + now rewrite hm. +Qed. + +#[local] Instance level_value_above_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> eq) level_value_above. +Proof. + intros m m' hm ? ? -> ? ? ->. + unfold level_value_above. + now rewrite hm. +Qed. + +#[local] Instance check_model_aux_proper : Proper (Clauses.Equal ==> eq ==> eq) check_model_aux. +Proof. +Admitted. + +#[local] Instance check_model_proper : Proper (Clauses.Equal ==> eq ==> eq) check_model. +Proof. + intros cls cls' eq. + intros wm wm' ->. + unfold check_model. + destruct (check_model_aux cls _) eqn:eqc. + destruct (check_model_aux cls' _) eqn:eqc' => //. + pose proof (check_model_aux_proper cls cls' eq ([], wm'.2) _ eq_refl). + rewrite eqc eqc' in H. noconf H. + destruct l => //. +Qed. + +Instance strictly_updates_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) strictly_updates. +Proof. + intros ? ? H ? ? H' ? ? H'' ? ? H'''. + eapply LevelSet.eq_leibniz in H'. subst y0. + split. + induction 1 in y, H, y1, H'', y2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. + now rewrite <- H. move: H1; unfold strict_update. destruct cl as [premse []]. + try setoid_rewrite <- H; + try setoid_rewrite <- H''; + try setoid_rewrite <- H'''; firstorder. + eapply IHstrictly_updates1; firstorder. firstorder. + induction 1 in x, H, x1, H'', x2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. + now rewrite H. move: H1; unfold strict_update. destruct cl as [premse []]. + try setoid_rewrite H; + try setoid_rewrite H''; + try setoid_rewrite H'''; firstorder. + eapply IHstrictly_updates1; firstorder. firstorder. +Qed. + + +Lemma update_value_valid {m cl} : + match update_value m cl with + | None => valid_clause m cl + | Some _ => ~~ valid_clause m cl end. +Proof. + unfold update_value, valid_clause. + destruct cl as [prem [l k]]; cbn. + destruct min_premise => //. + unfold level_value_above. + destruct level_value => //. + destruct Z.leb => //. +Qed. -Lemma check_model_aux_subset {cls w v} : - forall modified w' v', check_model_aux cls (w, v) = (modified, (w', v')) -> LevelSet.Subset w w'. -Proof. - intros modified w' v'. - unfold check_model, check_model_aux, check_clause_model. revert modified w' v'. - eapply ClausesProp.fold_rec => //. - { intros. noconf H0. reflexivity. } - intros x a s' s'' hin nin hadd IH. - intros modified' w' v'. destruct a. - unfold update_value. - destruct x as [prem [l k]]; cbn. - destruct p. - destruct min_premise as [k0|] eqn:hk0. - 2:apply IH. - destruct level_value_above. - - intros [= -> -> ->] => //. now eapply IH. - - intros [= <- <- <-]. intros x inx. - eapply LevelSet.add_spec. - specialize (IH _ _ _ eq_refl). - now right. +Lemma check_clause_model_spec {cl w m w' m'} : + check_clause_model cl (w, m) = (w', m') -> + (w = w' -> m = m' /\ valid_clause m cl) /\ + (w <> w' -> w' = clause_conclusion cl :: w /\ + strictly_updates (Clauses.singleton cl) (LevelSet.singleton (clause_conclusion cl)) m m'). +Proof. + unfold check_clause_model. + destruct update_value eqn:upd; revgoals. + * intros [= <- <-]. split => //. split => //. + move: (@update_value_valid m cl). now rewrite upd. + * intros [= <- <-]. split => //. + + intros. eapply (f_equal (@List.length _)) in H. cbn in H; lia. + + intros _. split => //. constructor. clsets. unfold strict_update. + move: upd. unfold update_value. + destruct cl as [prems [concl k]]. cbn. + destruct min_premise => //. + destruct level_value_above eqn:hl => //. + intros [= <-]. + exists z. split => //. rewrite hl. split => //. +Qed. + +Derive Signature for InA. + +Lemma check_model_aux_spec {cls w m w' m'} : + check_model_aux cls (w, m) = (w', m') -> + (w = w' -> m = m' /\ is_model cls m) /\ + (w <> w' -> exists pref, w' = pref ++ w /\ strictly_updates cls (LevelSetProp.of_list pref) m m'). +Proof. + rewrite /check_model_aux /is_model. + revert w' m'. + eapply ClausesProp.fold_rec. + - intros s' he w' m' [= <- <-]. split => //. split => //. + eapply Clauses.for_all_spec. tc. intros x hin. now apply he in hin. + - clear. intros x [w'' m''] s' s'' inx nins' hadd ih w' m' cl. + specialize (ih _ _ eq_refl) as[]. + split; intros; subst. + + eapply check_clause_model_spec in cl as []. + destruct (eqb_spec w' w''). + { subst w''. specialize (H eq_refl) as []. specialize (H1 eq_refl) as []. split => //. congruence. + eapply Clauses.for_all_spec in H3. eapply Clauses.for_all_spec. all:tc. + intros ? hin. eapply hadd in hin as []; subst; firstorder. } + forward H0 by auto. forward H2 by auto. + destruct H0 as [pref [-> su]]. + destruct pref; cbn in *; try congruence. + destruct H2. eapply (f_equal (@List.length _)) in H0; cbn in H0. rewrite length_app in H0. lia. + + eapply check_clause_model_spec in cl as []. + destruct (eqb_spec w w''). + { subst w''. specialize (H eq_refl) as []. subst m''. + destruct (eqb_spec w w'); subst; try congruence. + specialize (H3 H) as []. subst w'. exists [clause_conclusion x]. split => //. + replace (LevelSetProp.of_list [clause_conclusion x]) with (LevelSet.singleton (clause_conclusion x)). + eapply ClausesProp.Add_Equal in hadd. rewrite hadd. eapply strictly_updates_weaken; tea. clsets. + eapply LevelSet.eq_leibniz. red. intros ?. rewrite LevelSetProp.of_list_1. firstorder. constructor. + rewrite LevelSet.singleton_spec in H3. firstorder. depelim H3. subst. lsets. depelim H3. } + specialize (H0 H4). + destruct (eqb_spec w'' w'); subst. + { specialize (H2 eq_refl) as []; subst m''. + destruct H0 as [pref []]. subst w'. exists pref; split => //. + eapply strictly_updates_weaken; tea. intros ? ?. eapply hadd. clsets. } + forward H3 by auto. destruct H3 as [->]. + destruct H0 as [pref [-> su]]. eexists (clause_conclusion x :: pref); split => //. + replace (LevelSetProp.of_list (clause_conclusion x :: pref)) with (LevelSet.union (LevelSetProp.of_list pref) (LevelSet.singleton (clause_conclusion x))). + eapply (strictly_updates_weaken _ _ s'') in su; tea; try firstorder. + eapply (strictly_updates_weaken _ _ s'') in H3; tea; try firstorder. + 2:{ intros ?; rewrite Clauses.singleton_spec. intros ->. now apply hadd. } + exact: update_trans _ su H3. + apply LevelSet.eq_leibniz. intros ?. cbn. lsets. +Qed. + +Lemma check_model_spec {cls w m w' m'} : + check_model cls (w, m) = Some (w', m') -> + exists w'', strictly_updates cls w'' m m' /\ w' = LevelSet.union w w''. +Proof. + unfold check_model. + destruct check_model_aux eqn:cm. + apply check_model_aux_spec in cm as []. + destruct l => //. forward H0. auto with datatypes. + intros [= <- <-]. destruct H0 as [pref [heq su]]. + rewrite app_nil_r in heq. subst pref. + exists (LevelSetProp.of_list (t :: l)). split => //. + eapply LevelSet.eq_leibniz. intros ?. cbn. lsets. +Qed. + + +Lemma strict_update_invalid m cl m' : strict_update m cl m' -> ~~ valid_clause m cl. +Proof. + destruct cl as [prems [concl k]]. + cbn. + intros [v [him [hna heq]]]. + rewrite /valid_clause. rewrite him //= hna. +Qed. + +Lemma strictly_updates_invalid cls w m m' : strictly_updates cls w m m' -> ~~ is_model cls m. +Proof. + induction 1. + - eapply strict_update_invalid in H0. + apply/negbT. unfold is_model. + destruct Clauses.for_all eqn:fa => //. + eapply Clauses.for_all_spec in fa; tc. eapply fa in H. + now rewrite H in H0. + - auto. +Qed. + +Lemma check_model_None {cls acc} : + check_model cls acc = None <-> is_model cls acc.2. +Proof. + unfold check_model. + destruct check_model_aux eqn:cm. + apply check_model_aux_spec in cm as [ne ex]. + destruct l => //. split => // _. now specialize (ne eq_refl) as []. + split => //. forward ex by auto with datatypes. destruct ex as [pref [eq su]]. + rewrite app_nil_r in eq; subst pref. + intros ism. eapply strictly_updates_invalid in su. + now rewrite ism in su. +Qed. + +Lemma check_model_updates_spec {cls w init_model m w' m'} : + check_model cls (w, m) = Some (w', m') -> + forall cls', strictly_updates cls' w init_model m -> + strictly_updates (Clauses.union cls cls') w' init_model m' /\ w ⊂_lset w'. +Proof. + move/check_model_spec => [w'' [su ->]]. + intros cls' su'. split. + eapply update_trans; eapply strictly_updates_weaken; tea; clsets. lsets. +Qed. + +Lemma strictly_updates_non_empty {cls W m m'} : + strictly_updates cls W m m' -> ~ LevelSet.Empty W. +Proof. + induction 1. + - intros he. specialize (he (clause_conclusion cl)). lsets. + - intros he. apply IHstrictly_updates2. lsets. +Qed. + +Definition clauses_conclusions (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.add (level (concl cl)) acc) cls LevelSet.empty. + +Lemma clauses_conclusions_spec a cls : + LevelSet.In a (clauses_conclusions cls) <-> + exists cl, Clauses.In cl cls /\ level (concl cl) = a. +Proof. + unfold clauses_conclusions. + eapply ClausesProp.fold_rec; clear. + - move=> s' he /=. rewrite LevelSetFact.empty_iff. + firstorder auto. + - move=> cl ls cls' cls'' hin hnin hadd ih. + rewrite LevelSet.add_spec. firstorder eauto. + specialize (H0 x). cbn in H0. + apply hadd in H1. firstorder eauto. + subst. left. now destruct x. +Qed. + +Lemma strictly_updates_incl {cls W m m'} : + strictly_updates cls W m m' -> W ⊂_lset clauses_conclusions cls. +Proof. + induction 1. + - intros x. rewrite clauses_conclusions_spec. firstorder. exists cl. + eapply LevelSet.singleton_spec in H1; red in H1; subst. split => //. + - lsets. Qed. Lemma check_model_subset {cls v} : forall w' v', check_model cls v = Some (w', v') -> ~ LevelSet.Empty w'. Proof. - intros w' v'. unfold check_model. - destruct check_model_aux eqn:cm. destruct p. - eapply check_model_aux_subset in cm. - destruct LevelSet.is_empty eqn:hem => //. - eapply levelset_not_Empty_is_empty in hem. now intros [= <- <-]. + intros w' v'. + move/check_model_spec => [w'' [su ->]]. + eapply strictly_updates_non_empty in su. intros em. apply su. lsets. Qed. Definition premise_restricted_to W cl := @@ -787,24 +1113,6 @@ Proof. destruct cl. rewrite LevelSet.mem_spec. cbn. firstorder eauto. Qed. -Definition clauses_conclusions (cls : clauses) : LevelSet.t := - Clauses.fold (fun cl acc => LevelSet.add (level (concl cl)) acc) cls LevelSet.empty. - -Lemma clauses_conclusions_spec a cls : - LevelSet.In a (clauses_conclusions cls) <-> - exists cl, Clauses.In cl cls /\ level (concl cl) = a. -Proof. - unfold clauses_conclusions. - eapply ClausesProp.fold_rec; clear. - - move=> s' he /=. rewrite LevelSetFact.empty_iff. - firstorder auto. - - move=> cl ls cls' cls'' hin hnin hadd ih. - rewrite LevelSet.add_spec. firstorder eauto. - specialize (H0 x). cbn in H0. - apply hadd in H1. firstorder eauto. - subst. left. now destruct x. -Qed. - Lemma clauses_conclusions_clauses_with_concl cls concl : LevelSet.Subset (clauses_conclusions (clauses_with_concl cls concl)) concl. Proof. @@ -1033,25 +1341,11 @@ Qed. Lemma clauses_empty_eq {s} : Clauses.Empty s -> Clauses.Equal s Clauses.empty. Proof. clsets. Qed. -Lemma update_value_valid {W m cl} : - match update_value (W, m) cl with - | VacuouslyTrue | Holds => valid_clause m cl - | DoesntHold _ => ~~ valid_clause m cl - end. -Proof. - unfold update_value, valid_clause. - destruct cl as [prem [l k]]; cbn. - destruct min_premise => //. - unfold level_value_above. - destruct level_value => //. - destruct Z.leb => //. -Qed. - -Lemma valid_update_value {W m cl} : +Lemma valid_update_value {m cl} : valid_clause m cl -> - match update_value (W, m) cl with - | VacuouslyTrue | Holds => true - | DoesntHold _ => false + match update_value m cl with + | None => true + | Some _ => false end. Proof. unfold update_value, valid_clause. @@ -1062,61 +1356,11 @@ Proof. destruct Z.leb => //. Qed. -Lemma check_model_aux_false {cls w acc w' acc'} : check_model_aux cls (w, acc) = (false, (w', acc')) -> w = w' /\ acc = acc'. -Proof. - unfold check_model_aux, check_clause_model. - revert w' acc'. - eapply ClausesProp.fold_rec. - - intros s emp w' acc' [=] => //. - - intros cl [w'' m''] cls' cls'' incl nincls' incls''. - intros IH w' acc'. - destruct update_value eqn:upd => //. - * intros [= -> ->]. now specialize (IH _ _ eq_refl). - * intros [= -> ->]. now specialize (IH _ _ eq_refl). -Qed. Lemma level_value_not_above_spec m l k : level_value_above m l k = false -> opt_le Z.lt (level_value m l) (Some k). Proof. unfold level_value_above; destruct level_value => // hlt; constructor. lia. Qed. -(* Lemma check_model_aux_true {cls acc acc'} : check_model_aux cls acc = (true, acc') -> acc = acc'. -Proof. - unfold check_model_aux. - eapply ClausesProp.fold_rec. - - intros s emp [=] => //. - - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. - intros IH. - destruct update_value eqn:upd => //. -Qed. *) - -Lemma check_model_aux_model {cls acc} : - check_model_aux cls acc = (false, acc) <-> is_model cls acc.2. -Proof. - unfold check_model_aux, check_clause_model. - unfold is_model. - unfold is_true; rewrite -ClausesFact.for_all_iff. - eapply ClausesProp.fold_rec. - - intros s emp. - split => //. - intros [=] x hx. clsets. - - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. - intros IH. - split. - * move: (@update_value_valid w' m' cl). - destruct update_value eqn:upd => //. 1-2:intros vcl [= -> <-]; - destruct IH as [IH _]; specialize (IH eq_refl). - intros x hx; apply incls'' in hx as []; subst. exact vcl. now apply IH. - intros x hx; apply incls'' in hx as []; subst. exact vcl. now apply IH. - * intros hf. - assert (valid_clause acc.2 cl). - { apply hf. apply incls''. intuition auto. } - destruct IH as [_ IH]. forward IH. - { intros x hx. apply hf. apply incls''. now right. } - noconf IH. - move: (@valid_update_value w' m' cl H). - destruct update_value eqn:upd => //. -Qed. - Lemma clauses_for_all_neg {p s}: ~~ Clauses.for_all p s <-> ~ Clauses.For_all p s. Proof. @@ -1168,63 +1412,52 @@ Proof. destruct level_value as [v|] eqn:hv; constructor; lia. Qed. -Lemma check_clause_model_inv {cl modified w m b wm'} : - check_clause_model cl (modified, (w, m)) = (b, wm') -> - m ⩽ wm'.2. +Lemma level_value_MapsTo {l k} {m : model} : + LevelMap.MapsTo l k m -> level_value m l = k. Proof. - unfold check_clause_model. - destruct (update_value (w, m) cl) eqn:upd. - * now intros [= <- <-]. - * now intros [= <- <-]. - * intros [= <- <-]. - move: upd. - unfold update_value. - destruct cl as [prem [l k]] => /=. - destruct min_premise as [k0|] eqn:hmin => //. - destruct level_value_above eqn:hval => //. - intros [= <-]. cbn. - now eapply update_model_not_above. -Qed. - -Lemma check_clause_model_intact {cl modified w m wm'} : - check_clause_model cl (modified, (w, m)) = (false, wm') -> valid_clause m cl /\ wm' = (w, m). + unfold level_value. + move=> mapto; rewrite (LevelMap.find_1 mapto) //. +Qed. + +Lemma level_value_MapsTo' {l k} {m : model} : + level_value m l = Some k -> LevelMap.MapsTo l (Some k) m. Proof. - unfold check_clause_model. - move: (@update_value_valid w m cl). - destruct (update_value (w, m) cl) eqn:upd. - * intros valid [= -> <-]. split => //. - * intros valid [= -> <-]. split => //. - * intros _ [=]. + unfold level_value. destruct LevelMap.find eqn:hfind => //. + eapply LevelMap.find_2 in hfind. now intros ->. Qed. -Lemma check_clause_model_modify {cl w m wm'} : - check_clause_model cl (false, (w, m)) = (true, wm') -> ~~ valid_clause m cl. + +Lemma strict_update_ext m cl m' : strict_update m cl m' -> m ⩽ m'. Proof. - unfold check_clause_model. - destruct (update_value (w, m) cl) eqn:upd. - * now intros [= <- <-]. - * now intros [= <- <-]. - * intros [= <-]. - move: upd. - unfold update_value, valid_clause. - destruct min_premise as [k0|] eqn:hmin => //. - destruct cl as [prem [l k]] => /=. - unfold level_value_above. - destruct level_value as [val|] eqn:hval => //. - case: Z.leb_spec => //. -Qed. - -Lemma check_model_aux_model_le {cls acc acc' b} : - check_model_aux cls acc = (b, acc') -> acc.2 ⩽ acc'.2. + destruct cl as [prems [concl k]]. + unfold strict_update. + intros [v [hm [ha heq]]]. + intros x k' hin. setoid_rewrite heq. + setoid_rewrite LevelMapFact.F.add_mapsto_iff. + destruct (Level.eq_dec concl x). subst. + move: ha; rewrite /level_value_above. + eapply level_value_MapsTo in hin. rewrite hin. + exists (Some (Z.of_nat k + v)). + split. left. split; reflexivity. + destruct k' => //; constructor. + move: ha. + rewrite -Z.ltb_antisym => /Z.ltb_lt hlt. lia. + exists k'. split => //. right; eauto. reflexivity. +Qed. + +Lemma strictly_updates_ext cls w m m' : strictly_updates cls w m m' -> m ⩽ m'. Proof. - unfold check_model_aux. - revert b acc'. - eapply ClausesProp.fold_rec. - - intros s emp b acc'. intros [=]. subst. reflexivity. - - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. - intros IH b acc'. - move/check_clause_model_inv. - specialize (IH _ _ eq_refl). cbn in IH. now intros; transitivity m'. + induction 1. + now eapply strict_update_ext in H0. + now transitivity m'. +Qed. + +Lemma check_model_le {cls acc acc'} : + check_model cls acc = Some acc' -> acc.2 ⩽ acc'.2. +Proof. + destruct acc as [w m], acc' as [w' m']. + move/check_model_spec => [w'' [su ->]]. + cbn. now eapply strictly_updates_ext. Qed. Lemma level_value_update_model m l k : @@ -1237,7 +1470,6 @@ Proof. exfalso. now apply n. Qed. - Lemma model_map_outside_weaken {W W'} {m m' : model} : model_map_outside W m m' -> W ⊂_lset W' -> @@ -1254,24 +1486,6 @@ Proof. now move=> ism ism' x /Clauses.union_spec []. Qed. -#[local] Instance Clauses_For_All_proper : Proper (eq ==> Clauses.Equal ==> iff) Clauses.For_all. -Proof. - intros x y -> cl cl' eqcl. - unfold Clauses.For_all. now setoid_rewrite eqcl. -Qed. - -#[local] Instance Clauses_for_all_proper : Proper (eq ==> Clauses.Equal ==> eq) Clauses.for_all. -Proof. - intros x y -> cl cl' eqcl. - apply iff_is_true_eq_bool. - rewrite /is_true -!ClausesFact.for_all_iff. now rewrite eqcl. -Qed. - -#[local] Instance is_model_proper : Proper (Clauses.Equal ==> eq ==> eq) is_model. -Proof. - intros cl cl' eqcl x y ->. unfold is_model. now rewrite eqcl. -Qed. - Lemma model_le_values {m m' : model} x : m ⩽ m' -> level_value m x ≤ level_value m' x. Proof. intros lem. specialize (lem x). @@ -1282,20 +1496,6 @@ Proof. - constructor. Qed. -Lemma level_value_MapsTo {l k} {m : model} : - LevelMap.MapsTo l k m -> level_value m l = k. -Proof. - unfold level_value. - move=> mapto; rewrite (LevelMap.find_1 mapto) //. -Qed. - -Lemma level_value_MapsTo' {l k} {m : model} : - level_value m l = Some k -> LevelMap.MapsTo l (Some k) m. -Proof. - unfold level_value. destruct LevelMap.find eqn:hfind => //. - eapply LevelMap.find_2 in hfind. now intros ->. -Qed. - Infix "⊂_clset" := Clauses.Subset (at level 70). Lemma max_gain_in cl cls : @@ -1397,7 +1597,7 @@ Proof. rewrite LevelSet.add_spec. split. * intros [->|]. - left. exists (levelexpr_k x). + left. exists (levelexpr_k x). red in H. subst. apply hadd. cbn. left. now destruct x. apply ih in H. intuition auto. @@ -1670,30 +1870,6 @@ Proof. intros hprem. Admitted. -Definition equal_model (m m' : model) := LevelMap.Equal m m'. - -#[local] Instance equal_model_equiv : Equivalence equal_model. -Proof. unfold equal_model. - split; try econstructor; eauto. - red. intros. now symmetry. - red; intros. now transitivity y. -Qed. - - -#[local] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. -Proof. - intros x y eqm l ? <-. unfold level_value. - unfold equal_model in eqm. - destruct LevelMap.find eqn:hl. - - eapply LevelMap.find_2 in hl. - rewrite eqm in hl. - eapply LevelMap.find_1 in hl. now rewrite hl. - - eapply LevelMapFact.F.not_find_in_iff in hl. - rewrite eqm in hl. - eapply LevelMapFact.F.not_find_in_iff in hl. - now rewrite hl. -Qed. - Lemma v_minus_w_bound_spec W m : forall x, ~ LevelSet.In x W -> level_value m x ≤ Some (v_minus_w_bound W m). Proof. @@ -1782,19 +1958,6 @@ Qed. Definition total_model_of V (m : model) := forall k, LevelSet.In k V -> exists x, LevelMap.MapsTo k (Some x) m. -Definition strict_update m '(prems, (l, k)) m' := - exists v, min_premise m prems = Some v - /\ ~~ level_value_above m l (Z.of_nat k + v) /\ level_value_above m' l (Z.of_nat k + v). - -Definition has_strict_update cls m l m' := exists prems k, Clauses.In (prems, (l, k)) cls /\ strict_update m (prems, (l, k)) m'. - -Definition has_strict_update_W cls m W m' := - (forall l, LevelSet.In l W -> has_strict_update cls m l m'). - -(** The values of levels in W result from consequences of existing constraints *) -Definition is_update cls m W m' := - has_strict_update_W cls m W m' /\ model_map_outside W m m'. - Definition check_model_invariants cls w m w' m' (modified : bool) := if modified then [/\ w ⊂_lset w', @@ -1838,7 +2001,12 @@ Qed. Axiom todo : forall {A}, A. -Lemma is_update_check_model_invariants cls m W m' : ~ LevelSet.Empty W -> is_update cls m W m' -> check_model_invariants cls LevelSet.empty m W m' true. +Lemma level_value_add m l k : level_value (LevelMap.add l k m) l = k. +Proof. + rewrite /level_value LevelMapFact.F.add_eq_o //. +Qed. + +(* Lemma is_update_check_model_invariants cls m W m' : ~ LevelSet.Empty W -> is_update cls m W m' -> check_model_invariants cls LevelSet.empty m W m' true. Proof. unfold is_update. intros hw [hupd hnupd]. unfold check_model_invariants. @@ -1853,10 +2021,9 @@ Proof. eexists; split; tea. rewrite /valid_clause. rewrite minp //=. cbn. move: nabove; unfold level_value_above. destruct level_value eqn:hlev; try constructor. - move: above. unfold level_value_above. - destruct (level_value m' l) => //. - move/Z.leb_le => hle. constructor. - rewrite -Z.ltb_antisym in nabove. move/Z.ltb_lt: nabove. lia. + rewrite above level_value_add. + intros nabove. rewrite -Z.ltb_antisym in nabove. + constructor. move/Z.ltb_lt: nabove. lia. - split. { intros l' k hm. destruct (inLevelSet W l'). @@ -1864,16 +2031,20 @@ Proof. eapply negbTE in nabove. eapply level_value_not_above_spec in nabove. rewrite (level_value_MapsTo hm) in nabove. - eapply level_value_above_MapsTo in above as [k'0 [mk'0 le']]. - exists k'0. split => //. depelim le'. depelim nabove; constructor; lia. + setoid_rewrite above. + exists (Some (Z.of_nat k' + clin)). split => //. + rewrite LevelMapFact.F.add_mapsto_iff. left; split => //. red. + depelim nabove; constructor; lia. specialize (hnupd _ H). exists k. split; [|reflexivity]. now rewrite -hnupd. } red. intros l'. apply todo. exact hnupd. - intros l' hl'. specialize (hupd _ hl') as [prems [k' [v' [clin [minp [nabove above]]]]]]. - eapply level_value_above_MapsTo in above as [k2 [mk' leqk']]. depelim leqk'. now exists y. -Qed. + setoid_rewrite above. eexists. + rewrite LevelMapFact.F.add_mapsto_iff. left. split => //. + (* eapply level_value_above_MapsTo in above as [k2 [mk' leqk']]. depelim leqk'. now exists y. *) +Qed. *) #[local] Instance clauses_conclusions_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_conclusions. Proof. @@ -1925,8 +2096,6 @@ Qed. Definition declared_model_level (m : model) l := LevelMap.In l m. -Definition clause_conclusion cl := levelexpr_level (concl cl). - Definition update_model_same_domain {m l k} : declared_model_level m l -> model_same_domain m (update_model m l k). @@ -1966,107 +2135,28 @@ Proof. now exists x; eapply LevelMap.add_2. Qed. -Lemma update_value_spec w m cl w' m' : - update_value (w, m) cl = DoesntHold (w', m') -> - LevelSet.Equal w' (LevelSet.add (clause_conclusion cl) w) /\ strict_update m cl m'. -Proof. - unfold update_value. - destruct min_premise eqn:hmin => //. - destruct cl as [prems [concl k]]; cbn. - destruct level_value_above eqn:habove => //. - intros [= <-]. - intuition auto. reflexivity. - rewrite hmin. exists z; split => //. - rewrite habove. split => //. - subst m'. unfold level_value_above. - rewrite level_value_update_model. eapply Z.leb_le. lia. -Qed. - -Definition levelset_m_eq : LevelSet.t × model -> LevelSet.t × model -> Prop := - fun x y => LevelSet.Equal x.1 y.1 /\ LevelMap.Equal x.2 y.2. +Definition levelset_m_eq : list Level.t × model -> list Level.t × model -> Prop := + fun x y => x.1 = y.1 /\ LevelMap.Equal x.2 y.2. #[local] Instance lmeq_eq : Equivalence levelset_m_eq. Proof. split. intros x. split => //. - intros x y []; split => //. now rewrite H. + intros x y []; split => //. intros x y z [] []; split => //. all:etransitivity; tea. Qed. -Definition modified_levelset_m_eq : bool × LevelSet.t × model -> bool × LevelSet.t × model -> Prop := - fun x y => x.1 = y.1 /\ levelset_m_eq x.2 y.2. - -#[local] Instance mlm_eq : Equivalence modified_levelset_m_eq. -Proof. - split. intros x. split => //. - intros x y []; split => //. now symmetry. - intros x y z [] []; split => //. all:etransitivity; tea. -Qed. - -#[local] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. -Proof. - intros m m' eqm ? ? ->. unfold min_atom_value. - destruct y => //. - now rewrite eqm. -Qed. - -#[local] Instance fold_left_ext {A B} : Proper (`=2` ==> eq ==> eq ==> eq) (@fold_left A B). -Proof. - intros f g hfg ? ? -> ? ? ->. - induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). -Qed. - -#[local] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. -Proof. - intros m m' eq ? ? ->. - unfold min_premise. - destruct to_nonempty_list. - now setoid_rewrite eq. -Qed. - -#[local] Instance update_model_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> LevelMap.Equal) update_model. -Proof. - intros m m' hm ? ? -> ? ? ->. - unfold update_model. - now rewrite hm. -Qed. - -#[local] Instance level_value_above_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> eq) level_value_above. -Proof. - intros m m' hm ? ? -> ? ? ->. - unfold level_value_above. - now rewrite hm. -Qed. - -#[local] Instance check_clause_model_proper : Proper (eq ==> modified_levelset_m_eq ==> modified_levelset_m_eq) check_clause_model. -Proof. - intros x y eq [? []] [? []] []; cbn in *; subst. - unfold levelset_m_eq in H0. destruct H0; cbn in *; subst. - replace (min_premise m (premise y)) with (min_premise m0 (premise y)). - 2: now rewrite H0. - destruct min_premise. - destruct concl => //. - replace (level_value_above m t1 (Z.of_nat n + z)) with (level_value_above m0 t1 (Z.of_nat n + z)). - 2:now rewrite H0. - destruct level_value_above => //. - red. cbn. split => //. - red. cbn; split => //. now rewrite H. now rewrite H0. - red. cbn. split => //. -Qed. +(* Definition optm := optm *) -Instance has_strict_update_proper : Proper (Clauses.Equal ==> LevelMap.Equal ==> eq ==> LevelMap.Equal ==> iff) has_strict_update. -Proof. - intros ? ? eqcl ? ? eqm ? ? eqs ? ? eqm'. - unfold has_strict_update, strict_update. subst y1. - setoid_rewrite eqcl. setoid_rewrite eqm. now setoid_rewrite eqm'. -Qed. +(* #[local] Instance update_value_proper : Proper (LevelMap.Equal ==> eq ==> opt ) update_value. *) -Instance has_strict_update_W_proper : Proper (Clauses.Equal ==> LevelMap.Equal ==> LevelSet.Equal ==> LevelMap.Equal ==> iff) has_strict_update_W. +#[local] Instance check_clause_model_proper : Proper (eq ==> levelset_m_eq ==> levelset_m_eq) check_clause_model. Proof. - intros ? ? eqcl ? ? eqm ? ? eqs ? ? eqm'. - unfold has_strict_update_W. - now setoid_rewrite eqcl; setoid_rewrite eqm; setoid_rewrite eqs; setoid_rewrite eqm'. -Qed. + intros x y eq [] [] []; cbn in *; subst. + unfold levelset_m_eq. + replace (update_value m y) with (update_value m0 y). split => //; destruct update_value => //. + unfold update_value. setoid_rewrite H0. +Abort. Instance model_map_outside_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) model_map_outside. Proof. @@ -2083,76 +2173,6 @@ Proof. firstorder eauto. Qed. -Lemma check_clause_model_modify' {cl cls w m w' m' w'' m'' modified modified'} : - check_model_invariants cls w m w' m' modified -> - declared_model_level m (clause_conclusion cl) -> - check_clause_model cl (modified, (w', m')) = (modified', (w'', m'')) -> - check_model_invariants (Clauses.add cl cls) w m w'' m'' modified'. -Proof. - intros inv declcl. - unfold check_clause_model. - destruct (update_value (w', m') cl) eqn:upd. - * intros [= <- <-]. subst. - destruct modified. 2:{ cbn in inv |- *. intuition. } - destruct inv. - split => //. - + rewrite clauses_conclusions_add; lsets. - + destruct H1 as [cl' []]. - exists cl'; split => //. now rewrite Clauses.add_spec. - * intros [= <- <-]. subst. - destruct modified. 2:{ cbn in inv |- *; intuition. } - destruct inv. - split => //. - + rewrite clauses_conclusions_add; lsets. - + destruct H1 as [cl' []]. - exists cl'; split => //. now rewrite Clauses.add_spec. - * intros [= <- ->]. - move: upd. - unfold update_value. - destruct min_premise as [hmin|] eqn:eqmin => //. - destruct cl as [prem [l k]] => /=. - destruct level_value_above eqn:hval => //. - intros [= <- <-]. - destruct modified; noconf inv. - { destruct inv. - split => //. - + lsets. - + rewrite clauses_conclusions_add. - intros x. rewrite LevelSet.add_spec !LevelSet.union_spec LevelSet.singleton_spec. - intuition eauto. cbn. apply H0 in H5. lsets. - + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. - destruct H1 as [cl []]; exists cl; split => //. eauto. eauto. - destruct (level_value m (concl cl)) as [vconcl|] eqn:hconcl; [|constructor]. - eapply opt_lt_le_trans; tea. - eapply model_le_values. - now eapply update_model_not_above. - + transitivity m'. - { eapply model_extension_weaken; tea. lsets. } - split. - { now eapply update_model_not_above. } - { eapply update_model_same_domain. - eapply H2, declcl. } - { eapply update_model_outside. } - + now eapply total_model_of_update. } - { destruct inv as [inv htot]; noconf inv. split => //. - + lsets. - + rewrite clauses_conclusions_add. - intros x. rewrite LevelSet.add_spec !LevelSet.union_spec LevelSet.singleton_spec. - intuition eauto. - + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. - exists (prem, (l, k)). - split; tea; eauto. - - unfold valid_clause. cbn. now rewrite eqmin hval /=. - - cbn. rewrite level_value_update_model. now apply level_value_not_above_spec. - + split. - { now eapply update_model_not_above. } - { eapply update_model_same_domain. - eapply declcl. } - { eapply update_model_outside. } - + now eapply total_model_of_update. } -Qed. - - Lemma min_premise_some_pres {m m' prems k} : m ⩽ m' -> min_premise m prems = Some k -> exists k', min_premise m' prems = Some k'. Proof. intros ext minp. @@ -2227,13 +2247,13 @@ Proof. eapply level_value_above_MapsTo'; tea. now constructor; lia. Qed. -Lemma strict_update_ext_right m cl m' m'' : strict_update m cl m' -> m' ⩽ m'' -> strict_update m cl m''. +(* Lemma strict_update_ext_right m cl m' m'' : strict_update m cl m' -> m' ⩽ m'' -> strict_update m cl m''. Proof. destruct cl as [prems [concl k]]. unfold strict_update. intros [minp [eqminp [ha hna]]] leq. exists minp. split => //. split => //. eapply level_value_above_mon; tea. -Qed. +Qed. *) Definition enabled_clause (m : model) (cl : clause) := isSome (min_premise m (premise cl)). @@ -2265,94 +2285,8 @@ Proof. unfold enabled_clause in enabled. cbn in enabled. destruct min_premise eqn:hmin => //. exists z; split=> //. split => //. have hp := (min_premise_pres prems mext). rewrite hmin minv in hp. depelim hp. - 2:{ eapply level_value_above_mon; tea. eapply level_value_above_MapsTo'; tea. rewrite -nout. } - Admitted. - -Definition has_strict_update_from cls m l m' := - exists prems k, Clauses.In (prems, (l, k)) cls /\ - exists minter, m ⩽ minter /\ strict_update minter (prems, (l, k)) m'. - -Definition has_strict_update_from_W cls m W m' := - forall l, LevelSet.In l W -> has_strict_update_from cls m l m'. - -Lemma has_strict_update_W_trans cls m w m' cl m'' : - m' ⩽ m'' -> - has_strict_update_from_W cls m w m' -> - model_map_outside w m m' -> - strict_update m' cl m'' -> - has_strict_update_from_W (Clauses.add cl cls) m (LevelSet.add (clause_conclusion cl) w) m''. -Proof. - intros mleq updW outw su. - destruct cl as [prems [concl k]]. - intros l; rewrite LevelSet.add_spec. - destruct (inLevelSet w concl). - - intros [->|inw]. - * cbn. - apply updW in H. - destruct H as [prems' [k' [hin hstr]]]. - unfold has_strict_update_from. setoid_rewrite Clauses.add_spec. - do 2 eexists; split. right. exact hin. - destruct hstr as [minter [leqinter hstr]]. - exists m'. split. - Admitted. - { transitivity minter => //. red. } - move: su hstr. unfold strict_update. - intros [v [minv []]] [minter [leqinter [v' [minv' []]]]]. - exists m'. split. - { transitivity minter => //. - {} - exists v'. split => //. split => //. eapply level_value_above_mon; tea. - * eapply updW in inw. - destruct inw as [prems' [k' [hin hstr]]]. - red. do 2 eexists; split. rewrite Clauses.add_spec. right; tea. - move: su hstr. unfold strict_update. - intros [v [minv []]] [v' [minv' []]]. - exists v'. split => //. split => //. eapply level_value_above_mon; tea. - - intros [->|inw]. - * unfold has_strict_update. cbn -[strict_update]. - exists prems, k. split. rewrite Clauses.add_spec. now left. - - - have minp := min_premise_pres prems' mleq. - rewrite minv' in minp. depelim minp. - - - exists v. split => //. 2:split => //. *) -Admitted. - -Lemma check_clause_model_update {cl cls w m w' m' m'' modified modified'} : - is_update cls m w m' -> - declared_model_level m (clause_conclusion cl) -> - check_clause_model cl (modified, (w, m')) = (modified', (w', m'')) -> - is_update (Clauses.add cl cls) m w' m''. -Proof. - intros isupd hdecl. - unfold check_clause_model. - destruct update_value eqn:upd. - * intros [= <- <-]. subst m''. - red. unfold has_strict_update_W, has_strict_update. setoid_rewrite Clauses.add_spec. - destruct isupd. intuition eauto. - specialize (H _ H1) as [? [? [? ?]]]; intuition auto. do 3 eexists; intuition eauto. - * intros [= <- <-]. subst m''. - red. unfold has_strict_update_W, has_strict_update. setoid_rewrite Clauses.add_spec. - destruct isupd. intuition eauto. - specialize (H _ H1) as [? [? [? ?]]]; intuition auto. do 3 eexists; intuition eauto. - * intros [= <- ->]. - red. - eapply update_value_spec in upd as [hw' hsupd]. - destruct isupd as [hupd hnupd]. setoid_rewrite hw'. clear w' hw'. - destruct cl as [prems [concl k]]; cbn. - split. - { cbn. intros l [hl|hl]. subst l. - do 2 eexists. repeat split; eauto. cbn -[strict_update]. - specialize (hupd l ) - move: upd; unfold update_value. - destruct min_premise eqn:hmin. - have sub := update_value pose proof (inLe) - - } - specialize (H _ H1) as [? [? [? ?]]]; intuition auto. do 3 eexists; intuition eauto. - + (* 2:{ eapply level_value_above_mon; tea. eapply level_value_above_MapsTo'; tea. rewrite -nout. } *) + Abort. Definition model_of V (m : model) := forall k, LevelSet.In k V -> LevelMap.In k m. @@ -2387,72 +2321,68 @@ Proof. intuition eauto. destruct H as [cl []]; exists cl; split; try clsets; auto. Qed. -Lemma check_model_aux_spec {cls w m w' m' modified} : - model_of (clauses_conclusions cls) m -> - total_model_of w m -> - check_model_aux cls (w, m) = (modified, (w', m')) -> - check_model_invariants cls w m w' m' modified. -Proof. - rewrite /check_model_aux /is_model. - revert modified w' m'. - eapply ClausesProp.fold_rec. - - intros s' e modified w' m' mof tot [= <- <- <-]. - split => //. - - intros x ? s' s'' inx nins' hadd ih modified w' m' mof tot. - destruct a as [modified'' [w'' m'']]. - assert (ms' : model_of (clauses_conclusions s') m). - { eapply model_of_subset; tea. - eapply clauses_conclusions_subset. red in hadd. intros ?. - specialize (hadd a). intuition auto. } - specialize (ih _ _ _ ms' tot eq_refl). - apply ClausesProp.Add_Equal in hadd. rewrite hadd. - eapply check_clause_model_modify' => //. - red. apply mof. - apply clauses_conclusions_spec. exists x; split => //. - apply hadd. clsets. -Qed. - -Lemma check_model_spec {cls w m w' m'} : - model_of (clauses_conclusions cls) m -> - total_model_of w m -> +Lemma check_model_ext {cls w init_model m w' m'} : check_model cls (w, m) = Some (w', m') -> - check_model_invariants cls w m w' m' true. + strictly_updates cls w init_model m -> + strictly_updates cls w' init_model m' /\ w ⊂_lset w'. Proof. - intros mof tot. - unfold check_model. - destruct check_model_aux eqn:cm. - destruct p as []. - eapply check_model_aux_spec in cm => //. - destruct b => //. now intros [= <- <-]. + move/check_model_updates_spec. + intros ih cls'. eapply ih in cls' as [su incl]. split => //. + eapply strictly_updates_weaken; tea. clsets. +Qed. + +Lemma check_model_updates_spec_empty {cls m w m'} : + check_model cls (LevelSet.empty, m) = Some (w, m') -> + strictly_updates cls w m m'. +Proof. + move/check_model_spec => [w' [su ->]]. + replace (LevelSet.union LevelSet.empty w') with w' => //. + eapply LevelSet.eq_leibniz. intros x; lsets. Qed. -Lemma check_model_aux_not_model {cls w m w' m'} : +Lemma check_model_has_invariants {cls w m w' m'} : model_of (clauses_conclusions cls) m -> total_model_of w m -> - check_model_aux cls (w, m) = (true, (w', m')) -> - ~~ is_model cls m. + check_model cls (w, m) = Some (w', m') -> + check_model_invariants cls w m w' m' true. Proof. intros mof tot. - move/(check_model_aux_spec mof tot) => [] _ _ [cl [incl inval]] _ _ _ tot'. - unfold is_model. - apply clauses_for_all_neg. - intros hf. specialize (hf cl incl). cbn in hf. - rewrite /is_true hf in inval => //. + move/check_model_spec => [w'' [su ->]]. + cbn. split. + - lsets. + - apply strictly_updates_incl in su. lsets. + - clear -su. induction su. + * exists cl. split => //. now eapply strict_update_invalid. + unfold clause_conclusion. lsets. + destruct cl as [prems [concl k]]. + destruct H0 as [minp [hin [hnabove habove]]]. + move: hnabove habove. rewrite /level_value_above. + cbn. destruct level_value eqn:hv => //; try constructor. + intros hle. intros ->. rewrite level_value_add. constructor. + move/negbTE: hle. lia. + * destruct IHsu1 as [cl []]. + exists cl. split => //. lsets. + apply strictly_updates_ext in su2. + depelim H2; rewrite ?H3. 2:{ rewrite H2; constructor. } + eapply level_value_MapsTo', su2 in H4 as [k' [map le]]. + eapply level_value_MapsTo in map. rewrite map. depelim le; constructor. lia. + - constructor. now eapply strictly_updates_ext. + clear -mof su. + induction su. + * move: H0; unfold strict_update. destruct cl as [prems [concl k]]. + intros [v [hmi [nabove eqm]]]. intros l. rewrite eqm. + rewrite LevelMapFact.F.add_in_iff. specialize (mof l). + rewrite clauses_conclusions_spec in mof. firstorder. + * specialize (IHsu1 mof). transitivity m' => //. + apply IHsu2. intros l hin. specialize (mof _ hin). now apply IHsu1 in mof. + * apply todo. + - apply todo. Qed. Lemma check_model_is_model {W cls m} : - model_of (clauses_conclusions cls) m -> - total_model_of W m -> check_model cls (W, m) = None <-> is_model cls m. Proof. - intros mof tot; unfold check_model, is_model. - destruct check_model_aux eqn:caux. - destruct b => //. intuition auto. congruence. - { destruct p; eapply check_model_aux_not_model in caux => //. - rewrite /is_model /= // in caux. now rewrite H in caux. } - intuition auto. - pose proof (check_model_aux_false caux). subst p. - now rewrite check_model_aux_model in caux. + now rewrite check_model_None. Qed. Lemma check_model_update {W cls m wm'} : @@ -2460,12 +2390,11 @@ Lemma check_model_update {W cls m wm'} : total_model_of W m -> check_model cls (W, m) = Some wm' -> ~~ is_model cls m /\ m ⩽ wm'.2. Proof. - intros mof tot; unfold check_model, is_model. - destruct check_model_aux eqn:caux. - destruct b => //. intros [= <-]. intuition auto. - destruct p. - now eapply check_model_aux_not_model in caux. - now eapply check_model_aux_model_le in caux. + intros mof tot. + destruct wm'. + move/check_model_spec => [w'' [su ->]]. cbn. split. + now eapply strictly_updates_invalid. + now eapply strictly_updates_ext. Qed. Definition level_value_default m l := @@ -2601,7 +2530,7 @@ Proof. now eapply ClausesOrd.fold_equal; tc. Qed. -#[local] Instance check_model_aux_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> modified_levelset_m_eq) check_model_aux. +(* #[local] Instance check_model_aux_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> modified_levelset_m_eq) check_model_aux. Proof. intros cls cls' eq. intros wm wm' eq'. @@ -2611,33 +2540,23 @@ Proof. red. cbn => //. } unfold check_model_aux. now eapply ClausesOrd.fold_equal; tc. -Qed. - -#[local] Instance check_model_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> R_opt levelset_m_eq) check_model. -Proof. - intros cls cls' eq. - intros wm wm' eq'. - unfold check_model. - destruct (check_model_aux cls wm) eqn:eqc. - destruct (check_model_aux cls' wm') eqn:eqc' => //. - pose proof (check_model_aux_proper cls cls' eq wm wm' eq'). - rewrite eqc eqc' in H. destruct H; cbn in *; subst. - red in H0. destruct H0. - destruct b0 => //. -Qed. +Qed. *) +(* #[local] Instance check_model_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model. Proof. intros cls cls' eq. intros wm wm' eq'. unfold check_model. now subst wm'; rewrite eq. -Qed. +Qed. *) Record valid_model_def (V W : LevelSet.t) (m : model) (cls : clauses) := { model_model : model; model_of_V :> model_of V model_model; model_of_W : total_model_of W model_model; + model_incl : W ⊂_lset V; + model_updates : strictly_updates cls W m model_model; model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; model_ok :> is_model cls model_model; model_extends : model_extension V m model_model; @@ -2645,6 +2564,8 @@ Record valid_model_def (V W : LevelSet.t) (m : model) (cls : clauses) := Arguments model_model {V W m cls}. Arguments model_of_V {V W m cls}. Arguments model_of_W {V W m cls}. +Arguments model_incl {V W m cls}. +Arguments model_updates {V W m cls}. Arguments model_clauses_conclusions {V W m cls}. Arguments model_ok {V W m cls}. Arguments model_extends {V W m cls}. @@ -2772,15 +2693,15 @@ Definition is_loop (cls : clauses) (t : nonEmptyLevelExprSet) := Definition levelexprset_of_levels (ls : LevelSet.t) : LevelExprSet.t := LevelSet.fold (fun x => LevelExprSet.add (x, 0%nat)) ls LevelExprSet.empty. -Lemma levelexprset_of_levels_spec (ls : LevelSet.t) l : - LevelExprSet.In (l, 0%nat) (levelexprset_of_levels ls) <-> LevelSet.In l ls. +Lemma levelexprset_of_levels_spec (ls : LevelSet.t) l k : + LevelExprSet.In (l, k) (levelexprset_of_levels ls) <-> LevelSet.In l ls /\ k = 0%nat. Proof. rewrite /levelexprset_of_levels. eapply LevelSetProp.fold_rec. - intros s' he. rewrite LevelExprSetFact.empty_iff. firstorder. - intros x a s' s'' hin hnin hadd ih. rewrite LevelExprSet.add_spec; unfold LevelExprSet.E.eq. - firstorder eauto. noconf H1. firstorder. + firstorder eauto; try noconf H1 => //. apply hadd in H1. firstorder. subst. now left. Qed. @@ -2801,20 +2722,30 @@ Definition loop_on_univ cls prems := entails_clauses cls (to_clauses prems (succ Definition loop_on W (hne : ~ LevelSet.Empty W) cls := loop_on_univ cls (of_level_set W hne). +Lemma loop_on_proper W W' hne' cls : W =_lset W' -> exists hne, loop_on W hne cls -> loop_on W' hne' cls. +Proof. + intros eq; rewrite /loop_on /loop_on_univ. + assert (hne : ~ LevelSet.Empty W). now rewrite eq. + exists hne. + assert (of_level_set W hne = of_level_set W' hne'). + apply eq_univ'. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. + now rewrite -H. +Qed. + Lemma loop_on_subset {W hne cls cls'} : Clauses.Subset cls cls' -> loop_on W hne cls -> loop_on W hne cls'. Proof. Admitted. Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := | Loop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne cls) - | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). + | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). Arguments Loop {V U cls m}. Arguments Model {V U cls m}. Arguments lexprod {A B}. Definition option_of_result {V U m cls} (r : result V U m cls) : option model := match r with - | Model w m sub => Some m.(model_model) + | Model w m _ => Some m.(model_model) | Loop w hne isloop => None end. @@ -2828,6 +2759,7 @@ Proof. - eapply Loop; tea. - econstructor 2; tea. destruct m0. econstructor; tea. + apply todo. now transitivity m. Qed. @@ -2859,10 +2791,20 @@ Proof. eapply (Acc_intro_generator 1000). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. Defined. + +Definition is_update_of cls upd minit m := + if LevelSet.is_empty upd then minit = m + else strictly_updates cls upd minit m. + + (* #[tactic="idtac"] + Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) + (prf : [/\ clauses_conclusions cls ⊂_lset V, model_of V m & is_update_of cls U minit m]) : result V U cls m *) + + Section InnerLoop. Context (V : LevelSet.t) (U : LevelSet.t) (loop : forall (V' U' : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V', U' ⊂_lset V', model_of V' m, total_model_of U' m & is_update U' cls m ]), + (prf : [/\ clauses_conclusions cls ⊂_lset V' & model_of V' m]), lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls m). Definition sum_W W (f : LevelSet.elt -> nat) : nat := @@ -3068,6 +3010,12 @@ Section InnerLoop. now eapply in_restrict_clauses in H0 as []. Qed. + Lemma union_diff {cls W} : + Clauses.Equal (Clauses.union (Clauses.diff (cls ↓ W) (cls ⇂ W)) (cls ⇂ W)) (cls ↓ W). + Proof. + now rewrite ClausesProp.union_sym union_diff_eq union_restrict_with_concl. + Qed. + Lemma maps_to_level_value x (m m' : model) : (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> level_value m x = level_value m' x. @@ -3132,7 +3080,7 @@ Section InnerLoop. Proof. cbn; intros mof tot cm. pose proof (clauses_conclusions_diff_left cls w (cls ⇂ w)). - apply check_model_spec in cm as []. + apply check_model_has_invariants in cm as []. split => //. lsets. eapply model_of_subset; tea. exact tot. Qed. @@ -3194,6 +3142,67 @@ Section InnerLoop. intros []; cbn => htot. eapply total_model_of_ext; tea. Qed. + (* Inductive inner_result (V U : LevelSet.t) (cls : clauses) (m : model) := + | InLoop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne cls) + | InModel (w : LevelSet.t) (m : valid_model V w m cls). + (* (prf : U ⊂_lset w /\ w ⊂_lset V). *) + Arguments InLoop {V U cls m}. + Arguments InModel {V U cls m}. *) + + Lemma strictly_updates_total_model_gen cls W m m' : + strictly_updates cls W m m' -> + forall W', total_model_of W' m -> total_model_of (LevelSet.union W' W) m'. + Proof. + clear. + induction 1. + - intros W' tot x. + destruct cl as [prems [concl cl]]. + destruct H0 as [minv [hmin []]]. setoid_rewrite H1. + setoid_rewrite LevelMapFact.F.add_mapsto_iff. cbn. + destruct (Level.eq_dec concl x). + { subst. exists (Z.of_nat cl + minv). now left. } + { rewrite LevelSet.union_spec; intros [hin|hin]. + { eapply tot in hin as [wit mt]. exists wit. now right. } + { eapply LevelSet.singleton_spec in hin. red in hin; subst. congruence. } } + - intros W' tot. + eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. + eapply total_model_of_subset; tea. intros x; lsets. + Qed. + + Instance total_model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) total_model_of. + Proof. + intros ? ? H ? ? H'. unfold total_model_of. setoid_rewrite H. + now setoid_rewrite H'. + Qed. + + Lemma total_model_of_empty m : total_model_of LevelSet.empty m. + Proof. intros x; now move/LevelSet.empty_spec. Qed. + + Lemma strictly_updates_total_model {cls W m m'} : + strictly_updates cls W m m' -> + total_model_of W m'. + Proof. + move/strictly_updates_total_model_gen/(_ LevelSet.empty). intros H. + eapply total_model_of_subset. eapply H. apply total_model_of_empty. lsets. + Qed. + + Lemma is_update_of_empty cls m : + is_update_of cls LevelSet.empty m m. + Proof. + unfold is_update_of. + rewrite LevelSetFact.is_empty_1 //. lsets. + Qed. + + Lemma strictly_updates_model_of cls w m m' W : + strictly_updates cls w m m' -> + model_of W m -> model_of W m'. + Proof. apply todo. Qed. + + Lemma strictly_updates_total_model_of cls w m m' W : + strictly_updates cls w m m' -> + total_model_of W m -> total_model_of W m'. + Proof. apply todo. Qed. + Section innerloop_partition. Context (W : LevelSet.t) (cls : clauses). Context (premconclW conclW : clauses). @@ -3201,19 +3210,19 @@ Section InnerLoop. Clauses.Equal premconclW (cls ⇂ W) & Clauses.Equal conclW (Clauses.diff (cls ↓ W) (cls ⇂ W))]). #[tactic="idtac"] - Equations? inner_loop_partition (m : model) (mW : total_model_of W m) : result W U cls m + Equations? inner_loop_partition (m : model) (ism : total_model_of W m) : result W LevelSet.empty cls m by wf (measure W cls m) lt := - inner_loop_partition m mW with loop W LevelSet.empty premconclW m _ _ := { + inner_loop_partition m upd with loop W LevelSet.empty premconclW m _ _ := { (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) | Loop W ne isl => Loop W ne (loop_on_subset _ isl) (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). By invariant Wr ⊂ W *) - | Model Wr mr hsub with inspect (check_model conclW (Wr, model_model mr)) := { - | exist None eqm => Model W {| model_model := model_model mr |} _ + | Model Wr mr empWr with inspect (check_model conclW (Wr, model_model mr)) := { + | exist None eqm => Model Wr {| model_model := model_model mr |} _ | exist (Some (Wconcl, mconcl)) eqm with inner_loop_partition mconcl _ := { - (* Here Wconcl ⊂ Wr by invariant *) + (* Here Wr ⊂ Wconcl by invariant *) | Loop W ne isl => Loop W ne isl - | Model Wr' mr' hsub' => Model Wr' {| model_model := model_model mr' |} hsub' } + | Model Wr' mr' UWconcl => Model (LevelSet.union Wconcl Wr') {| model_model := model_model mr' |} _ } (* Here Wr' ⊂ W by invariant *) (* We check if the new model [mr] for (cls ⇂ W) extends to a model of (cls ↓ W). *) (* We're entitled to recursively compute a better model starting with mconcl, @@ -3228,45 +3237,70 @@ Section InnerLoop. all:try destruct prf as [WV neW UW clsW eqprem eqconcl]. all:try solve [intuition auto]. all:try rewrite eqconcl in eqm. - - split => //. rewrite eqprem. apply clauses_conclusions_restrict_clauses. lsets. exact mW. - intros k. now rewrite LevelSetFact.empty_iff. - now intros l; rewrite LevelSetFact.empty_iff. + - split => //. rewrite eqprem. apply clauses_conclusions_restrict_clauses. now apply total_model_of_sub. - left. now eapply strict_subset_cardinal. - destruct prf. transitivity (cls ⇂ W) => //. now rewrite H3. eapply restrict_clauses_subset. - - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. - eapply total_model_of_ext. 2:tea. pose proof (model_extends mr). - eapply total_model_of_ext; tea. - destruct hsub. eapply total_model_of_subset; tea. - eapply valid_model_total; tea. - - eapply (check_model_spec_diff mr) in eqm as [subwwconcl subwconcl hm hext] => //. + - have [w' [su eq]] := check_model_spec eqm. + have mmr := model_of_V mr. + eapply strictly_updates_total_model_of; tea. + now eapply valid_model_total. + (* - + eapply strictly_updates_incl in su. + pose proof (check_model_updates_spec (init_model:=m) eqm); tea. + eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. + assert (Wconcl ⊂_lset W). have incl := model_incl mr. lsets. + pose proof (model_updates mr). + apply H in H2 as [su incl]. + eapply (strictly_updates_weaken _ _ cls) in su. + have htr := update_trans _ upd su. + eapply strictly_updates_proper in htr; tea. + 1,3-4:reflexivity. lsets. + rewrite eqprem. rewrite union_diff. move=> l. now rewrite in_clauses_with_concl. + eapply mr. *) + - have tmr : total_model_of W (model_model mr). + { now eapply valid_model_total. } + eapply (check_model_spec_diff mr) in eqm as [subwwconcl subwconcl hm hext] => //. pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). destruct hm as [cll [hind nvalid inwconcl hl]]. eapply Nat.lt_le_trans. - 2:{ eapply measure_le; eauto; try eapply mr. } - eapply measure_lt. - { eapply valid_model_total; tea. } - { eapply model_map_outside_weaken. eapply hext. lsets. } + 2:{ eapply measure_le; eauto; try eapply mr; tea. } + eapply measure_lt; tea. + { eapply model_map_outside_weaken. eapply hext. have incl := model_incl mr. lsets. } { apply hext. } eapply invalid_clause_measure in nvalid; tea. exists (levelexpr_level (concl cll)). split => //. eapply clauses_conclusions_diff_left; tea. eapply clauses_conclusions_spec. exists cll; split => //. exact hind. - { eapply valid_model_total; tea. } - destruct hsub. eapply total_model_of_subset; tea. - { eapply valid_model_total; tea. } + have incl := model_incl mr. eapply total_model_of_subset; tea. - apply mr'. (* - apply clauses_conclusions_clauses_with_concl. *) - - apply mr'. + - have mu := model_updates mr. have mu' := model_updates mr'. + apply (check_model_updates_spec (init_model:=m) eqm) in mu as [mu incl]. + eapply (strictly_updates_weaken _ _ cls) in mu. + have tr := update_trans _ mu mu'. now eapply strictly_updates_total_model in tr. + intros ?; rewrite eqprem. now rewrite union_diff in_clauses_with_concl. + - have incl := model_incl mr; have incl':= model_incl mr'. + eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. lsets. + eapply mr. + - have mu := model_updates mr. have mu' := model_updates mr'. + apply (check_model_updates_spec (init_model:=m) eqm) in mu as [mu incl]. + eapply (strictly_updates_weaken _ _ cls) in mu. + eapply update_trans; tea. rewrite eqprem union_diff. + intros ?. rewrite in_clauses_with_concl => //. intuition. - apply mr'. - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. 2:apply mr. eapply model_ext_trans_weaken. 2:apply mr. lsets. - transitivity mconcl. eapply model_extension_weaken. 2:tea. lsets. apply mr'. + transitivity mconcl. eapply model_extension_weaken. 2:tea. + have incl := model_incl mr; lsets. apply mr'. + - lsets. - apply mr. - - now eapply valid_model_total. + - apply mr. + - apply mr. + (* now eapply valid_model_total. *) + - have um := model_updates mr. eapply strictly_updates_weaken; tea. + intros ?; rewrite eqprem in_restrict_clauses. now intros []. - rewrite check_model_is_model in eqm. - 1:{ eapply model_of_diff. apply mr. } - apply mr. have okm := (model_ok mr). have mu := is_model_union okm eqm. rewrite {1}eqprem in mu. @@ -3274,7 +3308,6 @@ Section InnerLoop. rewrite union_restrict_with_concl in mu. now rewrite (clauses_conclusions_eq _ _ clsW). - apply mr. - - split; lsets. Qed. End innerloop_partition. @@ -3283,8 +3316,8 @@ Section InnerLoop. *) #[tactic="idtac"] Equations? inner_loop (W : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & total_model_of W m]) : - result W U cls m := + (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & total_model_of W m]) + : result W LevelSet.empty cls m := inner_loop W cls m prf with inspect (Clauses.partition (premise_restricted_to W) cls) := | exist (premconclW, conclW) eqp => inner_loop_partition W cls premconclW conclW _ m _. Proof. @@ -3328,6 +3361,28 @@ Proof. apply H0. lsets. Qed. +Lemma strict_subset_leq_left U V W : + U ⊂_lset V -> strict_subset V W -> strict_subset U W. +Proof. + apply H0. lsets. + intros le []. split. lsets. intros eq. rewrite eq in le. +Qed. + +(* Lemma strict_subset_union_right U U' V W : + strict_subset V W -> U ⊂_lset U' -> + strict_subset (LevelSet.union U V) (LevelSet.union U' W). +Proof. + rewrite /strict_subset. + intros [] hu. split. lsets. intros he. + apply H0. + intros x. split. apply H. + specialize (he x). intros inW. + rewrite !LevelSet.union_spec in he. + destruct he as [he he']. + forward he'. now right. destruct he' => //. + forward he. apply he in + red in he. *) + Lemma strict_subset_diff_incl V W W' : strict_subset W' W -> W ⊂_lset V -> @@ -3350,7 +3405,7 @@ Lemma check_model_spec_V {V cls w m w' m'} : check_model_invariants cls w m w' m' true. Proof. cbn; intros mof incl tot cm. - apply check_model_spec in cm => //. + apply check_model_has_invariants in cm => //. eapply model_of_subset; tea. Qed. @@ -3360,93 +3415,304 @@ Proof. intros mof. eapply model_of_ext; tea. eapply m'. Qed. +Lemma clauses_with_concl_union cls W W' : + Clauses.Equal (clauses_with_concl cls (LevelSet.union W W')) + (Clauses.union (clauses_with_concl cls W) (clauses_with_concl cls W')). +Proof. + intros x. rewrite Clauses.union_spec !in_clauses_with_concl LevelSet.union_spec. + firstorder. +Qed. + +Lemma strictly_updates_strenghten {cls W m m'} : + strictly_updates cls W m m' -> + strictly_updates (cls ↓ W) W m m'. +Proof. + induction 1. + - constructor. rewrite in_clauses_with_concl. split => //. + eapply LevelSet.singleton_spec; reflexivity. exact H0. + - rewrite clauses_with_concl_union. econstructor 2. + eapply strictly_updates_weaken; tea. intros x; clsets. + eapply strictly_updates_weaken; tea. intros x; clsets. +Qed. + +Lemma clauses_with_concl_subset cls W : (cls ↓ W) ⊂_clset cls. +Proof. now intros ?; rewrite in_clauses_with_concl. Qed. + +Section Semantics. + + Section Interpretation. + Context (V : LevelMap.t nat). + + Definition interp_level l := + match LevelMap.find l V with + | Some x => x + | None => 0%nat + end. + + Definition interp_expr '(l, k) := (interp_level l + k)%nat. + Definition interp_prems prems := + let '(hd, tl) := to_nonempty_list prems in + fold_right (fun lk acc => Nat.max (interp_expr lk) acc) (interp_expr hd) tl. + + Definition clause_sem (cl : clause) : Prop := + let '(prems, concl) := cl in + interp_prems prems >= interp_expr concl. + + Definition clauses_sem (cls : clauses) : Prop := + Clauses.For_all clause_sem cls. + End Interpretation. + + (* There exists a valuation making all clauses true in the natural numbers *) + Definition satisfiable (cls : clauses) := + exists V, clauses_sem V cls. + + (* Any valuation making all clauses valid in the natural numbers also satisfies the clause cl *) + Definition entails_sem (cls : clauses) (cl : clause) := + forall V, clauses_sem V cls -> clause_sem V cl. +End Semantics. + + +Local Open Scope Z_scope. +Lemma max_min max min k : min <= 0 -> max >= 0 -> k <= max -> k >= min -> (max - k - min) >= 0. +Proof. lia. Qed. + +Definition model_min m := + LevelMap.fold (fun l k acc => + match k with + | Some k => Z.min acc k + | None => acc + end) m 0%Z. + +Lemma model_min_spec m : forall l k, LevelMap.MapsTo l k m -> (Some (model_min m) ≤ k). +Proof. Admitted. + +Definition model_max m := + LevelMap.fold (fun l k acc => + match k with + | Some k => Z.max acc k + | None => acc + end) m 0%Z. + +Lemma model_max_spec m : forall l k, LevelMap.MapsTo l k m -> (k ≤ Some (model_max m))%Z. +Proof. Admitted. + +Definition valuation_of_model (m : model) : LevelMap.t nat := + let min := model_min m in + let max := model_max m in + LevelMap.fold (fun l k acc => LevelMap.add l (Z.to_nat (max - option_get 0%Z k - min)) acc) m (LevelMap.empty _). +Close Scope Z_scope. + +Lemma valuation_of_model_spec m : + forall l k, LevelMap.MapsTo l (Some k) m -> + let v := (model_max m - k - model_min m)%Z in + (v >= 0)%Z /\ LevelMap.MapsTo l (Z.to_nat v) (valuation_of_model m). +Proof. Admitted. + + +Definition correct_model (cls : clauses) (m : model) := + enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. + + Lemma valid_clause_model model cl : + enabled_clause model cl -> + valid_clause model cl -> + clause_sem (valuation_of_model model) cl. +Proof. +Admitted. + +Lemma total_model_of_union U V cls : total_model_of U cls -> total_model_of V cls -> total_model_of (LevelSet.union U V) cls. +Proof. + intros hu hv x. + rewrite LevelSet.union_spec; move => [] hin. + now apply hu. now apply hv. +Qed. + +Lemma strictly_updates_loop cls V neV m m' : + total_model_of V m -> + enabled_clauses m cls -> + strictly_updates cls V m m' -> loop_on V neV cls. +Proof. + intros tot en. + induction 1. + - unfold loop_on, loop_on_univ. (* cl -> cl + 1 *) + destruct cl as [prems [concl k]]. + cbn. destruct H0 as [v [hmin [hnabove heq]]]. + cbn in tot. red in tot. specialize (tot concl). forward tot. eapply LevelSet.singleton_spec. reflexivity. + eapply Clauses.for_all_spec in en. + eapply en in H. + eapply valid_clause_model in H. red. +Admitted. + +Lemma check_model_is_update_of {cls U W minit m m'} : is_update_of cls U minit m -> check_model cls (U, m) = Some (W, m') -> + strictly_updates cls W minit m' /\ U ⊂_lset W. +Proof. + rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros ->. eapply LevelSetFact.is_empty_2 in he. + eapply LevelSetProp.empty_is_empty_1 in he. + eapply LevelSet.eq_leibniz in he. rewrite he. + move/check_model_updates_spec_empty. intros H; split => //; lsets. + - intros hs. now move/check_model_ext/(_ hs). +Qed. + +Lemma strictly_updates_valid_model {W W' m m' cls} : + is_model (cls ↓ W) m -> + strictly_updates cls W' m m' -> + exists l, LevelSet.In l W' /\ ~ LevelSet.In l W. +Proof. + intros vm. induction 1. + - exists (clause_conclusion cl). split => //. lsets. intros hin. + eapply strict_update_invalid in H0. + eapply is_model_invalid_clause in vm; tea. apply vm. + eapply in_clauses_with_concl. split => //. + - destruct (IHstrictly_updates1 vm). exists x. + rewrite LevelSet.union_spec. firstorder. +Qed. + #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V, U ⊂_lset V, model_of V m, total_model_of U m & is_update U cls m]) : result V U cls m + (prf : [/\ clauses_conclusions cls ⊂_lset V & model_of V m]) : result V U cls m by wf (loop_measure V U) lexprod_rel := loop V U cls m prf with inspect (check_model cls (U, m)) := - | exist None eqm => Model U {| model_model := m |} _ + | exist None eqm => Model LevelSet.empty {| model_model := m |} _ | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { | exist true eq := Loop W _ _ (* Loop on cls ↓ W, with |W| < |V| *) | exist false neq with inner_loop V U loop W (cls ↓ W) m' _ := { | Loop W' ne isloop := Loop W' ne (loop_on_subset _ isloop) - | Model Wc mwc hsub' - (* We get a model for (cls ↓ W), we check if it extends to all clauses. + (* We get a model for (cls ↓ W), we check if it extends to all clauses. By invariant |Wc| cannot be larger than |W|. *) + | Model Wc mwc _ with inspect (check_model cls (Wc, mwc.(model_model))) := - { | exist None eqm' => Model Wc {| model_model := mwc.(model_model) |} _ + { | exist None eqm' => Model (LevelSet.union W Wc) {| model_model := mwc.(model_model) |} _ | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { | exist true _ := Loop Wcls _ _ - | exist false neq' with loop V Wcls cls mcls _ := { + | exist false neq' with loop V (LevelSet.union W Wcls) cls mcls _ := { (* Here Wcls < V, we've found a model for all of the clauses with conclusion in W, which can now be fixed. We concentrate on the clauses whose conclusion is different. Clearly |W| < |V|, but |Wcls| is not necessarily < |V| *) | Loop W' ne isloop := Loop W' ne isloop - | Model Wvw mcls' hsub'' := Model Wvw {| model_model := model_model mcls' |} _ } } } + | Model Wvw mcls' hsub := Model Wvw {| model_model := model_model mcls' |} _ } } } } } . Proof. - all:cbn; clear loop. + all:cbn -[cls_diff clauses_with_concl restrict_clauses]; clear loop. all:try solve [intuition auto]. all:try eapply levelset_neq in neq. all:have cls_sub := clauses_conclusions_levels cls. - all:destruct prf as [clsV UV mof]. - - apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //; - destruct hcl as [? []]. now intros he; apply he in H4. + all:destruct prf as [clsV mof isupd]. + - eapply check_model_spec in eqm as [Wm [eqm ->]]; tea. eapply strictly_updates_non_empty in eqm. intro. apply eqm. lsets. - set (neW := ssr_have _ _); clearbody neW. do 2 red. eapply LevelSet.equal_spec in eq. - apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. - destruct hcl as [cl [incl vcl conclinW hle]]. - red in H. - - - - apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. - split => //. split => //. lsets. - destruct hcl as [l [hl _]]. intros he. lsets. - apply clauses_conclusions_clauses_with_concl. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. - eapply check_model_spec in eqm' as []. - 2:{ eapply model_of_subset. 2:exact clsV. - exact (valid_model_of mwc (model_of_ext mof ext)). } - split => //. lsets. - exact (model_of_ext (valid_model_of mwc (model_of_ext mof ext)) H4) => //. - eapply total_model_of_subset; [|apply hsub']. - eapply valid_model_total; tea. + eapply check_model_spec in eqm as [Wm' [eqm ->]]; tea. + apply todo. + - eapply check_model_is_update_of in eqm as [eqm incl]; tea. + have hi := strictly_updates_incl eqm. + (* apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. *) + split => //. split => //. lsets. now eapply strictly_updates_non_empty. + apply clauses_conclusions_clauses_with_concl. now eapply strictly_updates_strenghten. + - now intros ?; rewrite in_clauses_with_concl. + - eapply check_model_updates_spec in eqm'. 2:{ have hu := model_updates mwc. eapply strictly_updates_weaken; tea. + apply clauses_with_concl_subset. } + now eapply strictly_updates_non_empty. + - cbn. set prf := ssr_have _ _. clearbody prf. + eapply check_model_ext in eqm' as [eqm' incl']. + 2:{ have hu := model_updates mwc. eapply strictly_updates_weaken; tea. apply clauses_with_concl_subset. } + eapply check_model_is_update_of in eqm as [eqm incl]; tea. + have tr := update_trans _ eqm eqm'. eapply LevelSet.equal_spec in e. rewrite e in tr. + assert (LevelSet.union W V =_lset V). eapply strictly_updates_incl in eqm. lsets. + rewrite H in tr. symmetry in e. + have [neV hl] := loop_on_proper _ _ prf cls e. apply hl. + have vm := model_ok mwc. + apply todo. + - eapply check_model_is_update_of in eqm as [eqm incl]; tea. + have hu := model_updates mwc. + eapply check_model_ext in eqm' as [eqm' incl']. + 2:{ eapply strictly_updates_weaken; tea. apply clauses_with_concl_subset. } + split => //. apply todo. + unfold is_update_of. + eapply strictly_updates_weaken in hu. 2:eapply clauses_with_concl_subset. + have hu' := update_trans _ eqm eqm'. + have ne := strictly_updates_non_empty hu'. + rewrite -levelset_not_Empty_is_empty in ne. now rewrite ne. - right. - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. - eapply check_model_spec in eqm' as []. - 2:{ eapply model_of_subset. 2:exact clsV. - exact (valid_model_of mwc (model_of_ext mof ext)). } - destruct hsub' as [UWc WcW]. - assert (Wcls ⊂_lset V). lsets. - rewrite -!diff_cardinal //. - eapply strict_subset_cardinal. - assert (strict_subset Wc Wcls). - { split => //. - destruct H3 as [cl [clcls nvalid hcll hv]]. + eapply check_model_spec_V in eqm' as eqm''; tea. cbn in eqm''. + 2:{ apply todo. } 2:{ apply mwc. } + destruct eqm'' as []. + eapply check_model_is_update_of in eqm as [eqm incl]; tea. + have hu := model_updates mwc. + + (* eapply check_model_spec in eqm' as [wmwc [sumwc ->]]. *) + eapply check_model_is_update_of in eqm' as [eqm' incl']; tea. + 2:{ unfold is_update_of. + have := strictly_updates_non_empty hu => hne. + rewrite (proj2 (levelset_not_Empty_is_empty _) hne). + eapply strictly_updates_weaken; tea. apply clauses_with_concl_subset. } + have WcW := model_incl mwc. + (* destruct hsub' as [UWc WcW]. *) + have w_incl := strictly_updates_incl eqm. + have wcls_incl := strictly_updates_incl eqm'. + assert (exists l, LevelSet.In l Wcls /\ ~ LevelSet.In l W). + { destruct H1 as [cl [clcls nvalid hcll hv]]. pose proof (model_ok mwc). - eapply is_model_invalid_clause in H3; tea. + eapply is_model_invalid_clause in H1; tea. assert (~ LevelSet.In (levelexpr_level (concl cl)) W). - { intros hin. rewrite in_clauses_with_concl in H3. intuition auto. } - move/(_ (levelexpr_level (concl cl))) => [] wcwcls wclswc. - now apply H7, WcW, wclswc. } - eapply (strict_subset_leq_right _ (LevelSet.diff V Wc)). - 2:{ clear -UWc WcW UW WU H3 H4. lsets. } - apply strict_subset_diff_incl => //. clear -H1 H6; lsets. - eapply total_model_of_subset; [|apply hsub']. eapply valid_model_total; tea. + { intros hin. rewrite in_clauses_with_concl in H1. intuition auto. } + exists (concl cl). split => //. } + assert (Wcls ⊂_lset V). lsets. + rewrite -!diff_cardinal //. clear -w_incl clsV incl H5. lsets. lsets. + eapply strict_subset_cardinal. + eapply (strict_subset_leq_right _ (LevelSet.diff V W)). 2:lsets. + apply strict_subset_diff_incl => //. + { red. split => //. lsets. intros heq. destruct H4 as [l' [hin hnin]]. + rewrite heq in hnin. apply hnin. lsets. } + lsets. lsets. - eapply mcls'. - apply mcls'. - - auto. - - exact mcls'. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. + - apply mcls'. + - eapply check_model_spec in eqm as [Wm [sum' ->]]. + have hupd := model_updates mwc. + eapply check_model_spec in eqm' as [Wmwc [sumwc ->]]. + have hupd' := model_updates mcls'. + eapply (strictly_updates_weaken _ _ cls) in hupd. 2:{ intros ?. rewrite in_clauses_with_concl. clsets. } + have tr := update_trans _ (update_trans _ (update_trans _ sum' hupd) sumwc) hupd'. + eapply strictly_updates_proper; tea. 1,3-4:reflexivity. intros ?. lsets. + - assumption. + - apply mcls'. + - eapply check_model_spec in eqm as [Wm [sum' ->]]. + have hupd := model_updates mwc. + eapply check_model_spec in eqm' as [Wmwc [sumwc ->]]. + have hupd' := model_updates mcls'. + eapply (strictly_updates_weaken _ _ cls) in hupd. 2:{ intros ?. rewrite in_clauses_with_concl. clsets. } + have tr := update_trans _ (update_trans _ (update_trans _ sum' hupd) sumwc) hupd'. + split. now eapply strictly_updates_ext. + apply todo. apply todo. + - eapply check_model_is_update_of in eqm as []; tea. lsets. + - apply todo. + - apply todo. apply mwc. + - eapply check_model_is_update_of in eqm as []; tea. + have h := model_incl mwc. eapply strictly_updates_incl in H. lsets. + - eapply check_model_spec in eqm as [Wm [sum' ->]]. + have hupd := model_updates mwc. + eapply (strictly_updates_weaken _ _ cls) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. + have tr := update_trans _ sum' hupd. + eapply strictly_updates_proper; tea. 1,3-4:reflexivity. + + + + + move: isupd. rewrite /is_update_of. + + + + + eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. eapply check_model_spec in eqm' as []. 2:{ eapply model_of_subset. 2:exact clsV. exact (valid_model_of mwc (model_of_ext mof ext)). } assert (WV : W ⊂_lset V). - { clear -UV clsV WU; lsets. } + { clear -clsV WU lsets. } eapply model_ext_trans_weaken => //. 2:tea. auto. transitivity mcls; [|apply mcls']. transitivity (model_model mwc). 2:{ eapply model_extension_weaken; [|tea]. lsets. } @@ -3875,41 +4141,6 @@ Proof. - red. intros k. now rewrite LevelSetFact.empty_iff. Qed. -Local Open Scope Z_scope. -Lemma max_min max min k : min <= 0 -> max >= 0 -> k <= max -> k >= min -> (max - k - min) >= 0. -Proof. lia. Qed. - -Definition model_min m := - LevelMap.fold (fun l k acc => - match k with - | Some k => Z.min acc k - | None => acc - end) m 0%Z. - -Lemma model_min_spec m : forall l k, LevelMap.MapsTo l k m -> (Some (model_min m) ≤ k). -Proof. Admitted. - -Definition model_max m := - LevelMap.fold (fun l k acc => - match k with - | Some k => Z.max acc k - | None => acc - end) m 0%Z. - -Lemma model_max_spec m : forall l k, LevelMap.MapsTo l k m -> (k ≤ Some (model_max m))%Z. -Proof. Admitted. - -Definition valuation_of_model (m : model) : LevelMap.t nat := - let min := model_min m in - let max := model_max m in - LevelMap.fold (fun l k acc => LevelMap.add l (Z.to_nat (max - option_get 0%Z k - min)) acc) m (LevelMap.empty _). -Close Scope Z_scope. - -Lemma valuation_of_model_spec m : - forall l k, LevelMap.MapsTo l (Some k) m -> - let v := (model_max m - k - model_min m)%Z in - (v >= 0)%Z /\ LevelMap.MapsTo l (Z.to_nat v) (valuation_of_model m). -Proof. Admitted. (* Lemma valuation_of_model_pos l k model : LevelMap.MapsTo l (Z.to_nat k) (valuation_of_model model) -> (k >= 0)%Z. Proof. unfold valuation_of_model. @@ -4121,41 +4352,6 @@ Equations check {V init cls} (m : valid_model V V init cls) (cl : clause) : bool | None => false end. -Section Semantics. - - Section Interpretation. - Context (V : LevelMap.t nat). - - Definition interp_level l := - match LevelMap.find l V with - | Some x => x - | None => 0%nat - end. - - Definition interp_expr '(l, k) := (interp_level l + k)%nat. - Definition interp_prems prems := - let '(hd, tl) := to_nonempty_list prems in - fold_right (fun lk acc => Nat.max (interp_expr lk) acc) (interp_expr hd) tl. - - Definition clause_sem (cl : clause) : Prop := - let '(prems, concl) := cl in - interp_prems prems >= interp_expr concl. - - Definition clauses_sem (cls : clauses) : Prop := - Clauses.For_all clause_sem cls. - End Interpretation. - - (* There exists a valuation making all clauses true in the natural numbers *) - Definition satisfiable (cls : clauses) := - exists V, clauses_sem V cls. - - (* Any valuation making all clauses valid in the natural numbers also satisfies the clause cl *) - Definition entails_sem (cls : clauses) (cl : clause) := - forall V, clauses_sem V cls -> clause_sem V cl. -End Semantics. - -Definition correct_model (cls : clauses) (m : model) := - enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. Equations? infer_model (cls : clauses) : option model := infer_model cls with loop (clauses_levels cls) LevelSet.empty cls (init_model cls) _ := From acc0a8947df78cbb7fd5c7cfb3ef8c6f78d60e31 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 29 Jul 2025 02:31:26 +0200 Subject: [PATCH 010/164] Should try not to start with U instead --- template-rocq/theories/PartialLoopChecking.v | 64 ++++++++------------ 1 file changed, 26 insertions(+), 38 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 8025823d0..b1d44dc1e 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -2802,9 +2802,9 @@ Definition is_update_of cls upd minit m := Section InnerLoop. - Context (V : LevelSet.t) (U : LevelSet.t) - (loop : forall (V' U' : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V' & model_of V' m]), + Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) + (loop : forall (V' U' : LevelSet.t) (cls : clauses) (minit m : model) + (prf : [/\ clauses_conclusions cls ⊂_lset V', model_of V' m & is_update_of cls U' minit m]), lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls m). Definition sum_W W (f : LevelSet.elt -> nat) : nat := @@ -3193,15 +3193,6 @@ Section InnerLoop. rewrite LevelSetFact.is_empty_1 //. lsets. Qed. - Lemma strictly_updates_model_of cls w m m' W : - strictly_updates cls w m m' -> - model_of W m -> model_of W m'. - Proof. apply todo. Qed. - - Lemma strictly_updates_total_model_of cls w m m' W : - strictly_updates cls w m m' -> - total_model_of W m -> total_model_of W m'. - Proof. apply todo. Qed. Section innerloop_partition. Context (W : LevelSet.t) (cls : clauses). @@ -3210,9 +3201,10 @@ Section InnerLoop. Clauses.Equal premconclW (cls ⇂ W) & Clauses.Equal conclW (Clauses.diff (cls ↓ W) (cls ⇂ W))]). #[tactic="idtac"] - Equations? inner_loop_partition (m : model) (ism : total_model_of W m) : result W LevelSet.empty cls m + Equations? inner_loop_partition (m : model) (upd : strictly_updates cls W init_model m) : + result W LevelSet.empty cls m by wf (measure W cls m) lt := - inner_loop_partition m upd with loop W LevelSet.empty premconclW m _ _ := { + inner_loop_partition m upd with loop W LevelSet.empty premconclW m m _ _ := { (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) | Loop W ne isl => Loop W ne (loop_on_subset _ isl) (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). @@ -3237,16 +3229,12 @@ Section InnerLoop. all:try destruct prf as [WV neW UW clsW eqprem eqconcl]. all:try solve [intuition auto]. all:try rewrite eqconcl in eqm. - - split => //. rewrite eqprem. apply clauses_conclusions_restrict_clauses. now apply total_model_of_sub. + - split => //. rewrite eqprem. apply clauses_conclusions_restrict_clauses. + apply total_model_of_sub, (strictly_updates_total_model upd). + eapply is_update_of_empty. - left. now eapply strict_subset_cardinal. - destruct prf. transitivity (cls ⇂ W) => //. now rewrite H3. eapply restrict_clauses_subset. - - have [w' [su eq]] := check_model_spec eqm. - have mmr := model_of_V mr. - eapply strictly_updates_total_model_of; tea. - now eapply valid_model_total. - (* - - eapply strictly_updates_incl in su. - pose proof (check_model_updates_spec (init_model:=m) eqm); tea. + - pose proof (check_model_updates_spec (init_model:=m) eqm); tea. eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. assert (Wconcl ⊂_lset W). have incl := model_incl mr. lsets. pose proof (model_updates mr). @@ -3256,14 +3244,14 @@ Section InnerLoop. eapply strictly_updates_proper in htr; tea. 1,3-4:reflexivity. lsets. rewrite eqprem. rewrite union_diff. move=> l. now rewrite in_clauses_with_concl. - eapply mr. *) + eapply mr. - have tmr : total_model_of W (model_model mr). - { now eapply valid_model_total. } + { eapply valid_model_total. now eapply strictly_updates_total_model in upd. } eapply (check_model_spec_diff mr) in eqm as [subwwconcl subwconcl hm hext] => //. pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). destruct hm as [cll [hind nvalid inwconcl hl]]. eapply Nat.lt_le_trans. - 2:{ eapply measure_le; eauto; try eapply mr; tea. } + 2:{ eapply measure_le; eauto; try eapply mr; tea. now eapply strictly_updates_total_model in upd. } eapply measure_lt; tea. { eapply model_map_outside_weaken. eapply hext. have incl := model_incl mr. lsets. } { apply hext. } @@ -3316,8 +3304,8 @@ Section InnerLoop. *) #[tactic="idtac"] Equations? inner_loop (W : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & total_model_of W m]) - : result W LevelSet.empty cls m := + (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & + strictly_updates cls W init_model m]) : result W LevelSet.empty cls m := inner_loop W cls m prf with inspect (Clauses.partition (premise_restricted_to W) cls) := | exist (premconclW, conclW) eqp => inner_loop_partition W cls premconclW conclW _ m _. Proof. @@ -3364,8 +3352,8 @@ Qed. Lemma strict_subset_leq_left U V W : U ⊂_lset V -> strict_subset V W -> strict_subset U W. Proof. - apply H0. lsets. intros le []. split. lsets. intros eq. rewrite eq in le. + apply H0. lsets. Qed. (* Lemma strict_subset_union_right U U' V W : @@ -3569,24 +3557,24 @@ Proof. Qed. #[tactic="idtac"] -Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V & model_of V m]) : result V U cls m +Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) + (prf : [/\ clauses_conclusions cls ⊂_lset V, model_of V m & is_update_of cls U minit m]) : result V U cls m by wf (loop_measure V U) lexprod_rel := - loop V U cls m prf with inspect (check_model cls (U, m)) := + loop V U cls minit m prf with inspect (check_model cls (U, m)) := | exist None eqm => Model LevelSet.empty {| model_model := m |} _ | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { | exist true eq := Loop W _ _ (* Loop on cls ↓ W, with |W| < |V| *) - | exist false neq with inner_loop V U loop W (cls ↓ W) m' _ := + | exist false neq with inner_loop V U minit loop W (cls ↓ W) m' _ := { | Loop W' ne isloop := Loop W' ne (loop_on_subset _ isloop) - (* We get a model for (cls ↓ W), we check if it extends to all clauses. - By invariant |Wc| cannot be larger than |W|. *) | Model Wc mwc _ + (* We get a model for (cls ↓ W), we check if it extends to all clauses. + By invariant |Wc| cannot be larger than |W|. *) with inspect (check_model cls (Wc, mwc.(model_model))) := { | exist None eqm' => Model (LevelSet.union W Wc) {| model_model := mwc.(model_model) |} _ | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { | exist true _ := Loop Wcls _ _ - | exist false neq' with loop V (LevelSet.union W Wcls) cls mcls _ := { + | exist false neq' with loop V (LevelSet.union W Wcls) cls minit mcls _ := { (* Here Wcls < V, we've found a model for all of the clauses with conclusion in W, which can now be fixed. We concentrate on the clauses whose conclusion is different. Clearly |W| < |V|, but |Wcls| is not @@ -3602,10 +3590,10 @@ Proof. all:try eapply levelset_neq in neq. all:have cls_sub := clauses_conclusions_levels cls. all:destruct prf as [clsV mof isupd]. - - eapply check_model_spec in eqm as [Wm [eqm ->]]; tea. eapply strictly_updates_non_empty in eqm. intro. apply eqm. lsets. + - eapply check_model_is_update_of in eqm as [eqm incl]; tea. now eapply strictly_updates_non_empty in eqm. - set (neW := ssr_have _ _); clearbody neW. do 2 red. eapply LevelSet.equal_spec in eq. - eapply check_model_spec in eqm as [Wm' [eqm ->]]; tea. + eapply check_model_is_update_of in eqm; tea. rewrite eq in eqm. apply todo. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hi := strictly_updates_incl eqm. @@ -3690,7 +3678,7 @@ Proof. apply todo. apply todo. - eapply check_model_is_update_of in eqm as []; tea. lsets. - apply todo. - - apply todo. apply mwc. + - apply mwc. - eapply check_model_is_update_of in eqm as []; tea. have h := model_incl mwc. eapply strictly_updates_incl in H. lsets. - eapply check_model_spec in eqm as [Wm [sum' ->]]. From 5375bf14fb7809857494308aace6a751a971905a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 29 Jul 2025 10:08:50 +0200 Subject: [PATCH 011/164] Loop complete again --- template-rocq/theories/PartialLoopChecking.v | 122 +++++++++++++------ 1 file changed, 85 insertions(+), 37 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index b1d44dc1e..d6e12f9df 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -2804,8 +2804,8 @@ Definition is_update_of cls upd minit m := Section InnerLoop. Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) (loop : forall (V' U' : LevelSet.t) (cls : clauses) (minit m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V', model_of V' m & is_update_of cls U' minit m]), - lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls m). + (prf : [/\ clauses_conclusions cls ⊂_lset V', model_of V' minit & is_update_of cls U' minit m]), + lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls minit). Definition sum_W W (f : LevelSet.elt -> nat) : nat := LevelSet.fold (fun w acc => acc + f w)%nat W 0%nat. @@ -3514,6 +3514,12 @@ Proof. now apply hu. now apply hv. Qed. +Lemma total_model_of_union_inv U V cls : total_model_of (LevelSet.union U V) cls -> total_model_of U cls /\ total_model_of V cls. +Proof. + rewrite /total_model_of. + setoid_rewrite LevelSet.union_spec. firstorder. +Qed. + Lemma strictly_updates_loop cls V neV m m' : total_model_of V m -> enabled_clauses m cls -> @@ -3556,14 +3562,53 @@ Proof. rewrite LevelSet.union_spec. firstorder. Qed. +Lemma model_of_strictly_updates cls W V m m' : + clauses_conclusions cls ⊂_lset V -> + strictly_updates cls W m m' -> model_of V m -> model_of V m'. +Proof. + intros hcls su. + induction su. + - intros mv l hin. apply mv in hin. + red in hcls. setoid_rewrite clauses_conclusions_spec in hcls. + destruct cl as [prems [concl k]]. + destruct H0 as [minv [eqmin [nabove eqm]]]. rewrite eqm. + specialize (hcls concl). forward hcls. exists (prems, (concl, k)). split => //. + rewrite LevelMapFact.F.add_in_iff. now right. + - eauto. +Qed. + +Lemma total_model_of_strictly_updates cls W m m' : + strictly_updates cls W m m' -> + forall W', total_model_of W' m -> total_model_of W' m'. +Proof. + intros su. + induction su. + - intros W' mv l hin. apply mv in hin. + destruct cl as [prems [concl k]]. + destruct H0 as [minv [eqmin [nabove eqm]]]. setoid_rewrite eqm. + setoid_rewrite LevelMapFact.F.add_mapsto_iff. + red in mv. + destruct (eq_dec concl l). + * subst. eexists. left. split => //. + * destruct hin as [? lH]. eexists; right. split => //. exact lH. + - eauto. +Qed. + +Lemma check_model_ne {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> ~ LevelSet.Empty W. +Proof. + move/check_model_spec => [w'' [su ->]]. + apply strictly_updates_non_empty in su. + intros he. apply su. lsets. +Qed. + #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V, model_of V m & is_update_of cls U minit m]) : result V U cls m + (prf : [/\ clauses_conclusions cls ⊂_lset V, model_of V minit & is_update_of cls U minit m]) : result V U cls minit by wf (loop_measure V U) lexprod_rel := loop V U cls minit m prf with inspect (check_model cls (U, m)) := - | exist None eqm => Model LevelSet.empty {| model_model := m |} _ + | exist None eqm => Model U {| model_model := m |} _ | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { - | exist true eq := Loop W _ _ + | exist true eq := Loop W (check_model_ne eqm) _ (* Loop on cls ↓ W, with |W| < |V| *) | exist false neq with inner_loop V U minit loop W (cls ↓ W) m' _ := { | Loop W' ne isloop := Loop W' ne (loop_on_subset _ isloop) @@ -3573,7 +3618,7 @@ Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : mod with inspect (check_model cls (Wc, mwc.(model_model))) := { | exist None eqm' => Model (LevelSet.union W Wc) {| model_model := mwc.(model_model) |} _ | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { - | exist true _ := Loop Wcls _ _ + | exist true _ := Loop Wcls (check_model_ne eqm') _ | exist false neq' with loop V (LevelSet.union W Wcls) cls minit mcls _ := { (* Here Wcls < V, we've found a model for all of the clauses with conclusion in W, which can now be fixed. We concentrate on the clauses whose @@ -3590,9 +3635,8 @@ Proof. all:try eapply levelset_neq in neq. all:have cls_sub := clauses_conclusions_levels cls. all:destruct prf as [clsV mof isupd]. - - eapply check_model_is_update_of in eqm as [eqm incl]; tea. now eapply strictly_updates_non_empty in eqm. - - set (neW := ssr_have _ _); clearbody neW. - do 2 red. eapply LevelSet.equal_spec in eq. + - do 2 red. eapply LevelSet.equal_spec in eq. + set (prf := check_model_ne eqm); clearbody prf. eapply check_model_is_update_of in eqm; tea. rewrite eq in eqm. apply todo. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. @@ -3601,24 +3645,21 @@ Proof. split => //. split => //. lsets. now eapply strictly_updates_non_empty. apply clauses_conclusions_clauses_with_concl. now eapply strictly_updates_strenghten. - now intros ?; rewrite in_clauses_with_concl. - - eapply check_model_updates_spec in eqm'. 2:{ have hu := model_updates mwc. eapply strictly_updates_weaken; tea. - apply clauses_with_concl_subset. } - now eapply strictly_updates_non_empty. - - cbn. set prf := ssr_have _ _. clearbody prf. + - set (ne := check_model_ne eqm'). clearbody ne. eapply check_model_ext in eqm' as [eqm' incl']. 2:{ have hu := model_updates mwc. eapply strictly_updates_weaken; tea. apply clauses_with_concl_subset. } eapply check_model_is_update_of in eqm as [eqm incl]; tea. have tr := update_trans _ eqm eqm'. eapply LevelSet.equal_spec in e. rewrite e in tr. assert (LevelSet.union W V =_lset V). eapply strictly_updates_incl in eqm. lsets. rewrite H in tr. symmetry in e. - have [neV hl] := loop_on_proper _ _ prf cls e. apply hl. + have [neV hl] := loop_on_proper _ _ ne cls e. apply hl. have vm := model_ok mwc. apply todo. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hu := model_updates mwc. eapply check_model_ext in eqm' as [eqm' incl']. 2:{ eapply strictly_updates_weaken; tea. apply clauses_with_concl_subset. } - split => //. apply todo. + split => //. unfold is_update_of. eapply strictly_updates_weaken in hu. 2:eapply clauses_with_concl_subset. have hu' := update_trans _ eqm eqm'. @@ -3659,38 +3700,45 @@ Proof. - eapply mcls'. - apply mcls'. - apply mcls'. - - eapply check_model_spec in eqm as [Wm [sum' ->]]. - have hupd := model_updates mwc. - eapply check_model_spec in eqm' as [Wmwc [sumwc ->]]. - have hupd' := model_updates mcls'. - eapply (strictly_updates_weaken _ _ cls) in hupd. 2:{ intros ?. rewrite in_clauses_with_concl. clsets. } - have tr := update_trans _ (update_trans _ (update_trans _ sum' hupd) sumwc) hupd'. - eapply strictly_updates_proper; tea. 1,3-4:reflexivity. intros ?. lsets. + - exact (model_updates mcls'). - assumption. - apply mcls'. - - eapply check_model_spec in eqm as [Wm [sum' ->]]. - have hupd := model_updates mwc. - eapply check_model_spec in eqm' as [Wmwc [sumwc ->]]. - have hupd' := model_updates mcls'. - eapply (strictly_updates_weaken _ _ cls) in hupd. 2:{ intros ?. rewrite in_clauses_with_concl. clsets. } - have tr := update_trans _ (update_trans _ (update_trans _ sum' hupd) sumwc) hupd'. + - have hupd' := model_updates mcls'. split. now eapply strictly_updates_ext. apply todo. apply todo. - eapply check_model_is_update_of in eqm as []; tea. lsets. - apply todo. - - apply mwc. + - apply todo. - eapply check_model_is_update_of in eqm as []; tea. have h := model_incl mwc. eapply strictly_updates_incl in H. lsets. - - eapply check_model_spec in eqm as [Wm [sum' ->]]. + - eapply check_model_is_update_of in eqm as [suinit incl]; tea. have hupd := model_updates mwc. eapply (strictly_updates_weaken _ _ cls) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. - have tr := update_trans _ sum' hupd. - eapply strictly_updates_proper; tea. 1,3-4:reflexivity. - - - + exact: update_trans _ suinit hupd. + - assumption. + - now apply check_model_None in eqm'. + - eapply check_model_is_update_of in eqm as [suinit incl]; tea. + apply check_model_None in eqm'. + have hupd := model_updates mwc. + eapply (strictly_updates_weaken _ _ cls) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. + have tr := update_trans _ suinit hupd. + split. now apply strictly_updates_ext in tr. + apply todo. apply todo. + - apply check_model_spec in eqm as [? [su ->]]. lsets. + - move: isupd. rewrite /is_update_of. + destruct LevelSet.is_empty. + * now intros ->. + * intros su. + eapply model_of_strictly_updates; tea. + - apply todo. + - apply todo. + - apply todo. + - assumption. + - now eapply check_model_None in eqm. + - apply todo. + - lsets. +Qed. - move: isupd. rewrite /is_update_of. @@ -3701,8 +3749,8 @@ Proof. exact (valid_model_of mwc (model_of_ext mof ext)). } assert (WV : W ⊂_lset V). { clear -clsV WU lsets. } - eapply model_ext_trans_weaken => //. 2:tea. auto. transitivity mcls; [|apply mcls']. + eapply model_ext_trans_weaken => //. 2:tea. auto. transitivity (model_model mwc). 2:{ eapply model_extension_weaken; [|tea]. lsets. } eapply model_extension_weaken. 2:apply mwc. auto. eapply total_model_of_subset; [|apply hsub']. eapply valid_model_total; tea. From 9a4265676781d6eb06b312d5f489bbad7663610b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 29 Jul 2025 12:08:10 +0200 Subject: [PATCH 012/164] Partial Loop checking defined --- template-rocq/theories/PartialLoopChecking.v | 375 +++++++++++-------- 1 file changed, 214 insertions(+), 161 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index d6e12f9df..2d5ea2871 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -2551,12 +2551,16 @@ Proof. now subst wm'; rewrite eq. Qed. *) +Definition is_update_of cls upd minit m := + if LevelSet.is_empty upd then minit = m + else strictly_updates cls upd minit m. + Record valid_model_def (V W : LevelSet.t) (m : model) (cls : clauses) := { model_model : model; model_of_V :> model_of V model_model; model_of_W : total_model_of W model_model; model_incl : W ⊂_lset V; - model_updates : strictly_updates cls W m model_model; + model_updates : is_update_of cls W m model_model; model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; model_ok :> is_model cls model_model; model_extends : model_extension V m model_model; @@ -2791,15 +2795,28 @@ Proof. eapply (Acc_intro_generator 1000). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. Defined. +Lemma strictly_updates_trans {cls cls' W W' m m' m''} : + strictly_updates cls W m m' -> + strictly_updates cls' W' m' m'' -> + strictly_updates (Clauses.union cls cls') (LevelSet.union W W') m m''. + Proof. + intros su su'. + eapply update_trans; eapply strictly_updates_weaken; tea; clsets. + Qed. -Definition is_update_of cls upd minit m := - if LevelSet.is_empty upd then minit = m - else strictly_updates cls upd minit m. - - (* #[tactic="idtac"] - Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V, model_of V m & is_update_of cls U minit m]) : result V U cls m *) - +Lemma check_model_is_update_of {cls cls' U W minit m m'} : is_update_of cls U minit m -> check_model cls' (U, m) = Some (W, m') -> + strictly_updates (Clauses.union cls cls') W minit m' /\ U ⊂_lset W. +Proof. + rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros ->. eapply LevelSetFact.is_empty_2 in he. + eapply LevelSetProp.empty_is_empty_1 in he. + eapply LevelSet.eq_leibniz in he. rewrite he. + move/check_model_updates_spec_empty. intros H; split => //. 2:lsets. + eapply strictly_updates_weaken; tea. clsets. + - intros hs. move/check_model_spec => [w'' [su ->]]. split; [|lsets]. + eapply strictly_updates_trans; tea. +Qed. Section InnerLoop. Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) @@ -3016,6 +3033,13 @@ Section InnerLoop. now rewrite ClausesProp.union_sym union_diff_eq union_restrict_with_concl. Qed. + Lemma union_diff_cls {cls W} : + Clauses.Equal (Clauses.union (Clauses.diff (cls ↓ W) (cls ⇂ W)) cls) cls. + Proof. + intros ?. rewrite Clauses.union_spec Clauses.diff_spec in_restrict_clauses in_clauses_with_concl. + firstorder. + Qed. + Lemma maps_to_level_value x (m m' : model) : (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> level_value m x = level_value m' x. @@ -3193,6 +3217,100 @@ Section InnerLoop. rewrite LevelSetFact.is_empty_1 //. lsets. Qed. + Lemma is_update_of_case cls W m m' : + is_update_of cls W m m' -> + (LevelSet.Empty W /\ m = m') \/ strictly_updates cls W m m'. + Proof. + rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros ->. left => //. now eapply LevelSetFact.is_empty_2 in he. + - intros H; now right. + Qed. + + Lemma strictly_updates_W_eq cls W init m W' : + LevelSet.Equal W W' -> + strictly_updates cls W init m -> + strictly_updates cls W' init m. + Proof. now intros ->. Qed. + + Lemma strictly_updates_clauses_W cls cls' W init m W' : + Clauses.Subset cls cls' -> + LevelSet.Equal W W' -> + strictly_updates cls W init m -> + strictly_updates cls' W' init m. + Proof. intros hsub ->. now apply strictly_updates_weaken. Qed. + + Lemma strictly_updates_is_update_of cls W init m cls' W' m' : + strictly_updates cls W init m -> + is_update_of cls' W' m m' -> + strictly_updates (Clauses.union cls cls') (LevelSet.union W W') init m'. + Proof. + move=> su /is_update_of_case; intros [[empw eq]|su']. + subst m'. eapply (strictly_updates_weaken cls). clsets. + eapply strictly_updates_W_eq; tea. lsets. + eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. + Qed. + + + Lemma union_with_concl cls W : Clauses.Equal (Clauses.union cls (cls ↓ W)) cls. + Proof. + intros x. rewrite Clauses.union_spec in_clauses_with_concl. firstorder. + Qed. + + Instance is_update_of_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> eq ==> eq ==> iff) is_update_of. + Proof. + intros ?? H ?? H' ?? H'' ?? H'''. + unfold is_update_of. setoid_rewrite H'. destruct LevelSet.is_empty. firstorder. subst. reflexivity. subst. reflexivity. + subst. now rewrite H H'. + Qed. + + Lemma empty_union l : LevelSet.Equal (LevelSet.union LevelSet.empty l) l. + Proof. intros ?. lsets. Qed. + + Lemma is_update_of_strictly_updates cls W m m' : + strictly_updates cls W m m' -> + is_update_of cls W m m'. + Proof. + intros su. have ne := strictly_updates_non_empty su. + rewrite /is_update_of. now rewrite (proj2 (levelset_not_Empty_is_empty _) ne). + Qed. + + Lemma is_update_of_weaken {cls cls' W m m'} : + Clauses.Subset cls cls' -> + is_update_of cls W m m' -> is_update_of cls' W m m'. + Proof. + intros hsub. + move/is_update_of_case => []. + - intros []. subst. rewrite /is_update_of. + now rewrite (LevelSetFact.is_empty_1 H). + - intros su. have ne := strictly_updates_non_empty su. + unfold is_update_of. rewrite (proj2 (levelset_not_Empty_is_empty _) ne). + eapply strictly_updates_weaken; tea. + Qed. + + Lemma is_update_of_trans {cls cls' W W' m m' m''} : + is_update_of cls W m m' -> is_update_of cls' W' m' m'' -> + is_update_of (Clauses.union cls cls') (LevelSet.union W W') m m''. + Proof. + move/is_update_of_case => []. + - move=> [he <-]. intro. rewrite (LevelSetProp.empty_is_empty_1 he) empty_union. + move: H. eapply is_update_of_weaken. clsets. + - intros su isu. + eapply strictly_updates_is_update_of in isu; tea. + have ne := strictly_updates_non_empty isu. + rewrite /is_update_of. now rewrite (proj2 (levelset_not_Empty_is_empty _) ne). + Qed. + + Lemma is_update_of_trans_eq {cls cls' W W' cltr Wtr m m' m''} : + is_update_of cls W m m' -> is_update_of cls' W' m' m'' -> + Clauses.Subset (Clauses.union cls cls') cltr -> + LevelSet.Equal Wtr (LevelSet.union W W') -> + is_update_of cltr Wtr m m''. + Proof. + intros hi hi' hcl hw. rewrite hw. + eapply is_update_of_weaken; tea. + eapply is_update_of_trans; tea. + Qed. Section innerloop_partition. Context (W : LevelSet.t) (cls : clauses). @@ -3222,8 +3340,8 @@ Section InnerLoop. some atom in W has been strictly updated in Wconcl. *) } }. Proof. - all:cbn [model_model]; clear loop inner_loop_partition. all:try solve [try apply LevelSet.subset_spec; try reflexivity]. + all:cbn [model_model]; clear loop inner_loop_partition. all:try apply LevelSet.subset_spec in hsub. all:auto. all:try destruct prf as [WV neW UW clsW eqprem eqconcl]. @@ -3234,17 +3352,15 @@ Section InnerLoop. eapply is_update_of_empty. - left. now eapply strict_subset_cardinal. - destruct prf. transitivity (cls ⇂ W) => //. now rewrite H3. eapply restrict_clauses_subset. - - pose proof (check_model_updates_spec (init_model:=m) eqm); tea. - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. - assert (Wconcl ⊂_lset W). have incl := model_incl mr. lsets. - pose proof (model_updates mr). - apply H in H2 as [su incl]. - eapply (strictly_updates_weaken _ _ cls) in su. - have htr := update_trans _ upd su. - eapply strictly_updates_proper in htr; tea. - 1,3-4:reflexivity. lsets. - rewrite eqprem. rewrite union_diff. move=> l. now rewrite in_clauses_with_concl. - eapply mr. + - have mu := model_updates mr. + eapply strictly_updates_is_update_of in upd; tea. + apply check_model_spec in eqm as [Wconcl' [sumr ->]]. + have tr := strictly_updates_trans upd sumr. + eapply strictly_updates_clauses_W; tea. + { intros ?. rewrite eqprem. rewrite ClausesProp.union_assoc (ClausesProp.union_sym (restrict_clauses _ _)). + now rewrite union_diff union_with_concl. } + { have incl := model_incl mr. apply strictly_updates_incl in sumr. + have hdiff := clauses_conclusions_diff_left cls W (cls ⇂ W). lsets. } - have tmr : total_model_of W (model_model mr). { eapply valid_model_total. now eapply strictly_updates_total_model in upd. } eapply (check_model_spec_diff mr) in eqm as [subwwconcl subwconcl hm hext] => //. @@ -3264,18 +3380,23 @@ Section InnerLoop. - apply mr'. (* - apply clauses_conclusions_clauses_with_concl. *) - have mu := model_updates mr. have mu' := model_updates mr'. + eapply check_model_spec in eqm as [Wconcl' [su ->]]. + (* have := is_update_of_trans mu' mu. *) + apply todo. + (* eapply check_model_is_update_of in eqm; tea. apply (check_model_updates_spec (init_model:=m) eqm) in mu as [mu incl]. eapply (strictly_updates_weaken _ _ cls) in mu. have tr := update_trans _ mu mu'. now eapply strictly_updates_total_model in tr. - intros ?; rewrite eqprem. now rewrite union_diff in_clauses_with_concl. + intros ?; rewrite eqprem. now rewrite union_diff in_clauses_with_concl. *) - have incl := model_incl mr; have incl':= model_incl mr'. eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. lsets. eapply mr. - have mu := model_updates mr. have mu' := model_updates mr'. - apply (check_model_updates_spec (init_model:=m) eqm) in mu as [mu incl]. - eapply (strictly_updates_weaken _ _ cls) in mu. - eapply update_trans; tea. rewrite eqprem union_diff. - intros ?. rewrite in_clauses_with_concl => //. intuition. + eapply check_model_spec in eqm as [Wconc' [su ->]]; tea. + eapply is_update_of_strictly_updates in su. + eapply (is_update_of_trans_eq (cltr := cls)); tea. eapply (is_update_of_trans_eq (cltr := cls)); tea. + 2:reflexivity. 3:lsets. 2:rewrite eqprem. + rewrite union_diff_cls; clsets. intros ?. rewrite Clauses.union_spec in_restrict_clauses. firstorder. - apply mr'. - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. 2:apply mr. eapply model_ext_trans_weaken. 2:apply mr. lsets. @@ -3286,7 +3407,7 @@ Section InnerLoop. - apply mr. - apply mr. (* now eapply valid_model_total. *) - - have um := model_updates mr. eapply strictly_updates_weaken; tea. + - have um := model_updates mr. eapply is_update_of_weaken; tea. intros ?; rewrite eqprem in_restrict_clauses. now intros []. - rewrite check_model_is_model in eqm. have okm := (model_ok mr). @@ -3500,13 +3621,6 @@ Proof. Admitted. Definition correct_model (cls : clauses) (m : model) := enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. - Lemma valid_clause_model model cl : - enabled_clause model cl -> - valid_clause model cl -> - clause_sem (valuation_of_model model) cl. -Proof. -Admitted. - Lemma total_model_of_union U V cls : total_model_of U cls -> total_model_of V cls -> total_model_of (LevelSet.union U V) cls. Proof. intros hu hv x. @@ -3533,21 +3647,9 @@ Proof. cbn in tot. red in tot. specialize (tot concl). forward tot. eapply LevelSet.singleton_spec. reflexivity. eapply Clauses.for_all_spec in en. eapply en in H. - eapply valid_clause_model in H. red. + (* eapply valid_clause_model in H. red. *) Admitted. -Lemma check_model_is_update_of {cls U W minit m m'} : is_update_of cls U minit m -> check_model cls (U, m) = Some (W, m') -> - strictly_updates cls W minit m' /\ U ⊂_lset W. -Proof. - rewrite /is_update_of. - destruct LevelSet.is_empty eqn:he. - - intros ->. eapply LevelSetFact.is_empty_2 in he. - eapply LevelSetProp.empty_is_empty_1 in he. - eapply LevelSet.eq_leibniz in he. rewrite he. - move/check_model_updates_spec_empty. intros H; split => //; lsets. - - intros hs. now move/check_model_ext/(_ hs). -Qed. - Lemma strictly_updates_valid_model {W W' m m' cls} : is_model (cls ↓ W) m -> strictly_updates cls W' m m' -> @@ -3601,6 +3703,23 @@ Proof. intros he. apply su. lsets. Qed. +Lemma union_idem cls : Clauses.Equal (Clauses.union cls cls) cls. +Proof. intros ?; rewrite Clauses.union_spec. firstorder. Qed. + +Lemma check_model_update_of {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> + exists W', is_update_of cls W' m m' /\ W = LevelSet.union U W'. +Proof. + move/check_model_spec => [w'' [su ->]]. exists w''. split => //. + now eapply is_update_of_strictly_updates. +Qed. + +Lemma is_update_of_ext cls W m m' : is_update_of cls W m m' -> m ⩽ m'. +Proof. + move/is_update_of_case => []. + - intros [he%LevelSetProp.empty_is_empty_1]. now subst. + - apply strictly_updates_ext. +Qed. + #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) (prf : [/\ clauses_conclusions cls ⊂_lset V, model_of V minit & is_update_of cls U minit m]) : result V U cls minit @@ -3641,14 +3760,17 @@ Proof. apply todo. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hi := strictly_updates_incl eqm. + rewrite union_idem in hi, eqm. (* apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. *) split => //. split => //. lsets. now eapply strictly_updates_non_empty. apply clauses_conclusions_clauses_with_concl. now eapply strictly_updates_strenghten. - now intros ?; rewrite in_clauses_with_concl. - set (ne := check_model_ne eqm'). clearbody ne. - eapply check_model_ext in eqm' as [eqm' incl']. - 2:{ have hu := model_updates mwc. eapply strictly_updates_weaken; tea. apply clauses_with_concl_subset. } + have hu := model_updates mwc. + eapply check_model_is_update_of in eqm' as [eqm' incl']; tea. + rewrite ClausesProp.union_sym union_with_concl in eqm'. eapply check_model_is_update_of in eqm as [eqm incl]; tea. + rewrite union_idem in eqm. have tr := update_trans _ eqm eqm'. eapply LevelSet.equal_spec in e. rewrite e in tr. assert (LevelSet.union W V =_lset V). eapply strictly_updates_incl in eqm. lsets. rewrite H in tr. symmetry in e. @@ -3657,27 +3779,21 @@ Proof. apply todo. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hu := model_updates mwc. - eapply check_model_ext in eqm' as [eqm' incl']. - 2:{ eapply strictly_updates_weaken; tea. apply clauses_with_concl_subset. } - split => //. - unfold is_update_of. - eapply strictly_updates_weaken in hu. 2:eapply clauses_with_concl_subset. - have hu' := update_trans _ eqm eqm'. - have ne := strictly_updates_non_empty hu'. - rewrite -levelset_not_Empty_is_empty in ne. now rewrite ne. + eapply strictly_updates_is_update_of in hu; tea. + rewrite union_idem union_with_concl in hu. + eapply check_model_update_of in eqm' as [wmcls [upd ->]]. + eapply is_update_of_strictly_updates in hu. + have tr := is_update_of_trans_eq hu upd. + split => //. apply tr. clsets. lsets. - right. eapply check_model_spec_V in eqm' as eqm''; tea. cbn in eqm''. 2:{ apply todo. } 2:{ apply mwc. } destruct eqm'' as []. eapply check_model_is_update_of in eqm as [eqm incl]; tea. + rewrite union_idem in eqm. have hu := model_updates mwc. - - (* eapply check_model_spec in eqm' as [wmwc [sumwc ->]]. *) eapply check_model_is_update_of in eqm' as [eqm' incl']; tea. - 2:{ unfold is_update_of. - have := strictly_updates_non_empty hu => hne. - rewrite (proj2 (levelset_not_Empty_is_empty _) hne). - eapply strictly_updates_weaken; tea. apply clauses_with_concl_subset. } + rewrite ClausesProp.union_sym union_with_concl in eqm'. have WcW := model_incl mwc. (* destruct hsub' as [UWc WcW]. *) have w_incl := strictly_updates_incl eqm. @@ -3704,26 +3820,27 @@ Proof. - assumption. - apply mcls'. - have hupd' := model_updates mcls'. - split. now eapply strictly_updates_ext. + split. now eapply is_update_of_ext. apply todo. apply todo. - - eapply check_model_is_update_of in eqm as []; tea. lsets. + - eapply check_model_is_update_of in eqm as []; tea. rewrite union_idem in H. lsets. - apply todo. - apply todo. - - eapply check_model_is_update_of in eqm as []; tea. + - eapply check_model_is_update_of in eqm as []; tea. rewrite union_idem in H. have h := model_incl mwc. eapply strictly_updates_incl in H. lsets. - - eapply check_model_is_update_of in eqm as [suinit incl]; tea. + - eapply check_model_is_update_of in eqm as [suinit incl]; tea. rewrite union_idem in suinit. have hupd := model_updates mwc. - eapply (strictly_updates_weaken _ _ cls) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. - exact: update_trans _ suinit hupd. + eapply (is_update_of_weaken (cls' := cls)) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. + eapply is_update_of_trans_eq. eapply is_update_of_strictly_updates. tea. tea. clsets. lsets. - assumption. - now apply check_model_None in eqm'. - - eapply check_model_is_update_of in eqm as [suinit incl]; tea. + - eapply check_model_is_update_of in eqm as [suinit incl]; tea. rewrite union_idem in suinit. apply check_model_None in eqm'. have hupd := model_updates mwc. - eapply (strictly_updates_weaken _ _ cls) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. + apply todo. + (* eapply (strictly_updates_weaken _ _ cls) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. have tr := update_trans _ suinit hupd. split. now apply strictly_updates_ext in tr. - apply todo. apply todo. + apply todo. apply todo. *) - apply check_model_spec in eqm as [? [su ->]]. lsets. - move: isupd. rewrite /is_update_of. destruct LevelSet.is_empty. @@ -3731,59 +3848,16 @@ Proof. * intros su. eapply model_of_strictly_updates; tea. - apply todo. - - apply todo. - - apply todo. + - move/is_update_of_case: isupd => []. + + intros [eu ->]. lsets. + + intros su. eapply strictly_updates_incl in su. lsets. + - exact isupd. - assumption. - now eapply check_model_None in eqm. - apply todo. - lsets. Qed. - - - - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. - eapply check_model_spec in eqm' as []. - 2:{ eapply model_of_subset. 2:exact clsV. - exact (valid_model_of mwc (model_of_ext mof ext)). } - assert (WV : W ⊂_lset V). - { clear -clsV WU lsets. } - transitivity mcls; [|apply mcls']. - eapply model_ext_trans_weaken => //. 2:tea. auto. - transitivity (model_model mwc). 2:{ eapply model_extension_weaken; [|tea]. lsets. } - eapply model_extension_weaken. 2:apply mwc. auto. - eapply total_model_of_subset; [|apply hsub']. eapply valid_model_total; tea. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. - eapply check_model_spec in eqm' as []. - 2:{ eapply model_of_subset. 2:exact clsV. - exact (valid_model_of mwc (model_of_ext mof ext)). } - split. 1-2:clear -hsub' hsub'' UV H1; lsets. - eapply total_model_of_subset; [|apply hsub']; apply valid_model_total; tea. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. - refine (valid_model_of mwc _). - refine (model_of_ext mof ext). - - apply mwc. - - auto. - - rewrite check_model_is_model // in eqm'. - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. - refine (valid_model_of mwc _). - eapply model_of_subset. - refine (model_of_ext mof ext). auto. apply mwc. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. - transitivity m'. eapply model_extension_weaken; [|tea]. lsets. - eapply model_extension_weaken. 2:apply mwc. lsets. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. - split; lsets. - - exact mof. - - exact H. - - exact clsV. - - apply check_model_is_model in eqm; eauto. - eapply model_of_subset; tea. - - reflexivity. - - split; lsets. -Qed. - Transparent lexprod_rel_wf. Definition zero_model levels := @@ -4169,12 +4243,11 @@ Definition init_w (levels : LevelSet.t) : LevelSet.t := LevelSet.empty. Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). Equations? infer (cls : clauses) : infer_result (clauses_levels cls) cls := - infer cls := loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (And4 _ _ _ _). + infer cls := loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (init_model cls) (And3 _ _ _). Proof. - now eapply clauses_conclusions_levels. - - lsets. - red. now eapply init_model_levels. - - red. intros k. now rewrite LevelSetFact.empty_iff. + - apply is_update_of_empty. Qed. (* Lemma valuation_of_model_pos l k model : LevelMap.MapsTo l (Z.to_nat k) (valuation_of_model model) -> (k >= 0)%Z. @@ -4204,7 +4277,7 @@ Definition print_level_Z_map (m : LevelMap.t (option Z)) := Definition print_result {V cls} (m : infer_result V cls) := match m return string with - | Loop => "looping" + | Loop _ _ _ => "looping" | Model w m _ => "satisfiable with model: " ^ print_level_Z_map m.(model_model) ^ nl ^ " W = " ^ print_lset w ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model m.(model_model)) @@ -4212,7 +4285,7 @@ Definition print_result {V cls} (m : infer_result V cls) := Definition valuation_of_result {V cls} (m : infer_result V cls) := match m with - | Loop => "looping" + | Loop _ _ _ => "looping" | Model w m _ => print_level_nat_map (valuation_of_model m.(model_model)) end. @@ -4234,16 +4307,16 @@ Definition print_clauses (cls : clauses) := Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) (prf : clauses_conclusions cls ⊂_lset V /\ clauses_conclusions cls' ⊂_lset V /\ model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := - | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m _. + | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m m _. Proof. - split. 2:lsets. + split. intros x. rewrite clauses_conclusions_spec. intros [cl [hcl hl]]. rewrite Clauses.union_spec in hcl. destruct hcl. - apply H, clauses_conclusions_spec. exists cl => //. - apply H0, clauses_conclusions_spec. exists cl => //. - exact H1. - - intros x. now rewrite LevelSetFact.empty_iff. + - eapply is_update_of_empty. Qed. (* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by @@ -4266,7 +4339,7 @@ Qed. Definition enforce_clauses {V W init cls} (m : valid_model V W init cls) cls' : option model := match infer_extension m cls' with - | Loop => None + | Loop _ _ _ => None | Model w m _ => Some m.(model_model) end. @@ -4371,15 +4444,17 @@ Definition premises_model V cl : LevelSet.t * model := (levels, premises_model_map (undefined_model levels) (Clauses.singleton cl)). Program Definition loop_check {V init cls} (m : valid_model V V init cls) (cl : clause) : result (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 := - loop (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 _. + loop (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 (premises_model V cl).2 _. Next Obligation. - destruct m. split => //. 1-2:lsets. admit. - - now intros x; rewrite LevelSetFact.empty_iff. -Admitted. + destruct m. split => //. + - lsets. + - apply todo. + - apply is_update_of_empty. +Qed. Equations check {V init cls} (m : valid_model V V init cls) (cl : clause) : bool := check m cl with loop_check m cl := - | Loop => false (* Actually impossible *) + | Loop _ _ _ => false (* Actually impossible *) | Model W v _ => let '(concl, k) := concl cl in match LevelMap.find concl v.(model_model) with @@ -4390,15 +4465,14 @@ Equations check {V init cls} (m : valid_model V V init cls) (cl : clause) : bool Equations? infer_model (cls : clauses) : option model := -infer_model cls with loop (clauses_levels cls) LevelSet.empty cls (init_model cls) _ := - | Loop => None +infer_model cls with loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (init_model cls) _ := + | Loop _ _ _ => None | Model w vm heq => Some vm.(model_model). Proof. split. - apply clauses_conclusions_levels. - - lsets. - - apply infer_obligation_3. - - apply infer_obligation_4. + - apply infer_obligation_2. + - apply is_update_of_empty. Qed. Definition infer_correctness cls := forall m, infer_model cls = Some m -> correct_model cls m. @@ -4464,7 +4538,7 @@ Lemma infer_correct cls : infer_correctness cls. Proof. intros m. funelim (infer_model cls) => //. - intros [= <-]. clear Heq Heqcall. destruct vm as [model ofV ovW clsconcl ism mext], heq; cbn in *. + intros [= <-]. clear Heq Heqcall. destruct vm as [model ofV ovW wcls isupd clsconcl ism mext]; cbn in *. set (V := clauses_levels cls) in *. assert (total_model_of V model). { intros l inl. apply model_ext_le in mext. red in mext. @@ -4540,28 +4614,7 @@ Proof. rewrite H4 //=. unfold flip. move/Clauses.add_spec. intros [->|] => //. 2:{ now apply Clauses.empty_spec in H5. } destruct minelt as [min k']. cbn. - - - - assert (min_premise undef_model prems = Some z). - { - (min_premise_pres _ _ _ ) - - - - } - - - -Proof. - repeat split. - - pose proof (model_clauses_conclusions m). lsets. - - pose proof (clauses_conclusions_levels cls'). lsets. - - red. intros. - unfold min_model. rewrite min_model_map_levels. - pose proof (model_of_V m k). - apply LevelSet.union_spec in H as []; auto. -Qed. +Abort. End LoopChecking. From f4562d3b6a48d11f9a3b54ba45de74fdb25e4f7a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 29 Jul 2025 15:04:38 +0200 Subject: [PATCH 013/164] Only looping cases to do --- template-rocq/theories/PartialLoopChecking.v | 578 ++++++++++--------- 1 file changed, 304 insertions(+), 274 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 2d5ea2871..f64e5cc92 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -86,7 +86,7 @@ Module Type LoopCheckingItf (Level : LevelOrderedType) (LevelExprSet : LevelExprSet_fun Level LevelExpr) (LevelMap : FMapOTInterface Level). - Definition model := LevelMap.t Z. + Definition model := LevelMap.t (option Z). Definition valuation := LevelMap.t nat. Definition clause : Type := LevelExprSet.nonEmptyLevelExprSet × LevelExpr.t. @@ -100,9 +100,9 @@ Module Type LoopCheckingItf (Level : LevelOrderedType) Parameter enforce_constraint : forall (cstr : constraint) (cls : clauses), clauses. - Parameter valid_model : forall (V : LevelSet.t) (m : model) (cls : clauses), Type. + Parameter valid_model : forall (V : LevelSet.t) (U : LevelSet.t) (m : model) (cls : clauses), Type. - Parameter model_model : forall V m cls, valid_model V m cls -> model. + Parameter model_model : forall V U m cls, valid_model V U m cls -> model. (* { model_model : model; model_of_V :> model_of V model_model; @@ -113,11 +113,13 @@ Module Type LoopCheckingItf (Level : LevelOrderedType) Infix "⊂_lset" := LevelSet.Subset (at level 70). - Parameter enforce_clauses : forall {V init cls} (m : valid_model V init cls) (cls' : clauses), option model. + Parameter enforce_clauses : forall {V U init cls} (m : valid_model V U init cls) (cls' : clauses), option model. + + Parameter loop_on : forall w : LevelSet.t, ~ LevelSet.Empty w -> clauses -> Prop. Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := - | Loop - | Model (w : LevelSet.t) (m : valid_model V m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). + | Loop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne cls) + | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). Parameter init_model : clauses -> model. Parameter clauses_levels : clauses -> LevelSet.t. @@ -1999,53 +2001,11 @@ Proof. intros hleq; depelim hleq. now apply Z.leb_le. Qed. -Axiom todo : forall {A}, A. - Lemma level_value_add m l k : level_value (LevelMap.add l k m) l = k. Proof. rewrite /level_value LevelMapFact.F.add_eq_o //. Qed. -(* Lemma is_update_check_model_invariants cls m W m' : ~ LevelSet.Empty W -> is_update cls m W m' -> check_model_invariants cls LevelSet.empty m W m' true. -Proof. - unfold is_update. intros hw [hupd hnupd]. - unfold check_model_invariants. - eapply nEmpty_exists in hw as [l hl]. - split. - - lsets. - - intros hl' hin'. - specialize (hupd _ hin') as [prems [k [v [clin [minp [nabove above]]]]]]. - rewrite LevelSet.union_spec. right. - rewrite clauses_conclusions_spec. eexists; split; eauto. - - specialize (hupd l hl) as [prems [k [v [clin [minp [nabove above]]]]]]. - eexists; split; tea. rewrite /valid_clause. rewrite minp //=. - cbn. move: nabove; unfold level_value_above. - destruct level_value eqn:hlev; try constructor. - rewrite above level_value_add. - intros nabove. rewrite -Z.ltb_antisym in nabove. - constructor. move/Z.ltb_lt: nabove. lia. - - split. - { intros l' k hm. - destruct (inLevelSet W l'). - specialize (hupd _ H) as [prems [k' [v' [clin [minp [nabove above]]]]]]. - eapply negbTE in nabove. - eapply level_value_not_above_spec in nabove. - rewrite (level_value_MapsTo hm) in nabove. - setoid_rewrite above. - exists (Some (Z.of_nat k' + clin)). split => //. - rewrite LevelMapFact.F.add_mapsto_iff. left; split => //. red. - depelim nabove; constructor; lia. - specialize (hnupd _ H). exists k. split; [|reflexivity]. - now rewrite -hnupd. } - red. - intros l'. apply todo. - exact hnupd. - - intros l' hl'. specialize (hupd _ hl') as [prems [k' [v' [clin [minp [nabove above]]]]]]. - setoid_rewrite above. eexists. - rewrite LevelMapFact.F.add_mapsto_iff. left. split => //. - (* eapply level_value_above_MapsTo in above as [k2 [mk' leqk']]. depelim leqk'. now exists y. *) -Qed. *) - #[local] Instance clauses_conclusions_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_conclusions. Proof. intros cls cls' eq x. @@ -2340,45 +2300,6 @@ Proof. eapply LevelSet.eq_leibniz. intros x; lsets. Qed. -Lemma check_model_has_invariants {cls w m w' m'} : - model_of (clauses_conclusions cls) m -> - total_model_of w m -> - check_model cls (w, m) = Some (w', m') -> - check_model_invariants cls w m w' m' true. -Proof. - intros mof tot. - move/check_model_spec => [w'' [su ->]]. - cbn. split. - - lsets. - - apply strictly_updates_incl in su. lsets. - - clear -su. induction su. - * exists cl. split => //. now eapply strict_update_invalid. - unfold clause_conclusion. lsets. - destruct cl as [prems [concl k]]. - destruct H0 as [minp [hin [hnabove habove]]]. - move: hnabove habove. rewrite /level_value_above. - cbn. destruct level_value eqn:hv => //; try constructor. - intros hle. intros ->. rewrite level_value_add. constructor. - move/negbTE: hle. lia. - * destruct IHsu1 as [cl []]. - exists cl. split => //. lsets. - apply strictly_updates_ext in su2. - depelim H2; rewrite ?H3. 2:{ rewrite H2; constructor. } - eapply level_value_MapsTo', su2 in H4 as [k' [map le]]. - eapply level_value_MapsTo in map. rewrite map. depelim le; constructor. lia. - - constructor. now eapply strictly_updates_ext. - clear -mof su. - induction su. - * move: H0; unfold strict_update. destruct cl as [prems [concl k]]. - intros [v [hmi [nabove eqm]]]. intros l. rewrite eqm. - rewrite LevelMapFact.F.add_in_iff. specialize (mof l). - rewrite clauses_conclusions_spec in mof. firstorder. - * specialize (IHsu1 mof). transitivity m' => //. - apply IHsu2. intros l hin. specialize (mof _ hin). now apply IHsu1 in mof. - * apply todo. - - apply todo. -Qed. - Lemma check_model_is_model {W cls m} : check_model cls (W, m) = None <-> is_model cls m. Proof. @@ -2558,26 +2479,19 @@ Definition is_update_of cls upd minit m := Record valid_model_def (V W : LevelSet.t) (m : model) (cls : clauses) := { model_model : model; model_of_V :> model_of V model_model; - model_of_W : total_model_of W model_model; - model_incl : W ⊂_lset V; model_updates : is_update_of cls W m model_model; model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; model_ok :> is_model cls model_model; - model_extends : model_extension V m model_model; }. Arguments model_model {V W m cls}. Arguments model_of_V {V W m cls}. -Arguments model_of_W {V W m cls}. -Arguments model_incl {V W m cls}. Arguments model_updates {V W m cls}. Arguments model_clauses_conclusions {V W m cls}. Arguments model_ok {V W m cls}. -Arguments model_extends {V W m cls}. Extraction Inline model_model. Definition valid_model := valid_model_def. - Definition add_expr n '((l, k) : LevelExpr.t) := (l, k + n)%nat. Lemma add_expr_add_expr n n' lk : add_expr n (add_expr n' lk) = add_expr (n + n') lk. @@ -2753,37 +2667,6 @@ Definition option_of_result {V U m cls} (r : result V U m cls) : option model := | Loop w hne isloop => None end. -Definition extends_model {W U cls m m'} : - m' ⩽ m -> - model_same_domain m' m -> - model_map_outside W m' m -> - result W U cls m -> result W U cls m'. -Proof. - intros leq ldom lout []. - - eapply Loop; tea. - - econstructor 2; tea. - destruct m0. econstructor; tea. - apply todo. - now transitivity m. -Qed. - -(* #[tactic="idtac"] -Equations? result_inclusion {V U m cls V'} (r : result V U cls m) - (prf : LevelSet.Subset V V') : result V' U cls m := - result_inclusion Loop _ := Loop; - result_inclusion (Model w m' sub) sub' := - Model w {| model_model := m'.(model_model) |} _. -Proof. - - - - transitivity V => //. now eapply m'.(model_clauses_conclusions). - - apply m'. - - apply m'. - - apply m'. - - intros x hin. apply m'. intros hv. - apply sub' in hv. now apply hin. - - intuition lsets. -Qed. *) - Notation "#| V |" := (LevelSet.cardinal V). Notation loop_measure V W := (#|V|, #|V| - #|W|)%nat. @@ -2818,6 +2701,269 @@ Proof. eapply strictly_updates_trans; tea. Qed. +Lemma is_update_of_case cls W m m' : + is_update_of cls W m m' -> + (LevelSet.Empty W /\ m = m') \/ strictly_updates cls W m m'. +Proof. + rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros ->. left => //. now eapply LevelSetFact.is_empty_2 in he. + - intros H; now right. +Qed. + + +Lemma model_incl {V W m cls} : valid_model V W m cls -> W ⊂_lset V. +Proof. + intros vm; have upd := model_updates vm. + move/is_update_of_case: upd => []. + - intros [ne eq]. lsets. + - move/strictly_updates_incl. have hv := model_clauses_conclusions vm. lsets. +Qed. + +(* + model_of_W : total_model_of W model_model; + model_incl : ; +model_extends : model_extension V m model_model; + +Arguments model_of_W {V W m cls}. +Arguments model_incl {V W m cls}. +Arguments model_extends {V W m cls}. + *) + +Lemma total_model_of_ext {W m m'} : + total_model_of W m -> m ⩽ m' -> total_model_of W m'. +Proof. + intros mof ext. + intros k hin. destruct (mof k hin). specialize (ext _ _ H) as [k' []]. depelim H1. now exists y. +Qed. + +Lemma valid_model_total W W' m cls : + forall vm : valid_model W W' m cls, total_model_of W m -> total_model_of W (model_model vm). +Proof. + intros []; cbn => htot. + move/is_update_of_case: model_updates0 => []. + - intros [ne ->] => //. + - intros su. eapply strictly_updates_ext in su. + eapply total_model_of_ext; tea. +Qed. + +Lemma is_update_of_ext {cls W m m'} : is_update_of cls W m m' -> m ⩽ m'. +Proof. + move/is_update_of_case => []. + - intros [he%LevelSetProp.empty_is_empty_1]. now subst. + - apply strictly_updates_ext. +Qed. + +Lemma total_model_of_union {U V cls} : total_model_of U cls -> total_model_of V cls -> total_model_of (LevelSet.union U V) cls. +Proof. + intros hu hv x. + rewrite LevelSet.union_spec; move => [] hin. + now apply hu. now apply hv. +Qed. + +Lemma total_model_of_union_inv U V cls : total_model_of (LevelSet.union U V) cls -> total_model_of U cls /\ total_model_of V cls. +Proof. + rewrite /total_model_of. + setoid_rewrite LevelSet.union_spec. firstorder. +Qed. + + +Lemma strictly_updates_total_model_gen cls W m m' : + strictly_updates cls W m m' -> + forall W', total_model_of W' m -> total_model_of (LevelSet.union W' W) m'. +Proof. + clear. + induction 1. + - intros W' tot x. + destruct cl as [prems [concl cl]]. + destruct H0 as [minv [hmin []]]. setoid_rewrite H1. + setoid_rewrite LevelMapFact.F.add_mapsto_iff. cbn. + destruct (Level.eq_dec concl x). + { subst. exists (Z.of_nat cl + minv). now left. } + { rewrite LevelSet.union_spec; intros [hin|hin]. + { eapply tot in hin as [wit mt]. exists wit. now right. } + { eapply LevelSet.singleton_spec in hin. red in hin; subst. congruence. } } + - intros W' tot. + eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. + eapply total_model_of_subset; tea. intros x; lsets. +Qed. + +Lemma total_model_of_empty m : total_model_of LevelSet.empty m. +Proof. intros x; now move/LevelSet.empty_spec. Qed. + +Instance total_model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) total_model_of. +Proof. + intros ? ? H ? ? H'. unfold total_model_of. setoid_rewrite H. + now setoid_rewrite H'. +Qed. + +Lemma strictly_updates_total_model {cls W m m'} : + strictly_updates cls W m m' -> + total_model_of W m'. +Proof. + move/strictly_updates_total_model_gen/(_ LevelSet.empty). + intros H. forward H. apply total_model_of_empty. + rewrite LevelSetProp.empty_union_1 in H => //. lsets. +Qed. + +Lemma is_update_of_total_model cls W m m' : is_update_of cls W m m' -> total_model_of W m'. +Proof. + move/is_update_of_case => []. + - intros [he ->]. + rewrite /total_model_of. lsets. + - eapply strictly_updates_total_model. +Qed. + +Instance model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) model_of. +Proof. + intros ? ? H ? ? H'. unfold model_of. setoid_rewrite H. + now setoid_rewrite H'. +Qed. + +Lemma model_of_union U V cls : model_of U cls -> model_of V cls -> model_of (LevelSet.union U V) cls. +Proof. + intros hu hv x. + rewrite LevelSet.union_spec; move => [] hin. + now apply hu. now apply hv. +Qed. + +Lemma model_of_union_inv U V cls : model_of (LevelSet.union U V) cls -> model_of U cls /\ model_of V cls. +Proof. + rewrite /model_of. + setoid_rewrite LevelSet.union_spec. firstorder. +Qed. + +Lemma strict_update_modify m cl m' : strict_update m cl m' -> + exists k, LevelMap.Equal m' (LevelMap.add (clause_conclusion cl) (Some k) m). +Proof. + rewrite /strict_update. + destruct cl as [prems [concl k]]. + intros [v [hmin [hab eq]]]. now exists (Z.of_nat k + v). +Qed. + +Lemma strictly_updates_model_of_gen {cls W m m'} : + strictly_updates cls W m m' -> forall W', model_of W' m -> model_of (LevelSet.union W' W) m'. +Proof. + induction 1. + - intros W' mw'. + intros k. rewrite LevelSet.union_spec LevelSet.singleton_spec //=. + specialize (mw' k). + eapply strict_update_modify in H0 as [k' ->]. + rewrite LevelMapFact.F.add_in_iff. firstorder. now left. + - intros W' mw'. eapply IHstrictly_updates1 in mw'. + eapply IHstrictly_updates2 in mw'. + now rewrite -LevelSetProp.union_assoc. +Qed. + +Lemma model_of_empty m : model_of LevelSet.empty m. +Proof. intros x; now move/LevelSet.empty_spec. Qed. + +Lemma strictly_updates_model_of {cls W m m'} : + strictly_updates cls W m m' -> model_of W m'. +Proof. + move/strictly_updates_model_of_gen/(_ LevelSet.empty). + rewrite LevelSetProp.empty_union_1. lsets. + intros H; apply H. apply model_of_empty. +Qed. + +Lemma strictly_updates_modify {cls W m m'} : + strictly_updates cls W m m' -> + forall l k, LevelMap.MapsTo l k m' -> LevelSet.In l W \/ LevelMap.MapsTo l k m. +Proof. + induction 1. + + eapply strict_update_modify in H0 as [k eq]. + intros l k'. rewrite LevelSet.singleton_spec. + rewrite eq. + rewrite LevelMapFact.F.add_mapsto_iff. + intros [[]|] => //. red in H0; subst. + left. lsets. now right. + + intros. eapply IHstrictly_updates2 in H1. + destruct H1. left; lsets. + eapply IHstrictly_updates1 in H1 as []. left; lsets. + now right. +Qed. + +Lemma strictly_updates_modify_inv {cls W m m'} : + strictly_updates cls W m m' -> + forall l k, LevelMap.MapsTo l k m -> LevelSet.In l W \/ LevelMap.MapsTo l k m'. +Proof. + induction 1. + + eapply strict_update_modify in H0 as [k eq]. + intros l k'. rewrite LevelSet.singleton_spec. + rewrite eq. + rewrite LevelMapFact.F.add_mapsto_iff. + intros hm. unfold Level.eq. + destruct (eq_dec l (clause_conclusion cl)). subst. now left. + right. right. auto. + + intros. eapply IHstrictly_updates1 in H1 as []. + left; lsets. + eapply IHstrictly_updates2 in H1 as []. left; lsets. + now right. +Qed. + +Lemma strictly_updates_outside cls W m m' : + strictly_updates cls W m m' -> model_map_outside W m m'. +Proof. + move=> su. + have lr := strictly_updates_modify su. + have rl := strictly_updates_modify_inv su. + intros l nin k. + split; intros. + - apply rl in H as [] => //. + - apply lr in H as [] => //. +Qed. + +Lemma valid_model_model_map_outside {W W' m cls} (vm : valid_model W W' m cls) : model_map_outside W m (model_model vm). +Proof. + destruct vm as [m' mV mupd mcls mok]; cbn. + - move/is_update_of_case: mupd => []. + * intros [ne <-]. red. intros. reflexivity. + * intros su. eapply (model_map_outside_weaken (W:=W')). + 2:{ eapply strictly_updates_incl in su. lsets. } + clear -su. revert su. + eapply strictly_updates_outside. +Qed. + + +Lemma check_model_has_invariants {cls w m w' m'} : + model_of (clauses_conclusions cls) m -> + total_model_of w m -> + check_model cls (w, m) = Some (w', m') -> + check_model_invariants cls w m w' m' true. +Proof. + intros mof tot. + move/check_model_spec => [w'' [su ->]]. + cbn. split. + - lsets. + - apply strictly_updates_incl in su. lsets. + - clear -su. induction su. + * exists cl. split => //. now eapply strict_update_invalid. + unfold clause_conclusion. lsets. + destruct cl as [prems [concl k]]. + destruct H0 as [minp [hin [hnabove habove]]]. + move: hnabove habove. rewrite /level_value_above. + cbn. destruct level_value eqn:hv => //; try constructor. + intros hle. intros ->. rewrite level_value_add. constructor. + move/negbTE: hle. lia. + * destruct IHsu1 as [cl []]. + exists cl. split => //. lsets. + apply strictly_updates_ext in su2. + depelim H2; rewrite ?H3. 2:{ rewrite H2; constructor. } + eapply level_value_MapsTo', su2 in H4 as [k' [map le]]. + eapply level_value_MapsTo in map. rewrite map. depelim le; constructor. lia. + - constructor. now eapply strictly_updates_ext. + clear -mof su. + induction su. + * move: H0; unfold strict_update. destruct cl as [prems [concl k]]. + intros [v [hmi [nabove eqm]]]. intros l. rewrite eqm. + rewrite LevelMapFact.F.add_in_iff. specialize (mof l). + rewrite clauses_conclusions_spec in mof. firstorder. + * specialize (IHsu1 mof). transitivity m' => //. + apply IHsu2. intros l hin. specialize (mof _ hin). now apply IHsu1 in mof. + * eapply model_map_outside_weaken. now eapply strictly_updates_outside. lsets. + - eapply strictly_updates_total_model_gen in su; tea. +Qed. + Section InnerLoop. Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) (loop : forall (V' U' : LevelSet.t) (cls : clauses) (minit m : model) @@ -3116,13 +3262,6 @@ Section InnerLoop. intros k hin. apply dom. now apply mof. Qed. - Lemma total_model_of_ext {W W' m m'} : - total_model_of W m -> model_extension W' m m' -> total_model_of W m'. - Proof. - intros mof [ext _ _]. - intros k hin. destruct (mof k hin). specialize (ext _ _ H) as [k' []]. depelim H1. now exists y. - Qed. - Lemma clauses_partition_spec {cls W allW conclW} : clauses_conclusions cls ⊂_lset W -> Clauses.partition (premise_restricted_to W) cls = (allW, conclW) -> @@ -3160,12 +3299,6 @@ Section InnerLoop. apply cl, clauses_conclusions_spec. now exists x. Qed. - Lemma valid_model_total W W' m cls : - forall vm : valid_model W W' m cls, total_model_of W m -> total_model_of W (model_model vm). - Proof. - intros []; cbn => htot. eapply total_model_of_ext; tea. - Qed. - (* Inductive inner_result (V U : LevelSet.t) (cls : clauses) (m : model) := | InLoop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne cls) | InModel (w : LevelSet.t) (m : valid_model V w m cls). @@ -3173,43 +3306,6 @@ Section InnerLoop. Arguments InLoop {V U cls m}. Arguments InModel {V U cls m}. *) - Lemma strictly_updates_total_model_gen cls W m m' : - strictly_updates cls W m m' -> - forall W', total_model_of W' m -> total_model_of (LevelSet.union W' W) m'. - Proof. - clear. - induction 1. - - intros W' tot x. - destruct cl as [prems [concl cl]]. - destruct H0 as [minv [hmin []]]. setoid_rewrite H1. - setoid_rewrite LevelMapFact.F.add_mapsto_iff. cbn. - destruct (Level.eq_dec concl x). - { subst. exists (Z.of_nat cl + minv). now left. } - { rewrite LevelSet.union_spec; intros [hin|hin]. - { eapply tot in hin as [wit mt]. exists wit. now right. } - { eapply LevelSet.singleton_spec in hin. red in hin; subst. congruence. } } - - intros W' tot. - eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. - eapply total_model_of_subset; tea. intros x; lsets. - Qed. - - Instance total_model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) total_model_of. - Proof. - intros ? ? H ? ? H'. unfold total_model_of. setoid_rewrite H. - now setoid_rewrite H'. - Qed. - - Lemma total_model_of_empty m : total_model_of LevelSet.empty m. - Proof. intros x; now move/LevelSet.empty_spec. Qed. - - Lemma strictly_updates_total_model {cls W m m'} : - strictly_updates cls W m m' -> - total_model_of W m'. - Proof. - move/strictly_updates_total_model_gen/(_ LevelSet.empty). intros H. - eapply total_model_of_subset. eapply H. apply total_model_of_empty. lsets. - Qed. - Lemma is_update_of_empty cls m : is_update_of cls LevelSet.empty m m. Proof. @@ -3217,16 +3313,6 @@ Section InnerLoop. rewrite LevelSetFact.is_empty_1 //. lsets. Qed. - Lemma is_update_of_case cls W m m' : - is_update_of cls W m m' -> - (LevelSet.Empty W /\ m = m') \/ strictly_updates cls W m m'. - Proof. - rewrite /is_update_of. - destruct LevelSet.is_empty eqn:he. - - intros ->. left => //. now eapply LevelSetFact.is_empty_2 in he. - - intros H; now right. - Qed. - Lemma strictly_updates_W_eq cls W init m W' : LevelSet.Equal W W' -> strictly_updates cls W init m -> @@ -3366,8 +3452,11 @@ Section InnerLoop. eapply (check_model_spec_diff mr) in eqm as [subwwconcl subwconcl hm hext] => //. pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). destruct hm as [cll [hind nvalid inwconcl hl]]. - eapply Nat.lt_le_trans. - 2:{ eapply measure_le; eauto; try eapply mr; tea. now eapply strictly_updates_total_model in upd. } + eapply Nat.lt_le_trans with (measure W cls (model_model mr)). + 2:{ eapply measure_le; eauto; try eapply mr; tea. + - now eapply strictly_updates_total_model in upd. + - eapply valid_model_model_map_outside. + - eapply is_update_of_ext. eapply mr. } eapply measure_lt; tea. { eapply model_map_outside_weaken. eapply hext. have incl := model_incl mr. lsets. } { apply hext. } @@ -3378,37 +3467,16 @@ Section InnerLoop. eapply clauses_conclusions_spec. exists cll; split => //. exact hind. have incl := model_incl mr. eapply total_model_of_subset; tea. - apply mr'. - (* - apply clauses_conclusions_clauses_with_concl. *) - - have mu := model_updates mr. have mu' := model_updates mr'. - eapply check_model_spec in eqm as [Wconcl' [su ->]]. - (* have := is_update_of_trans mu' mu. *) - apply todo. - (* eapply check_model_is_update_of in eqm; tea. - apply (check_model_updates_spec (init_model:=m) eqm) in mu as [mu incl]. - eapply (strictly_updates_weaken _ _ cls) in mu. - have tr := update_trans _ mu mu'. now eapply strictly_updates_total_model in tr. - intros ?; rewrite eqprem. now rewrite union_diff in_clauses_with_concl. *) - - have incl := model_incl mr; have incl':= model_incl mr'. - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. lsets. - eapply mr. - - have mu := model_updates mr. have mu' := model_updates mr'. - eapply check_model_spec in eqm as [Wconc' [su ->]]; tea. - eapply is_update_of_strictly_updates in su. - eapply (is_update_of_trans_eq (cltr := cls)); tea. eapply (is_update_of_trans_eq (cltr := cls)); tea. - 2:reflexivity. 3:lsets. 2:rewrite eqprem. - rewrite union_diff_cls; clsets. intros ?. rewrite Clauses.union_spec in_restrict_clauses. firstorder. + - eapply check_model_is_update_of in eqm as [eqm incl]. 2:eapply mr. + eapply strictly_updates_is_update_of in eqm. 2:eapply mr'. + eapply is_update_of_strictly_updates in eqm. + eapply is_update_of_weaken; tea. + rewrite (ClausesProp.union_sym premconclW) eqprem union_diff. + intros ?. rewrite Clauses.union_spec in_clauses_with_concl; cbn. clear; firstorder. - apply mr'. - - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. 2:apply mr. - eapply model_ext_trans_weaken. 2:apply mr. lsets. - transitivity mconcl. eapply model_extension_weaken. 2:tea. - have incl := model_incl mr; lsets. apply mr'. - lsets. - apply mr. - - apply mr. - - apply mr. - (* now eapply valid_model_total. *) - - have um := model_updates mr. eapply is_update_of_weaken; tea. - intros ?; rewrite eqprem in_restrict_clauses. now intros []. + - eapply is_update_of_weaken. 2:apply mr. rewrite eqprem. apply restrict_clauses_subset. - rewrite check_model_is_model in eqm. have okm := (model_ok mr). have mu := is_model_union okm eqm. @@ -3416,7 +3484,6 @@ Section InnerLoop. rewrite union_diff_eq in mu. rewrite union_restrict_with_concl in mu. now rewrite (clauses_conclusions_eq _ _ clsW). - - apply mr. Qed. End innerloop_partition. @@ -3518,12 +3585,6 @@ Proof. eapply model_of_subset; tea. Qed. -Lemma valid_model_of {V W W' m cls} (m' : valid_model W W' m cls) : - model_of V m -> model_of V (model_model m'). -Proof. - intros mof. eapply model_of_ext; tea. eapply m'. -Qed. - Lemma clauses_with_concl_union cls W W' : Clauses.Equal (clauses_with_concl cls (LevelSet.union W W')) (Clauses.union (clauses_with_concl cls W) (clauses_with_concl cls W')). @@ -3621,19 +3682,6 @@ Proof. Admitted. Definition correct_model (cls : clauses) (m : model) := enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. -Lemma total_model_of_union U V cls : total_model_of U cls -> total_model_of V cls -> total_model_of (LevelSet.union U V) cls. -Proof. - intros hu hv x. - rewrite LevelSet.union_spec; move => [] hin. - now apply hu. now apply hv. -Qed. - -Lemma total_model_of_union_inv U V cls : total_model_of (LevelSet.union U V) cls -> total_model_of U cls /\ total_model_of V cls. -Proof. - rewrite /total_model_of. - setoid_rewrite LevelSet.union_spec. firstorder. -Qed. - Lemma strictly_updates_loop cls V neV m m' : total_model_of V m -> enabled_clauses m cls -> @@ -3713,12 +3761,7 @@ Proof. now eapply is_update_of_strictly_updates. Qed. -Lemma is_update_of_ext cls W m m' : is_update_of cls W m m' -> m ⩽ m'. -Proof. - move/is_update_of_case => []. - - intros [he%LevelSetProp.empty_is_empty_1]. now subst. - - apply strictly_updates_ext. -Qed. +Axiom todo : forall {A}, A. #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) @@ -3757,7 +3800,7 @@ Proof. - do 2 red. eapply LevelSet.equal_spec in eq. set (prf := check_model_ne eqm); clearbody prf. eapply check_model_is_update_of in eqm; tea. rewrite eq in eqm. - apply todo. + apply todo. (* loop *) - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hi := strictly_updates_incl eqm. rewrite union_idem in hi, eqm. @@ -3776,7 +3819,7 @@ Proof. rewrite H in tr. symmetry in e. have [neV hl] := loop_on_proper _ _ ne cls e. apply hl. have vm := model_ok mwc. - apply todo. + apply todo. (* loop *) - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hu := model_updates mwc. eapply strictly_updates_is_update_of in hu; tea. @@ -3786,8 +3829,13 @@ Proof. have tr := is_update_of_trans_eq hu upd. split => //. apply tr. clsets. lsets. - right. - eapply check_model_spec_V in eqm' as eqm''; tea. cbn in eqm''. - 2:{ apply todo. } 2:{ apply mwc. } + eapply check_model_spec_V in eqm' as eqm''. 3:exact clsV. cbn in eqm''. + 2:{ + eapply check_model_is_update_of in eqm as [eqm incl]; tea. + eapply strictly_updates_is_update_of in eqm; tea. 2:apply mwc. + eapply strictly_updates_model_of_gen in eqm; tea. + eapply model_of_subset; tea. lsets. } + 2:{ eapply is_update_of_total_model. apply mwc. } destruct eqm'' as []. eapply check_model_is_update_of in eqm as [eqm incl]; tea. rewrite union_idem in eqm. @@ -3816,45 +3864,28 @@ Proof. - eapply mcls'. - apply mcls'. - apply mcls'. - - exact (model_updates mcls'). - - assumption. - apply mcls'. - - have hupd' := model_updates mcls'. - split. now eapply is_update_of_ext. - apply todo. apply todo. - eapply check_model_is_update_of in eqm as []; tea. rewrite union_idem in H. lsets. - - apply todo. - - apply todo. - - eapply check_model_is_update_of in eqm as []; tea. rewrite union_idem in H. - have h := model_incl mwc. eapply strictly_updates_incl in H. lsets. + - eapply check_model_is_update_of in eqm as [suinit incl]; tea. rewrite union_idem in suinit. + have hupd := model_updates mwc. + eapply (is_update_of_weaken (cls' := cls)) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. + eapply strictly_updates_is_update_of in suinit; tea. rewrite union_idem in suinit. + eapply model_of_strictly_updates; tea. - eapply check_model_is_update_of in eqm as [suinit incl]; tea. rewrite union_idem in suinit. have hupd := model_updates mwc. eapply (is_update_of_weaken (cls' := cls)) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. eapply is_update_of_trans_eq. eapply is_update_of_strictly_updates. tea. tea. clsets. lsets. - assumption. - now apply check_model_None in eqm'. - - eapply check_model_is_update_of in eqm as [suinit incl]; tea. rewrite union_idem in suinit. - apply check_model_None in eqm'. - have hupd := model_updates mwc. - apply todo. - (* eapply (strictly_updates_weaken _ _ cls) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. - have tr := update_trans _ suinit hupd. - split. now apply strictly_updates_ext in tr. - apply todo. apply todo. *) - - apply check_model_spec in eqm as [? [su ->]]. lsets. + - eapply check_model_is_update_of in eqm as [suinit incl]; tea. rewrite union_idem in suinit. lsets. - move: isupd. rewrite /is_update_of. destruct LevelSet.is_empty. * now intros ->. * intros su. eapply model_of_strictly_updates; tea. - - apply todo. - - move/is_update_of_case: isupd => []. - + intros [eu ->]. lsets. - + intros su. eapply strictly_updates_incl in su. lsets. - exact isupd. - assumption. - now eapply check_model_None in eqm. - - apply todo. - lsets. Qed. @@ -4538,10 +4569,10 @@ Lemma infer_correct cls : infer_correctness cls. Proof. intros m. funelim (infer_model cls) => //. - intros [= <-]. clear Heq Heqcall. destruct vm as [model ofV ovW wcls isupd clsconcl ism mext]; cbn in *. + intros [= <-]. clear Heq Heqcall. destruct vm as [model ofV isupd clsconcl ism]; cbn in *. set (V := clauses_levels cls) in *. assert (total_model_of V model). - { intros l inl. apply model_ext_le in mext. red in mext. + { intros l inl. eapply is_update_of_ext in isupd as mext. red in mext. (* eapply clauses_levels_spec in inl as [cl [hcl hin]]. *) unfold init_model in mext. have [kmin [hm incl]] := min_model_mapsto cls l inl. @@ -4549,7 +4580,7 @@ Proof. depelim hmodel. now exists y. } unfold correct_model. have encl : enabled_clauses model cls. - { eapply enabled_clauses_ext. apply mext. + { eapply enabled_clauses_ext. apply is_update_of_ext in isupd. exact isupd. unfold enabled_clauses. eapply Clauses.for_all_spec. tc. intros x hin. unfold enabled_clause. pose proof (@min_premise_spec (init_model cls) (premise x)) as [premmin [prem [premin premeq]]]. @@ -4568,7 +4599,6 @@ Proof. eapply Clauses.for_all_spec in ism; tc. now specialize (ism _ hin). Qed. - (* If a clause checks, then it should be valid in any extension of the model *) Lemma check_entails {V init cls} (m : valid_model V V init cls) (cl : clause) : check m cl = true -> forall m', model_model m ⩽ m' -> valid_clause m' cl. @@ -4600,8 +4630,8 @@ Proof. was found requiring to increase its value. But then it must mean [z -> z + 1]. *) exfalso. - have me := model_extends v. - have me' := model_ext_le _ _ _ me. + have updundef := model_updates v. + have me := is_update_of_ext updundef. assert (not (exists x, is_loop cls x)). admit. apply H3. destruct mineq as [minelt [hprems hmin']]. From d3b2abfee2e5dd96baca730d8f767883bb6c9f85 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 2 Aug 2025 04:21:03 +0200 Subject: [PATCH 014/164] Proven the right invariant for loop checking, finally !!! --- template-rocq/theories/PartialLoopChecking.v | 1015 ++++++++++++++++-- 1 file changed, 938 insertions(+), 77 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index f64e5cc92..3f7218e64 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -145,8 +145,8 @@ Module LoopChecking Definition level (e : LevelExpr.t) : Level.t := fst e. Definition levels (e : LevelExprSet.t) := LevelExprSet.fold (fun le => LevelSet.add (level le)) e LevelSet.empty. + Import LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). -Import LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). Local Existing Instance Level.reflect_eq. @@ -226,10 +226,13 @@ Module NonEmptySetFacts. Qed. Lemma not_Empty_is_empty s : - ~ LevelExprSet.Empty s -> LevelExprSet.is_empty s = false. + ~ LevelExprSet.Empty s <-> LevelExprSet.is_empty s = false. Proof. - intro H. apply not_true_is_false. intro H'. - apply H. now apply LevelExprSetFact.is_empty_2 in H'. + split. + - intro H. apply not_true_is_false. intro H'. + apply H. now apply LevelExprSetFact.is_empty_2 in H'. + - intros H he. red in he. apply negbT in H. unshelve eapply (contraNnot _ H). + 3:exact he. intros ha. now apply LevelExprSetFact.is_empty_1. Qed. Program Definition add (e : LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet @@ -1040,6 +1043,18 @@ Proof. - intros he. apply IHstrictly_updates2. lsets. Qed. +Lemma strictly_updates_non_empty_map {cls W m m'} : + strictly_updates cls W m m' -> ~ LevelMap.Empty m'. +Proof. + induction 1. + - intros he. specialize (he (clause_conclusion cl)). + destruct cl as [prems [concl k]]. + destruct H0 as [? [? [? heq]]]. + setoid_rewrite heq in he. eapply (he (Some (Z.of_nat k + x))); cbn. + rewrite LevelMapFact.F.add_mapsto_iff. firstorder. + - intros he. now apply IHstrictly_updates2. +Qed. + Definition clauses_conclusions (cls : clauses) : LevelSet.t := Clauses.fold (fun cl acc => LevelSet.add (level (concl cl)) acc) cls LevelSet.empty. @@ -1148,12 +1163,19 @@ Definition premise_min (l : nonEmptyLevelExprSet) : nat := let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in fold_left (B:=LevelExpr.t) (fun min atom => Nat.min atom min) tl hd. +Definition premise_max (l : nonEmptyLevelExprSet) : nat := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (B:=LevelExpr.t) (fun min atom => Nat.max atom min) tl hd. + Definition gain (cl : clause) : Z := Z.of_nat (levelexpr_k (concl cl)) - Z.of_nat (premise_min (premise cl)). Definition max_gain (cls : clauses) := Clauses.fold (fun cl acc => Nat.max (Z.to_nat (gain cl)) acc) cls 0%nat. +Definition max_clause_premise (cls : clauses) := + Clauses.fold (fun cl acc => Nat.max (premise_max (premise cl)) acc) cls 0%nat. + Definition model_same_domain (m m' : model) := forall l, LevelMap.In l m <-> LevelMap.In l m'. @@ -1180,15 +1202,14 @@ Proof. now transitivity y. Qed. -Definition value_le : relation (option Z) := opt_le Z.le. +Infix "≤" := (opt_le Z.le) (at level 50). -Infix "≤" := value_le (at level 50). +Definition model_rel R (m m' : model) := + forall l k, LevelMap.MapsTo l k m -> exists k', LevelMap.MapsTo l k' m' /\ R k k'. -Definition model_le (m m' : model) := - forall l k, LevelMap.MapsTo l k m -> - exists k', LevelMap.MapsTo l k' m' /\ k ≤ k'. +Infix "⩽" := (model_rel (opt_le Z.le)) (at level 70). (* \leqslant *) -Infix "⩽" := model_le (at level 70). (* \leqslant *) +Infix "⩹" := (model_rel (opt_le Z.lt)) (at level 70). Definition model_map_outside V (m m' : model) := forall l, ~ LevelSet.In l V -> @@ -1382,10 +1403,10 @@ Proof. move/orP: H1 => [->|] //. move/H. intros ->. now rewrite orb_true_r. move/orP: H1 => [->|] //. move/H0. intros ->. now rewrite orb_true_r. Qed. -#[local] Instance model_le_refl : Reflexive model_le. -Proof. intros x l k map. exists k; split => //. reflexivity. Qed. +#[local] Instance model_le_refl R (HR : Reflexive R) : Reflexive (model_rel R). +Proof. intros x l k map. exists k; split => //. Qed. -#[local] Instance model_le_trans : Transitive model_le. +#[local] Instance model_le_trans R (HR : Transitive R) : Transitive (model_rel R). Proof. intros m m' m'' mm' m'm'' l k map. apply mm' in map as [k' [map ?]]. apply m'm'' in map as [k'' [map ?]]. exists k''. split => //. @@ -1530,6 +1551,20 @@ Proof. apply max_gain_in in incls''. lia. Qed. +Lemma max_clause_premise_spec cl cls : + Clauses.In cl cls -> + (premise_max (premise cl) <= max_clause_premise cls)%nat. +Proof. + intros hin. + unfold max_clause_premise. revert cl hin. + eapply ClausesProp.fold_rec. + - intros s' ise hin. firstorder eauto. + - intros x a s' s'' xs nxs' hadd IH cl' hin'. + eapply hadd in hin' as []. + * subst x. lia. + * specialize (IH _ H). lia. +Qed. + Notation cls_diff cls W := (Clauses.diff (cls ↓ W) (cls ⇂ W)) (only parsing). (* @@ -1776,6 +1811,41 @@ Section MoreNonEmpty. now apply premise_min_spec_aux. Qed. + Lemma premise_max_spec_aux s k : + premise_max s = k -> + (forall x, LevelExprSet.In x s -> (x <= k)%nat) /\ + (exists x, LevelExprSet.In x s /\ k = x). + Proof. + unfold premise_max. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. + now exists t0; split => //. + - destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [t0]) in H as [<-|inih]. + cbn. rewrite fold_left_comm. unfold level_expr_elt in *; lia. unfold level_expr_elt in *; lia. + specialize (ha _ inih). + cbn. rewrite fold_left_comm. lia. lia. + destruct hex as [maxval [inmin ih]]. + cbn. rewrite fold_left_comm. lia. + destruct (Nat.leb_spec a maxval). + exists maxval. cbn in inmin; split; [intuition auto|]. lia. + exists a. split; [intuition|]. rewrite -ih in H. cbn in inmin. + unfold level_expr_elt in *; lia. + Qed. + + Lemma premise_max_spec (s : nonEmptyLevelExprSet) : + (forall x, LevelExprSet.In x s -> x <= premise_max s)%nat /\ + (exists x, LevelExprSet.In x s /\ premise_max s = x). + Proof. + now apply premise_max_spec_aux. + Qed. + Lemma premise_min_subset (s s' : nonEmptyLevelExprSet) : LevelExprSet.Subset s s' -> (premise_min s' <= premise_min s)%nat. @@ -2543,19 +2613,32 @@ Proof. - eapply Clauses_In_elements in H0. apply succ_clause_inj in H. now subst. Qed. -Inductive in_pred_closure cls : clause -> Prop := +Variant in_pred_closure cls : clause -> Prop := | incls cl n : Clauses.In cl cls -> in_pred_closure cls (add_clause n cl) | predcl x k : in_pred_closure cls (singleton (x, k + 1)%nat, (x, k)). Derive Signature for in_pred_closure. Inductive entails (cls : clauses) : clause -> Prop := -| clause_in (prems : nonEmptyLevelExprSet) (cl : LevelExpr.t) : LevelExprSet.In cl prems -> entails cls (prems, cl) +| clause_in (prems : nonEmptyLevelExprSet) (concl : LevelExpr.t) : LevelExprSet.In concl prems -> entails cls (prems, concl) | clause_cut prems' concl' prems concl : in_pred_closure cls (prems', concl') -> entails cls (add concl' prems, concl) -> LevelExprSet.Subset prems' prems -> entails cls (prems, concl). +Definition entails_all cls (prems concls : nonEmptyLevelExprSet) := + LevelExprSet.For_all (fun le => entails cls (prems, le)) concls. + +Notation " cls ⊢ prems → concl " := (entails cls (prems, concl)) (at level 20). +Notation " cls ⊢a prems → concl " := (entails_all cls prems concl) (at level 20). + +Lemma in_pred_closure_equal cls (prems prems' : nonEmptyLevelExprSet) concl : + LevelExprSet.Equal prems prems' -> + in_pred_closure cls (prems, concl) -> in_pred_closure cls (prems', concl). +Proof. + intros eq. apply NonEmptySetFacts.eq_univ' in eq. now subst prems. +Qed. + Lemma entails_equal cls (prems prems' : nonEmptyLevelExprSet) concl : LevelExprSet.Equal prems prems' -> entails cls (prems, concl) -> entails cls (prems', concl). @@ -2568,7 +2651,7 @@ Qed. Lemma entails_plus cls c : entails cls c -> entails (succ_clauses cls) (succ_clause c). Proof. induction 1. - - constructor. apply map_spec. exists cl. split => //. + - constructor. apply map_spec. exists concl0. split => //. - eapply clause_cut with (succ_prems prems') (succ_expr concl'). + depelim H. * have -> : (succ_prems prems', succ_expr concl') = add_clause n (succ_clause cl). @@ -2608,11 +2691,11 @@ Definition is_loop (cls : clauses) (t : nonEmptyLevelExprSet) := let prem := List.map (fun e => (e, n)) preml in is_loop cls prem. *) -Definition levelexprset_of_levels (ls : LevelSet.t) : LevelExprSet.t := - LevelSet.fold (fun x => LevelExprSet.add (x, 0%nat)) ls LevelExprSet.empty. +Definition levelexprset_of_levels (ls : LevelSet.t) n : LevelExprSet.t := + LevelSet.fold (fun x => LevelExprSet.add (x, n)) ls LevelExprSet.empty. -Lemma levelexprset_of_levels_spec (ls : LevelSet.t) l k : - LevelExprSet.In (l, k) (levelexprset_of_levels ls) <-> LevelSet.In l ls /\ k = 0%nat. +Lemma levelexprset_of_levels_spec {ls : LevelSet.t} {l k n} : + LevelExprSet.In (l, k) (levelexprset_of_levels ls n) <-> LevelSet.In l ls /\ k = n. Proof. rewrite /levelexprset_of_levels. eapply LevelSetProp.fold_rec. @@ -2624,11 +2707,11 @@ Proof. Qed. #[program] -Definition of_level_set (ls : LevelSet.t) (hne : ~ LevelSet.Empty ls) : nonEmptyLevelExprSet := - {| t_set := levelexprset_of_levels ls |}. +Definition of_level_set (ls : LevelSet.t) n (hne : ~ LevelSet.Empty ls) : nonEmptyLevelExprSet := + {| t_set := levelexprset_of_levels ls n |}. Next Obligation. apply not_Empty_is_empty => he. apply hne. - intros l nin. specialize (he (l,0%nat)). apply he. + intros l nin. specialize (he (l,n)). apply he. now rewrite levelexprset_of_levels_spec. Qed. @@ -2638,16 +2721,18 @@ Definition entails_clauses cls cl := Definition loop_on_univ cls prems := entails_clauses cls (to_clauses prems (succ_prems prems)). Definition loop_on W (hne : ~ LevelSet.Empty W) cls := - loop_on_univ cls (of_level_set W hne). + cls ⊢a of_level_set W (max_clause_premise cls) hne → of_level_set W (max_clause_premise cls + 1) hne. Lemma loop_on_proper W W' hne' cls : W =_lset W' -> exists hne, loop_on W hne cls -> loop_on W' hne' cls. Proof. intros eq; rewrite /loop_on /loop_on_univ. assert (hne : ~ LevelSet.Empty W). now rewrite eq. exists hne. - assert (of_level_set W hne = of_level_set W' hne'). + assert (of_level_set W (max_clause_premise cls) hne = of_level_set W' (max_clause_premise cls) hne') as ->. + apply eq_univ'. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. + assert (of_level_set W (max_clause_premise cls + 1) hne = of_level_set W' (max_clause_premise cls + 1) hne') as ->. apply eq_univ'. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. - now rewrite -H. + by []. Qed. Lemma loop_on_subset {W hne cls cls'} : Clauses.Subset cls cls' -> loop_on W hne cls -> loop_on W hne cls'. @@ -3682,22 +3767,6 @@ Proof. Admitted. Definition correct_model (cls : clauses) (m : model) := enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. -Lemma strictly_updates_loop cls V neV m m' : - total_model_of V m -> - enabled_clauses m cls -> - strictly_updates cls V m m' -> loop_on V neV cls. -Proof. - intros tot en. - induction 1. - - unfold loop_on, loop_on_univ. (* cl -> cl + 1 *) - destruct cl as [prems [concl k]]. - cbn. destruct H0 as [v [hmin [hnabove heq]]]. - cbn in tot. red in tot. specialize (tot concl). forward tot. eapply LevelSet.singleton_spec. reflexivity. - eapply Clauses.for_all_spec in en. - eapply en in H. - (* eapply valid_clause_model in H. red. *) -Admitted. - Lemma strictly_updates_valid_model {W W' m m' cls} : is_model (cls ↓ W) m -> strictly_updates cls W' m m' -> @@ -3763,6 +3832,827 @@ Qed. Axiom todo : forall {A}, A. +Lemma opt_le_lt_trans {x y z} : opt_le Z.le x y -> opt_le Z.lt y z -> opt_le Z.lt x z. +Proof. + destruct 1; intros H'; depelim H'; constructor. lia. +Qed. + +Lemma strictly_updates_all cls V minit m : strictly_updates cls V minit m -> + (forall l k, LevelSet.In l V -> LevelMap.MapsTo l k minit -> exists k', LevelMap.MapsTo l k' m /\ opt_le Z.lt k k'). +Proof. + induction 1. + - intros l k hin hm. + move: H0; rewrite /strict_update. + destruct cl as [prems [concl gain]]. + move=> [] v [] minp []. cbn in hin. eapply LevelSet.singleton_spec in hin. red in hin; subst l. + move/negbTE; rewrite /level_value_above. + intros hle eq. setoid_rewrite eq. + eexists. setoid_rewrite LevelMapFact.F.add_mapsto_iff. split; [left;split;eauto|] => //. + destruct level_value eqn:hl => //. + * rewrite (level_value_MapsTo hm) in hl. subst k. constructor. lia. + * rewrite (level_value_MapsTo hm) in hl. subst k. constructor. + - intros l k; rewrite LevelSet.union_spec; move=> [] hin hm. + apply IHstrictly_updates1 in hm as [k' [hle hm']]; tea. + eapply strictly_updates_ext in H0. apply H0 in hle as [k'' [hm'' lek'']]. + exists k''. split => //. eapply opt_lt_le_trans; tea. + eapply strictly_updates_ext in H. eapply H in hm as [k' [hm' lek']]. + eapply IHstrictly_updates2 in hm' as [k'' [hm'' lek'']]; tea. + exists k''. split => //. eapply opt_le_lt_trans; tea. +Qed. + +Lemma strictly_updates_zero_model cls V mzero m : + (forall l, LevelSet.In l V -> LevelMap.MapsTo l (Some 0%Z) mzero) -> + strictly_updates cls V mzero m -> + forall l, LevelSet.In l V -> exists k, LevelMap.MapsTo l (Some k) m /\ (0 < k)%Z. +Proof. + intros ho. + move/strictly_updates_all => ha l hin. + eapply ha in hin; revgoals. now apply ho. + destruct hin as [k' [hm hle]]; depelim hle. + now exists y. +Qed. + +Lemma In_to_clauses (prems : nonEmptyLevelExprSet) (concl : nonEmptyLevelExprSet) : + forall cl, + Clauses.In cl (to_clauses prems concl) <-> + exists concle, LevelExprSet.In concle concl /\ cl = (prems, concle). +Proof. Admitted. + +Lemma In_add_prems k (prems : nonEmptyLevelExprSet): + forall le, LevelExprSet.In le (add_prems k prems) <-> + exists le', LevelExprSet.In le' prems /\ le = add_expr k le'. +Proof. Admitted. + +Derive Signature for entails. + +Lemma entails_pred_closure {cls prems concl k} : entails cls (prems, (concl, 1 + k)) -> entails cls (prems, (concl, k)). +Proof. + intros he. + depind he. + - eapply clause_cut. + constructor. + 2:{ intros l hin. rewrite LevelExprSet.singleton_spec in hin. red in hin; subst l. rewrite Nat.add_1_r; exact H. } + constructor. + rewrite LevelExprSet.add_spec. lesets. + - eapply clause_cut; tea. +Qed. + +Lemma entails_pred_closure_n {cls prems concl k n} : + entails cls (prems, (concl, k + n)) -> entails cls (prems, (concl, k)). +Proof. + induction n in k |- *. + - rewrite Nat.add_0_r. tauto. + - intros hen. rewrite Nat.add_succ_r in hen. + eapply IHn. now eapply entails_pred_closure in hen. +Qed. + +Lemma add_clause_0 cl : add_clause 0 cl = cl. +Proof. + destruct cl as [prems [concl k]]; cbn. + f_equal. 2:now rewrite Nat.add_0_r. + unfold add_prems. + eapply eq_univ'. intros [l k']. + rewrite NonEmptySetFacts.map_spec. + unfold add_expr. firstorder. destruct x. noconf H0. + now rewrite Nat.add_0_r. +Qed. + +Lemma incls0 {cls cl} : Clauses.In cl cls -> in_pred_closure cls cl. +Proof. + intros hin. + have hcl := incls _ _ 0 hin. + now rewrite add_clause_0 in hcl. +Qed. + +Lemma entails_in {cls cl} : Clauses.In cl cls -> entails cls cl. +Proof. + intros hin. + destruct cl as [prems concl]. + eapply clause_cut. + - now eapply incls0. + - constructor. eapply LevelExprSet.add_spec. now left. + - reflexivity. +Qed. + + + +Lemma in_pred_closure_shift {cls cl} n : in_pred_closure cls cl -> in_pred_closure cls (add_clause n cl). +Proof. + destruct 1. + - rewrite add_clause_add_clause. now constructor. + - cbn. eapply in_pred_closure_equal with (singleton (x, k + 1 + n)). + { intros le. rewrite In_add_prems; rewrite_strat (topdown LevelExprSet.singleton_spec). + intuition auto. exists (x, k + 1). split => //. + now destruct H as [le' [-> ->]]. } + rewrite -Nat.add_assoc. rewrite -[1 + _](Nat.add_1_r n) Nat.add_assoc. constructor. +Qed. + +Lemma add_clause_singleton n le concl k : add_clause n (singleton le, (concl, k)) = (singleton (add_expr n le), (concl, k + n)). +Proof. + rewrite /add_clause //=. f_equal. + apply eq_univ'. intros le'. rewrite In_add_prems. + rewrite_strat (topdown LevelExprSet.singleton_spec). + unfold LevelExprSet.E.eq. firstorder. subst. reflexivity. +Qed. + +Lemma entails_shift {cls cl} n : entails cls cl -> entails cls (add_clause n cl). +Proof. + induction 1. + - unfold add_clause. constructor. + rewrite In_add_prems. exists concl0. split => //. + - eapply (clause_cut _ (add_prems n prems') (add_expr n concl')). + 2:{ unfold add_clause in *. eapply entails_equal; tea. + intros le. setoid_rewrite In_add_prems. setoid_rewrite LevelExprSet.add_spec. + setoid_rewrite In_add_prems. + unfold LevelExprSet.E.eq. firstorder. subst. now left. } + 2:{ intros x. rewrite !In_add_prems. firstorder. } + eapply (in_pred_closure_shift _ H). +Qed. + +Lemma of_level_set_singleton l k hne : of_level_set (LevelSet.singleton l) k hne = singleton (l, k). +Proof. + apply: eq_univ'. move=> [l' k']. + rewrite /of_level_set //= levelexprset_of_levels_spec !LevelExprSet.singleton_spec LevelSet.singleton_spec /LevelSet.E.eq /LevelExprSet.E.eq. + firstorder subst => //. now noconf H. now noconf H. +Qed. + +Lemma entails_subset cls (prems prems' : nonEmptyLevelExprSet) concl : LevelExprSet.Subset prems prems' -> + entails cls (prems, concl) -> + entails cls (prems', concl). +Proof. + intros hsubt. + intros H; revert prems' hsubt; depind H. + - constructor. eapply hsubt, H. + - intros prems'' hsub. + eapply clause_cut. 2:eapply IHentails. tea. + 2:lesets. intros x; rewrite !LevelExprSet.add_spec. firstorder. +Qed. + +Lemma entails_trans {cls prems concl concl'} : + entails cls (prems, concl) -> + entails cls (singleton concl, concl') -> + entails cls (prems, concl'). +Proof. + intros H; depind H. + - intros he. + depelim he. + * rewrite LevelExprSet.singleton_spec in H0. red in H0; subst concl0. + now constructor. + * eapply (clause_cut _ prems'). tea. + eapply entails_subset; tea. + intros ?; rewrite !LevelExprSet.add_spec LevelExprSet.singleton_spec; firstorder. + red in H2; subst a. now right. intros x. firstorder. apply H1 in H2. + rewrite LevelExprSet.singleton_spec in H2. now red in H2; subst x. + - intros he. + specialize (IHentails concl'0 he). + eapply clause_cut; tea. +Qed. + +Lemma add_comm {le le' e} : add le (add le' e) = add le' (add le e). +Proof. + apply eq_univ'. intros x. + rewrite !LevelExprSet.add_spec. firstorder. +Qed. + +#[program] +Definition univ_union (prems prems' : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + {| t_set := LevelExprSet.union prems prems' |}. +Next Obligation. + destruct prems, prems'; cbn. + destruct (LevelExprSet.is_empty (LevelExprSet.union _ _)) eqn:ise => //. + eapply LevelExprSetFact.is_empty_2 in ise. + eapply not_Empty_is_empty in t_ne0, t_ne1. + destruct t_ne0. lesets. +Qed. + +Lemma univ_union_spec u u' l : + LevelExprSet.In l (univ_union u u') <-> + LevelExprSet.In l u \/ LevelExprSet.In l u'. +Proof. + destruct u, u'; unfold univ_union; cbn. + apply LevelExprSet.union_spec. +Qed. + +Lemma entails_weak {cls prem concl concl'} : + entails cls (prem, concl) -> + entails cls (add concl' prem, concl). +Proof. + intros H. depind H. + - constructor. apply LevelExprSet.add_spec. now right. + - eapply (clause_cut _ _ concl'); tea. + rewrite add_comm. apply IHentails. + intros x; rewrite LevelExprSet.add_spec. firstorder. +Qed. + +Lemma univ_union_add_singleton u le : univ_union u (singleton le) = add le u. +Proof. + apply eq_univ'. + intros x. rewrite univ_union_spec LevelExprSet.singleton_spec add_spec. + intuition auto. +Qed. + +Lemma univ_union_comm {u u'} : univ_union u u' = univ_union u' u. +Proof. + apply eq_univ'. + intros x. rewrite !univ_union_spec. + intuition auto. +Qed. + +Lemma univ_union_add_distr {le u u'} : univ_union (add le u) u' = add le (univ_union u u'). +Proof. + apply eq_univ'. + intros x. rewrite !univ_union_spec !add_spec !univ_union_spec. + intuition auto. +Qed. + +Lemma entails_weak_union {cls prem concl concl'} : + entails cls (prem, concl) -> + entails cls (univ_union concl' prem, concl). +Proof. + intros hyp. + move: concl'. + apply: nonEmptyLevelExprSet_elim. + - intros le. rewrite univ_union_comm univ_union_add_singleton. + now apply entails_weak. + - intros le prems ih. + rewrite univ_union_add_distr. + now eapply entails_weak. +Qed. + +Lemma entails_all_weak {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (add concl' prem) concl. +Proof. + intros hcl x hin. + specialize (hcl _ hin). cbn in hcl. + now apply entails_weak. +Qed. + +Lemma entails_all_weak_union {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (univ_union concl' prem) concl. +Proof. + intros hcl x hin. + specialize (hcl _ hin). cbn in hcl. + now apply entails_weak_union. +Qed. + +Lemma entails_all_weak' {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (add concl' prem) (add concl' concl). +Proof. + intros hcl x hin. + eapply LevelExprSet.add_spec in hin as []. red in H; subst. + - constructor. eapply LevelExprSet.add_spec. now left. + - specialize (hcl _ H). cbn in hcl. + now apply entails_weak. +Qed. + +Lemma entails_cut_all {cls prems' concl' prems concls} : + in_pred_closure cls (prems', concl') -> + cls ⊢a add concl' prems → concls -> + prems' ⊂_leset prems -> + cls ⊢a prems → concls. +Proof. + intros inp he hp x hin. + eapply clause_cut; tea. + now apply he in hin. +Qed. + +Lemma entails_all_subset {cls} {prems prems' prems'' : nonEmptyLevelExprSet} : + prems'' ⊂_leset prems' -> + cls ⊢a prems → prems' -> + cls ⊢a prems → prems''. +Proof. + intros incl ha x hin. + eapply incl in hin. now apply ha in hin. +Qed. + +(* Lemma entails_all_one {cls prems concl concl'} : + entails_all cls prems concl -> + entails cls (univ_union concl prems, concl') -> + entails cls (prems, concl'). +Proof. + intros hall he; depind he. + - eapply LevelExprSet.union_spec in H as []. + 2:now constructor. + now eapply hall in H. + - eapply clause_cut in he; tea. 3:reflexivity. specialize (IHhe _ _ concl0 hall). *) + +Lemma entails_all_add cls prem l prems' : + cls ⊢a prem → add l prems' <-> + cls ⊢ prem → l /\ cls ⊢a prem → prems'. +Proof. + rewrite /entails_all /LevelExprSet.For_all. + setoid_rewrite LevelExprSet.add_spec; rewrite /LevelExprSet.E.eq. + firstorder. now subst. +Qed. + +Lemma entails_add {cls prems cl concl} : + entails cls (prems, cl) -> + entails cls (add cl prems, concl) -> + entails cls (prems, concl). +Proof. + intros H; depind H. + - intros he. + depelim he. + * rewrite LevelExprSet.add_spec in H0. destruct H0 as []. + { red in H0; subst concl0. now constructor. } + { now constructor. } + * have eq : prems = add concl0 prems. + { eapply eq_univ'. intros x; rewrite LevelExprSet.add_spec. firstorder. now red in H2; subst. } + rewrite -eq in H1. + eapply (clause_cut _ prems' _ prems). tea. 2:tea. + now rewrite -eq in he. + - intros he. + eapply clause_cut. tea. eapply IHentails. + rewrite add_comm. now eapply entails_weak. + exact H1. +Qed. + +Lemma entails_cumul_one {cls prems prems' concl} : + entails_all cls prems prems' -> + entails cls (univ_union prems prems', concl) -> + entails cls (prems, concl). +Proof. + revert prems' prems concl. + apply: nonEmptyLevelExprSet_elim. + - intros. specialize (H le). forward H by now apply LevelExprSet.singleton_spec. + cbn in H. + eapply entails_add; tea. + now rewrite -univ_union_add_singleton. + - intros le prems ih prem concl' hadd hadd'. + rewrite univ_union_comm univ_union_add_distr -univ_union_comm -univ_union_add_distr in hadd'. + eapply ih in hadd'. 2:{ apply entails_all_weak. apply entails_all_add in hadd as []. exact H0. } + apply entails_all_add in hadd as []. + eapply entails_add; tea. +Qed. + +Lemma entails_all_cumul {cls prems prems' concl} : + entails_all cls prems prems' -> + entails_all cls (univ_union prems prems') concl -> + entails_all cls prems concl. +Proof. + intros hp hc. + intros x hin. apply hc in hin. + eapply entails_cumul_one; tea. +Qed. + +Lemma entails_all_one {cls prem concl concl'} : + entails_all cls prem concl -> + entails cls (concl, concl') -> + entails cls (prem, concl'). +Proof. + intros ha he. + eapply entails_cumul_one; tea. + now eapply entails_weak_union. +Qed. + +Lemma entails_all_trans {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls concl concl' -> + entails_all cls prem concl'. +Proof. + intros ha he cl hin. + apply he in hin. + eapply entails_all_one; tea. +Qed. + +Lemma entails_incr_shift cls concl k n : entails cls (singleton (concl, k), (concl, k + 1)) -> + entails cls (singleton (concl, k), (concl, k + 1 + n)). +Proof. + induction n in k |- *; auto. + - now rewrite Nat.add_0_r. + - intros en. + have hs := entails_shift 1 en. rewrite add_clause_singleton /= in hs. + apply IHn in hs. + rewrite -Nat.add_assoc Nat.add_1_l in hs. + now eapply entails_trans. +Qed. + +Lemma entails_incr_all cls concl k : entails cls (singleton (concl, k), (concl, k + 1)) -> + forall k', entails cls (singleton (concl, k), (concl, k')). +Proof. + intros en k'. + destruct (Nat.lt_trichotomy k k') as [|[]]; subst; auto. + - eapply (entails_incr_shift _ _ _ (k' - k - 1)) in en. + assert (k + 1 + (k' - k - 1) = k') by lia. now rewrite H0 in en. + - constructor. now rewrite LevelExprSet.singleton_spec. + - have [k0 ->] : (exists kd, k = k' + kd). { exists (k - k'). lia. } + eapply (entails_pred_closure_n (n:=k0)). constructor. now apply LevelExprSet.singleton_spec. +Qed. + +Ltac rw l := rewrite_strat (topdown l). +Ltac rw_in l H := rewrite_strat (topdown l) in H. + +Lemma entails_all_concl_union {cls prems concl concl'} : + cls ⊢a prems → concl -> + cls ⊢a prems → concl' -> + cls ⊢a prems → univ_union concl concl'. +Proof. + intros l r. + rewrite /entails_all. + intros x. rewrite univ_union_spec. intros []. now apply l. now apply r. +Qed. + +Lemma entails_all_union {cls prems concl prems' concl'} : + cls ⊢a prems → concl -> + cls ⊢a prems' → concl' -> + cls ⊢a univ_union prems prems' → univ_union concl concl'. +Proof. + intros l r. + apply entails_all_concl_union. + rewrite univ_union_comm. + now eapply entails_all_weak_union. + now eapply entails_all_weak_union. +Qed. + +Lemma of_level_set_union_spec {ls ls' n hne} hne' hne'' : + of_level_set (ls ∪ ls') n hne = + univ_union (of_level_set ls n hne') (of_level_set ls' n hne''). +Proof. + apply eq_univ'. + intros [l k]. rewrite /of_level_set //= !levelexprset_of_levels_spec LevelExprSet.union_spec. + rewrite !levelexprset_of_levels_spec LevelSet.union_spec. clear. firstorder. +Qed. + +Lemma in_singleton l : LevelSet.In l (LevelSet.singleton l). +Proof. lsets. Qed. + +Definition app {A B} (f : A -> B) (x : A) := f x. + +Notation "f $ x" := (app f x) (at level 20). + +Definition model_domain (m : model) V := + forall x, LevelSet.In x V <-> LevelMap.In x m. + +Definition model_rel_partial R V (m m' : model) := + forall l, + (LevelSet.In l V -> forall k, LevelMap.MapsTo l (Some k) m -> + exists k', LevelMap.MapsTo l (Some k') m' /\ R k k') /\ + (~ LevelSet.In l V -> forall k, LevelMap.MapsTo l k m <-> LevelMap.MapsTo l k m'). + +Lemma total_model_of_sext {R W W' m m'} : + total_model_of W m -> + total_model_of W' m -> + model_rel_partial R W m m' -> total_model_of W' m'. +Proof. + intros mof mof' ext. + intros l hin. + destruct (mof' l hin). specialize (ext l) as [lin lout]. + destruct (inLevelSet W l) as [hin'|hout]. + - specialize (lin hin' _ H). firstorder. + - specialize (lout hout (Some x)). + exists x. now apply lout. +Qed. + +Lemma not_in_union_inv l ls ls' : + ~ LevelSet.In l (LevelSet.union ls ls') -> + ~ LevelSet.In l ls /\ ~ LevelSet.In l ls'. +Proof. + rewrite LevelSet.union_spec. firstorder. +Qed. + +Lemma model_rel_partial_trans {R W W' m m' m''} (HR : Transitive R) : + model_rel_partial R W m m' -> + model_rel_partial R W' m' m'' -> + model_rel_partial R (LevelSet.union W W') m m''. +Proof. + intros mr mr' l. + specialize (mr l) as [inWmr outWmr]. + specialize (mr' l) as [inWmr' outWmr']. + split. + { rewrite LevelSet.union_spec. move=> [] hin k hm. + - specialize (inWmr hin k hm) as [k' [hk' rk']]. + destruct (inLevelSet W' l). + + specialize (inWmr' H k' hk') as [k'' [hk'' rk'']]. + exists k''. split => //. now transitivity k'. + + specialize (outWmr' H (Some k')). exists k'. split => //. now apply outWmr'. + - destruct (inLevelSet W l). + + specialize (inWmr H k hm) as [k'' [hk'' rk'']]. + specialize (inWmr' hin k'' hk'') as [km' [hkm' rkm']]. + exists km'. split => //. now transitivity k''. + + specialize (outWmr H (Some k)) as eq. + apply eq in hm. + specialize (inWmr' hin k hm) as [m''k [hm'' rm'']]. + exists m''k. split => //. } + { move/not_in_union_inv => [] ninW ninW' k. + rewrite (outWmr ninW k). + rewrite (outWmr' ninW' k). reflexivity. } +Qed. + +Lemma strictly_updates_model_lt {cls V} {m m'} : + strictly_updates cls V m m' -> + total_model_of V m -> + model_rel_partial Z.lt V m m'. +Proof. + intros su; induction su. + - intros htot l. split; revgoals. + { intros nin k. destruct cl as [prems [concl conclk]]; cbn in *. + destruct H0 as [minp [hmin [nabove hm']]]. + rewrite hm'. rewrite LevelMapFact.F.add_mapsto_iff. + assert (concl <> l). intros ->. + apply nin, in_singleton. + firstorder. } + intros inv k hin. + red in htot. + specialize (htot (clause_conclusion cl) (in_singleton _)) as [mconcl mt]. + destruct cl as [prems [concl conclk]]; cbn in *. + destruct H0 as [minp [hmin [nabove hm']]]. + eapply LevelSet.singleton_spec in inv; red in inv; subst l. + eapply LevelMapFact.F.MapsTo_fun in hin; tea. noconf hin. + exists (Z.of_nat conclk + minp)%Z. split => //. + rewrite hm'. + rewrite LevelMapFact.F.add_mapsto_iff. left. split => //. + move/negbTE: nabove; move/level_value_not_above_spec. + rewrite (level_value_MapsTo mt). now intros x; depelim x. + - move/total_model_of_union_inv => [] totls totls'. + forward IHsu1 by auto. + forward IHsu2. + { eapply total_model_of_sext. exact totls. assumption. eassumption. } + now eapply model_rel_partial_trans. +Qed. + +Definition clauses_premises_levels (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls LevelSet.empty. + +Lemma clauses_premises_levels_spec_aux l cls acc : + LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls acc) <-> + (exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl))) \/ LevelSet.In l acc. +Proof. + eapply ClausesProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k [hin hl]]. clsets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.union_spec. + split. + * intros [hin'|]. + left. exists x. split => //. + apply hadd. now left. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. + * intros [[k [ins'' ?]]|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma clauses_premises_levels_spec l cls : + LevelSet.In l (clauses_premises_levels cls) <-> + exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl)). +Proof. + unfold clauses_premises_levels. + rewrite clauses_premises_levels_spec_aux. + intuition auto. lsets. +Qed. + + +Definition infers_atom (m : model) (l : Level.t) (k : Z) := Some k ≤ level_value m l. + +Lemma intro_sing {P : Level.t -> Prop} {cl} : + P cl -> (forall l, LevelSet.In l (LevelSet.singleton cl) -> P l). +Proof. + intros H l ins. rewrite LevelSet.singleton_spec in ins. now red in ins; subst. +Qed. + +Lemma elim_sing {P : Level.t -> Prop} {cl} : (forall l, LevelSet.In l (LevelSet.singleton cl) -> P l) -> P cl. +Proof. + intros H. apply H, in_singleton. +Qed. + +#[program] +Definition of_level_map (m : LevelMap.t (option Z)) (hne : ~ LevelMap.Empty m) : nonEmptyLevelExprSet := + {| t_set := LevelMap.fold (fun l k acc => LevelExprSet.add (l, option_default Z.to_nat k 0%nat) acc) m LevelExprSet.empty |}. +Next Obligation. Admitted. + +Lemma of_level_map_spec m hne : + forall l k, LevelExprSet.In (l, k) (of_level_map m hne) <-> LevelMap.MapsTo l (Some (Z.of_nat k)) m. +Proof. Admitted. + +Notation univ := nonEmptyLevelExprSet. + +Definition premise_values (prems : univ) m := + NonEmptySetFacts.map (fun '(l, k) => (l, option_default Z.to_nat (level_value m l) 0%nat)) prems. + +Lemma premise_values_spec prems m : + forall l k, LevelExprSet.In (l, k) (premise_values prems m) <-> + (exists k', LevelExprSet.In (l, k') prems /\ k = option_default Z.to_nat (level_value m l) 0%nat). +Proof. + rewrite /premise_values. + intros l k. rewrite NonEmptySetFacts.map_spec. + firstorder. destruct x. noconf H0. + exists n. split => //. +Qed. + +Definition hyps_map (hyps : univ) m := + (forall (l : Level.t) (k : nat), LevelExprSet.In (l, k) hyps <-> LevelMap.MapsTo l (Some (Z.of_nat k)) m). + +Lemma model_hyps_entails cls m hyps (prems : univ) concl : + Clauses.In (prems, concl) cls -> + (forall l : Level.t, LevelSet.In l (clauses_premises_levels cls) -> Some (Z.of_nat (max_clause_premise cls)) ≤ level_value m l) -> + hyps_map hyps m -> + cls ⊢a hyps → premise_values prems m. +Proof. + intros incls hmx hm. + intros [l k] hin. + rewrite premise_values_spec in hin. destruct hin as [k' [inp ->]]. + red in hm. + constructor. rewrite hm. + specialize (hmx l). + forward hmx. + { rewrite clauses_premises_levels_spec. exists (prems, concl); split => //. cbn. + eapply levelexprset_levels_spec. now exists k'. } + depelim hmx. rewrite H0 //=. + rewrite Z2Nat.id. lia. now eapply level_value_MapsTo'. +Qed. + +Lemma entails_succ cls (u v : univ) : + (forall l k, LevelExprSet.In (l, k) v -> exists k', LevelExprSet.In (l, k') u /\ k <= k') -> + cls ⊢a u → v. +Proof. + intros hk [l k] hin. + specialize (hk _ _ hin) as [k' [hin' le]]. + assert (exists n, k' = k + n) as [n ->] by (exists (k' - k); lia). + eapply (entails_pred_closure_n (n := n)). + now constructor. +Qed. + + +Lemma hyps_entails (hyps : univ) m cls : + forall (hmz : forall l : Level.t, LevelSet.In l (clauses_premises_levels cls) -> Some (Z.of_nat (max_clause_premise cls)) ≤ level_value m l), + (forall (l : Level.t) (k : nat), LevelExprSet.In (l, k) hyps <-> LevelMap.MapsTo l (Some (Z.of_nat k)) m) -> + forall prems conclk, Clauses.In (prems, conclk) cls -> + forall v, min_premise m prems = Some (Z.of_nat v) -> + cls ⊢a hyps → add_prems v prems. +Proof. + intros hmz H prems conclk H0 v H1. + have [minsleq mineq] := min_premise_spec m prems. + destruct mineq as [[minprem minpremk] [inprems eqminp]]. cbn. + move: eqminp. rewrite /min_atom_value. + destruct level_value eqn:hl. intros hminp. + 2:{ now rewrite H1. } + rewrite H1 in hminp. noconf hminp. + have entails_prems : cls ⊢a hyps → premise_values prems m. + by eapply model_hyps_entails with conclk; auto. + eapply entails_all_trans; tea. + eapply entails_succ. + intros l k. rewrite In_add_prems. + intros [[prem premk] [inprem [= -> ->]]]. + rw premise_values_spec. eexists. + split. exists premk. split => //. + have hmz' := hmz prem. forward hmz'. + { rewrite clauses_premises_levels_spec. eexists; split => //. exact H0. cbn. + eapply levelexprset_levels_spec. now eexists. } + depelim hmz'. rewrite H4 //=. + assert (v = Z.to_nat z - minpremk). lia. subst v. + specialize (minsleq _ inprem). cbn in minsleq. rewrite H4 in minsleq. + rewrite H1 in minsleq. depelim minsleq. + have hmzz := hmz minprem. forward hmzz. + { rewrite clauses_premises_levels_spec. eexists. split. eassumption. cbn. + eapply levelexprset_levels_spec. now eexists. } + rewrite hl in hmzz. depelim hmzz. + lia. +Qed. + +Definition above_max_premise_model cls m := + forall l, LevelSet.In l (clauses_premises_levels cls) -> infers_atom m l (Z.of_nat (max_clause_premise cls)). + +Definition max_premise_model cls m := + (forall l, LevelSet.In l (clauses_premises_levels cls) -> + LevelMap.MapsTo l (Some (Z.of_nat (max_clause_premise cls))) m) /\ + (forall l k, LevelMap.MapsTo l (Some k) m -> LevelSet.In l (clauses_premises_levels cls) /\ k = Z.of_nat (max_clause_premise cls)). + +Lemma max_premise_model_above cls m : + max_premise_model cls m -> + above_max_premise_model cls m. +Proof. + move=> mp l hl; move: (proj1 mp l hl); rewrite /infers_atom. + move/level_value_MapsTo => ->. reflexivity. +Qed. + +Lemma strictly_updates_entails {cls V mzero m} (hne : ~ LevelMap.Empty mzero) (hne' : ~ LevelMap.Empty m) : + above_max_premise_model cls mzero -> + strictly_updates cls V mzero m -> + entails_all cls (of_level_map mzero hne) (of_level_map m hne'). +Proof. + intros hmz su; induction su. + - destruct cl as [prems [concl k]]. + destruct H0 as [minp [hmin [nabove eqm']]]. + have [minsleq mineq] := min_premise_spec m prems. + destruct mineq as [minprem [inprems eqminp]]. cbn. + move: eqminp. rewrite /min_atom_value. + move/negbTE/level_value_not_above_spec: nabove => nabove. + destruct minprem as [minprem mink]. + destruct (level_value m minprem) eqn:hminprem; rewrite hmin //; intros [= ->]. + intros [l k'] hin. + eapply of_level_map_spec in hin. rewrite eqm' in hin. + rewrite LevelMapFact.F.add_mapsto_iff in hin. + destruct hin as [[eq heq]|[neq hm]]. red in eq. subst l. + noconf heq. + have minp_pos : (z - Z.of_nat mink >= 0)%Z. + { forward (hmz minprem). eapply clauses_premises_levels_spec. eexists; split; eauto. cbn. + eapply levelexprset_levels_spec. now eexists. red in hmz. + rewrite hminprem in hmz. depelim hmz. + have := max_clause_premise_spec (prems, (concl, k)) cls H. + cbn. + have [] := premise_max_spec prems => /(_ _ inprems) //= lemax _. + lia. } + assert (k + (Z.to_nat z - mink) = k'). lia. subst k'. clear H0. + have hypss := of_level_map_spec m hne. + set (hyps := of_level_map m hne) in *. clearbody hyps. + have entailscl : entails cls (prems, (concl, k)) by exact: entails_in H. + move/(entails_shift (Z.to_nat z - mink)): entailscl. cbn. move => entailscl. + eapply (entails_all_one (concl := add_prems (Z.to_nat z - mink) prems)) => //. + eapply level_value_MapsTo' in hminprem. + assert (exists z', z = Z.of_nat z'). exists (Z.to_nat z). lia. + destruct H0 as [z2 ->]. rename z2 into z. + rewrite -hypss in hminprem. rewrite -> Nat2Z.id in *. + eapply hyps_entails; tea. rewrite hmin. lia_f_equal. + constructor. now rewrite of_level_map_spec. + - have hnemid : ~ LevelMap.Empty m'. by exact: strictly_updates_non_empty_map su1. + specialize (IHsu1 hne hnemid). + specialize (IHsu2 hnemid hne'). + forward IHsu1. auto. + forward IHsu2. + { intros l hin. red. move: (hmz _ hin). unfold infers_atom. + intros leq; depelim leq. eapply strictly_updates_ext in su1. + eapply model_le_values in su1. etransitivity; [|eexact su1]. now apply hmz. } + eapply entails_all_trans; tea. +Qed. + +Lemma not_empty_exists V : ~ LevelSet.Empty V -> exists l, LevelSet.In l V. +Proof. + intros ne. + destruct (LevelSet.choose V) eqn:ch. exists e. + now eapply LevelSet.choose_spec1 in ch. + now apply LevelSet.choose_spec2 in ch. +Qed. + +Lemma of_level_map_of_level_set cls V m hne hne' : + max_premise_model cls m -> + V =_lset clauses_premises_levels cls -> + of_level_map m hne = of_level_set V (max_clause_premise cls) hne'. +Proof. + move=> mp hv. apply: eq_univ' => [[l k]]. + rewrite of_level_map_spec levelexprset_of_levels_spec. + split. red in mp. + move/(proj2 mp l) => [hin eq]. split. 2:lia. lsets. + move=> [] inl ->. rewrite hv in inl. + now apply mp. +Qed. + +(* The criterion for loops: + when a set of updates manages to strictly update all the levels it started with, + then we can deduce a looping constraint `x, ..., z -> x + 1, ... z + 1`. + + TODO: refine the premises, this should work also when some clauses cannot be considered, + so that it can be used for checking and not only inferrence. + + *) + +Lemma strictly_updates_entails_loop cls V (hne : ~ LevelSet.Empty V) mzero m : + max_premise_model cls mzero -> + V =_lset clauses_premises_levels cls -> + total_model_of V mzero -> + strictly_updates cls V mzero m -> + entails_all cls (of_level_set V (max_clause_premise cls) hne) + (of_level_set V (max_clause_premise cls + 1) hne). +Proof. + intros maxp vincl tot su. + have mp := strictly_updates_model_lt su tot. + have nemzero : ~ LevelMap.Empty mzero. + { have := not_empty_exists V hne => [[l]]. + now move/tot => [v hm] /(_ _ _ hm). } + have nem := strictly_updates_non_empty_map su. + eapply (strictly_updates_entails nemzero nem) in su; tea. + unshelve erewrite of_level_map_of_level_set in su; tea. + move/entails_all_trans: su; apply. + 2:by eapply max_premise_model_above. + apply: entails_succ => l k. + rewrite levelexprset_of_levels_spec => [[hin ->]]. + rw of_level_map_spec. + move: (mp l) => [] /(_ hin). + move: (tot _ hin) => [x hm]. + move/(_ _ hm) => [k' [hm' lt]]. + intros _. + exists (Z.to_nat k'). + unfold max_premise_model in maxp. + move: (proj1 maxp l) => hl. + forward hl. apply vincl, hin. + eapply LevelMapFact.F.MapsTo_fun in hm; tea. noconf hm. + rewrite Z2Nat.id. lia. + split => //. lia. +Qed. + +Lemma add_prems_add {n lk prems} : add_prems n (add lk prems) = add (add_expr n lk) (add_prems n prems). +Proof. + apply eq_univ'. intros x. + rewrite In_add_prems LevelExprSet.add_spec In_add_prems /LevelExprSet.E.eq; rw LevelExprSet.add_spec. + firstorder. subst. red in H; subst x0. now left. +Qed. + #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) (prf : [/\ clauses_conclusions cls ⊂_lset V, model_of V minit & is_update_of cls U minit m]) : result V U cls minit @@ -3800,7 +4690,12 @@ Proof. - do 2 red. eapply LevelSet.equal_spec in eq. set (prf := check_model_ne eqm); clearbody prf. eapply check_model_is_update_of in eqm; tea. rewrite eq in eqm. - apply todo. (* loop *) + destruct eqm as [eqm incl]. rewrite union_idem in eqm. + eapply strictly_updates_strenghten in eqm. + eapply strictly_updates_entails_loop with minit m'. + + apply todo. + + rewrite eq. intros x. eapply strictly_updates_incl in eqm. rewrite clauses_premises_levels_spec. + - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hi := strictly_updates_incl eqm. rewrite union_idem in hi, eqm. @@ -4404,40 +5299,6 @@ Definition premises_model_map (m : LevelMap.t (option Z)) cls : LevelMap.t (opti LevelExprSet.fold (fun '(l, k) acc => add_max l (Z.of_nat k) acc) cl acc) cls m. -Definition clauses_premises_levels (cls : clauses) : LevelSet.t := - Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls LevelSet.empty. - -Lemma clauses_premises_levels_spec_aux l cls acc : - LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls acc) <-> - (exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl))) \/ LevelSet.In l acc. -Proof. - eapply ClausesProp.fold_rec. - - intros. - intuition auto. destruct H1 as [k [hin hl]]. clsets. - - intros x a s' s'' hin nin hadd ih. - rewrite LevelSet.union_spec. - split. - * intros [hin'|]. - left. exists x. split => //. - apply hadd. now left. - apply ih in H. - intuition auto. - left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. - * intros [[k [ins'' ?]]|inacc]. - eapply hadd in ins''. destruct ins''; subst. - + now left. - + right. apply ih. now left; exists k. - + right. intuition auto. -Qed. - -Lemma clauses_premises_levels_spec l cls : - LevelSet.In l (clauses_premises_levels cls) <-> - exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl)). -Proof. - unfold clauses_premises_levels. - rewrite clauses_premises_levels_spec_aux. - intuition auto. lsets. -Qed. Lemma premises_model_map_levels m cls k : LevelMap.In k (premises_model_map m cls) <-> From 40db520e1dac7fe202852bb58722796f6fad08c1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 25 Aug 2025 18:09:59 +0200 Subject: [PATCH 015/164] Parameterizing inner_loop by original clauses --- template-rocq/theories/PartialLoopChecking.v | 565 ++++++++++++++----- 1 file changed, 418 insertions(+), 147 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 3f7218e64..2aae7ed1b 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -613,6 +613,13 @@ Proof. intuition auto. lsets. Qed. +Instance clauses_levels_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_levels. +Proof. + intros cl cl' eq x. + rewrite !clauses_levels_spec. + now setoid_rewrite eq. +Qed. + Lemma clause_levels_spec l cl : LevelSet.In l (clause_levels cl) <-> LevelSet.In l (levels (premise cl)) \/ l = levelexpr_level (concl cl). @@ -1977,7 +1984,7 @@ Proof. Qed. Lemma clauses_levels_restrict_clauses cls W : - LevelSet.Subset (clauses_levels (cls ⇂ W)) W. + clauses_levels (cls ⇂ W) ⊂_lset W. Proof. intros x [cl []] % clauses_levels_spec. eapply in_restrict_clauses in H as [hconc hprem incl]. @@ -3049,12 +3056,197 @@ Proof. - eapply strictly_updates_total_model_gen in su; tea. Qed. -Section InnerLoop. - Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) - (loop : forall (V' U' : LevelSet.t) (cls : clauses) (minit m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V', model_of V' minit & is_update_of cls U' minit m]), - lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls minit). +Lemma clauses_levels_conclusions cls V : clauses_levels cls ⊂_lset V -> + clauses_conclusions cls ⊂_lset V. +Proof. + intros hin x; rewrite clauses_conclusions_spec; move => [cl [hin' eq]]; apply hin. + rewrite clauses_levels_spec. exists cl. split => //. subst x. + rewrite clause_levels_spec. now right. +Qed. +Definition clauses_premises_levels (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls LevelSet.empty. + +Lemma clauses_premises_levels_spec_aux l cls acc : + LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls acc) <-> + (exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl))) \/ LevelSet.In l acc. +Proof. + eapply ClausesProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k [hin hl]]. clsets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.union_spec. + split. + * intros [hin'|]. + left. exists x. split => //. + apply hadd. now left. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. + * intros [[k [ins'' ?]]|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma clauses_premises_levels_spec l cls : + LevelSet.In l (clauses_premises_levels cls) <-> + exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl)). +Proof. + unfold clauses_premises_levels. + rewrite clauses_premises_levels_spec_aux. + intuition auto. lsets. +Qed. + +Lemma clauses_levels_premises cls V : clauses_levels cls ⊂_lset V -> + clauses_premises_levels cls ⊂_lset V. +Proof. + intros hin x; rewrite clauses_premises_levels_spec; move => [cl [hin' eq]]; apply hin. + rewrite clauses_levels_spec. exists cl. split => //. + rewrite clause_levels_spec. now left. +Qed. + +Lemma clauses_premises_levels_incl cls : clauses_premises_levels cls ⊂_lset clauses_levels cls. +Proof. + intros x; rewrite clauses_premises_levels_spec clauses_levels_spec; move => [cl [hin' eq]]. + exists cl; split => //. + rewrite clause_levels_spec. now left. +Qed. + +Lemma clauses_premises_levels_mon {cls cls'} : cls ⊂_clset cls' -> + clauses_premises_levels cls ⊂_lset clauses_premises_levels cls'. +Proof. + intros hin x; rewrite !clauses_premises_levels_spec; move => [cl [hin' eq]]. + exists cl; split => //. now apply hin. +Qed. + +Definition monotone_selector sel := + forall cls' cls, cls' ⊂_clset cls -> sel cls' ⊂_lset sel cls. + +Lemma clauses_levels_mon : monotone_selector clauses_levels. +Proof. + intros cls' cls hin x; rewrite !clauses_levels_spec; move => [cl [hin' eq]]. + exists cl; split => //. now apply hin. +Qed. + +Definition infers_atom (m : model) (l : Level.t) (k : Z) := Some k ≤ level_value m l. + +Definition max_premise_model cls sel m := + (forall l, LevelSet.In l (sel cls) -> + LevelMap.MapsTo l (Some (Z.of_nat (max_clause_premise cls))) m) /\ + (forall l k, LevelMap.MapsTo l (Some k) m -> LevelSet.In l (sel cls) /\ k = Z.of_nat (max_clause_premise cls)). + + +Definition max_premise_map cls : model := + let max := max_clause_premise cls in + let ls := clauses_levels cls in + LevelSet.fold (fun l acc => LevelMap.add l (Some (Z.of_nat max)) acc) ls (LevelMap.empty _). + +Definition above_max_premise_model cls m := + (exists V, strictly_updates cls V (max_premise_map cls) m) \/ m = max_premise_map cls. +Lemma max_premise_model_exists cls : max_premise_model cls clauses_levels (max_premise_map cls). +Proof. + rewrite /max_premise_map; split. + - intros l. + eapply LevelSetProp.fold_rec. + { intros s he hin. now apply he in hin. } + intros. + destruct (Level.eq_dec l x). subst. + * eapply LevelMapFact.F.add_mapsto_iff. left; split => //. + * eapply LevelMapFact.F.add_mapsto_iff. right. split => //. now unfold Level.eq. apply H2. + specialize (H1 l). apply H1 in H3. destruct H3 => //. congruence. + - intros l k. + eapply LevelSetProp.fold_rec. + { intros s' he hm. now eapply LevelMapFact.F.empty_mapsto_iff in hm. } + intros. + eapply LevelMapFact.F.add_mapsto_iff in H3 as []. + * destruct H3. noconf H4. split => //. apply H1. now left. + * destruct H3. firstorder. +Qed. + +Lemma infer_atom_downward {m l k k'} : + infers_atom m l k -> + (k' <= k)%Z -> + infers_atom m l k'. +Proof. + rewrite /infers_atom. + intros infa le. + transitivity (Some k) => //. now constructor. +Qed. + +Lemma infers_atom_le {m m' l k} : + infers_atom m l k -> + m ⩽ m' -> + infers_atom m' l k. +Proof. + rewrite /infers_atom. + intros infa le. + depelim infa. eapply level_value_MapsTo' in H0. eapply le in H0 as [k' [hm hle]]. + depelim hle. + rewrite (level_value_MapsTo hm). constructor; lia. +Qed. + +Lemma infers_atom_mapsto m l k : infers_atom m l k <-> + exists k', LevelMap.MapsTo l (Some k') m /\ k <= k'. +Proof. + rewrite /infers_atom; split. + - intros hle; depelim hle. + eapply level_value_MapsTo' in H0. exists y. split => //. + - intros [k' [hm hle]]. + eapply level_value_MapsTo in hm. rewrite hm. now constructor. +Qed. + +Lemma above_max_premise_model_infers {cls m} : + above_max_premise_model cls m -> + (forall l, LevelSet.In l (clauses_levels cls) -> infers_atom m l (Z.of_nat (max_clause_premise cls))). +Proof. + intros ha l hl. + have hm := max_premise_model_exists cls. + destruct ha as [[V su]|eq]. + * eapply strictly_updates_ext in su. + eapply infers_atom_le; tea. + eapply infers_atom_mapsto. + destruct hm. exists (Z.of_nat (max_clause_premise cls)). split => //. 2:lia. + now eapply H. + * subst m. eapply infers_atom_mapsto. destruct hm. + specialize (H l hl). eexists; split. exact H. lia. +Qed. + +(* Lemma max_premise_model_above cls sel sel' m : + (sel' cls ⊂_lset sel cls) -> + max_premise_model cls sel m -> + above_max_premise_model cls m. +Proof. + move=> incl mp l hl; move: (proj1 mp l (incl _ hl)); rewrite /infers_atom. + move/level_value_MapsTo => ->. reflexivity. +Qed. *) + + +Lemma clauses_with_concl_union cls W W' : + Clauses.Equal (clauses_with_concl cls (LevelSet.union W W')) + (Clauses.union (clauses_with_concl cls W) (clauses_with_concl cls W')). +Proof. + intros x. rewrite Clauses.union_spec !in_clauses_with_concl LevelSet.union_spec. + firstorder. +Qed. + +Lemma strictly_updates_strenghten {cls W m m'} : + strictly_updates cls W m m' -> + strictly_updates (cls ↓ W) W m m'. +Proof. + induction 1. + - constructor. rewrite in_clauses_with_concl. split => //. + eapply LevelSet.singleton_spec; reflexivity. exact H0. + - rewrite clauses_with_concl_union. econstructor 2. + eapply strictly_updates_weaken; tea. intros x; clsets. + eapply strictly_updates_weaken; tea. intros x; clsets. +Qed. + +Lemma clauses_with_concl_subset cls W : (cls ↓ W) ⊂_clset cls. +Proof. now intros ?; rewrite in_clauses_with_concl. Qed. + +Section InnerLoop. Definition sum_W W (f : LevelSet.elt -> nat) : nat := LevelSet.fold (fun w acc => acc + f w)%nat W 0%nat. @@ -3072,7 +3264,6 @@ Section InnerLoop. let clsdiff := cls_diff cls W in measure W cls m = 0%nat -> is_model clsdiff m. Proof using. - clear loop V U. unfold measure, sum_W, measure_w, is_model. set (clsdiff := Clauses.diff _ _). intros hv hm. @@ -3483,10 +3674,74 @@ Section InnerLoop. eapply is_update_of_trans; tea. Qed. + Lemma union_idem cls : Clauses.Equal (Clauses.union cls cls) cls. + Proof. intros ?; rewrite Clauses.union_spec. firstorder. Qed. + + Lemma above_max_premise_model_trans {cls V' m m'} : + above_max_premise_model cls m -> + strictly_updates cls V' m m' -> + above_max_premise_model cls m'. + Proof. + move=> [[V'' ab]|eq] su. + * have tr := strictly_updates_trans ab su. + rewrite union_idem in tr. + now left; eexists. + * left; exists V'. now subst. + Qed. + + Lemma max_clause_premise_spec2 cls : + (exists cl, Clauses.In cl cls /\ max_clause_premise cls = premise_max (premise cl)) \/ + (Clauses.Empty cls /\ max_clause_premise cls = 0%nat). + Proof. + unfold max_clause_premise. + eapply ClausesProp.fold_rec. + - firstorder. + - intros x a s' s'' incls ins' hadd [ih|ih]. + left. + * destruct ih as [cl [incl ->]]. + destruct (Nat.max_spec (premise_max (premise x)) (premise_max (premise cl))) as [[hlt ->]|[hge ->]]. + { exists cl. split => //. apply hadd. now right. } + { exists x. firstorder. } + * left. exists x. split; firstorder. subst. + lia. + Qed. + + Lemma max_clause_premise_mon {cls cls'} : + cls ⊂_clset cls' -> + (max_clause_premise cls <= max_clause_premise cls')%nat. + Proof using Type. + intros hincl. + have [[cl [hin hs]]|[he hs]] := max_clause_premise_spec2 cls; + have [[cl' [hin' hs']]|[he' hs']] := max_clause_premise_spec2 cls'. + - apply hincl in hin. + have hm := max_clause_premise_spec _ _ hin. + have hm' := max_clause_premise_spec _ _ hin'. lia. + - rewrite hs'. apply hincl in hin. now eapply he' in hin. + - rewrite hs. lia. + - lia. + Qed. + + (*Lemma above_max_premise_model_strengthen {cls cls' m} : + cls ⊂_clset cls' -> + above_max_premise_model cls m -> + above_max_premise_model cls' m. + Proof. + intros hincl [V' su]. exists V'. + eapply strictly_updates_weaken; tea. red in ha. + move/(hmon _ _ hincl)/(ha l) => ha'. + eapply infer_atom_downward; tea. + apply max_clause_premise_mon in hincl. lia. + Qed. *) + + Context (V : LevelSet.t) (ocls : clauses) (U : LevelSet.t) (init_model : model) (maxp : above_max_premise_model ocls init_model) + (loop : forall (V' U' : LevelSet.t) (cls' : clauses) (minit m : model) + (prf : [/\ clauses_levels cls' ⊂_lset V', total_model_of V' minit, cls' ⊂_clset ocls, above_max_premise_model ocls minit & is_update_of cls' U' minit m]), + lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls' minit). + Section innerloop_partition. Context (W : LevelSet.t) (cls : clauses). Context (premconclW conclW : clauses). - Context (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W, + Context (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, cls ⊂_clset ocls, clauses_conclusions cls ⊂_lset W, Clauses.Equal premconclW (cls ⇂ W) & Clauses.Equal conclW (Clauses.diff (cls ↓ W) (cls ⇂ W))]). #[tactic="idtac"] @@ -3515,14 +3770,18 @@ Section InnerLoop. all:cbn [model_model]; clear loop inner_loop_partition. all:try apply LevelSet.subset_spec in hsub. all:auto. - all:try destruct prf as [WV neW UW clsW eqprem eqconcl]. + all:try destruct prf as [WV neW UW oclsi clsW eqprem eqconcl]. all:try solve [intuition auto]. all:try rewrite eqconcl in eqm. - - split => //. rewrite eqprem. apply clauses_conclusions_restrict_clauses. - apply total_model_of_sub, (strictly_updates_total_model upd). - eapply is_update_of_empty. + - split => //. + * rewrite eqprem. apply clauses_levels_restrict_clauses. + * eapply (strictly_updates_total_model upd). + * rewrite eqprem. transitivity cls => //. apply restrict_clauses_subset. + * eapply strictly_updates_weaken in upd; tea. eapply above_max_premise_model_trans in maxp; tea. + * eapply is_update_of_empty. - left. now eapply strict_subset_cardinal. - - destruct prf. transitivity (cls ⇂ W) => //. now rewrite H3. eapply restrict_clauses_subset. + - rewrite eqprem. eapply restrict_clauses_subset. + (* - destruct prf. transitivity (cls ⇂ W) => //. now rewrite H3. eapply restrict_clauses_subset. *) - have mu := model_updates mr. eapply strictly_updates_is_update_of in upd; tea. apply check_model_spec in eqm as [Wconcl' [sumr ->]]. @@ -3577,12 +3836,12 @@ Section InnerLoop. *) #[tactic="idtac"] Equations? inner_loop (W : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & + (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, cls ⊂_clset ocls, clauses_conclusions cls ⊂_lset W & strictly_updates cls W init_model m]) : result W LevelSet.empty cls m := inner_loop W cls m prf with inspect (Clauses.partition (premise_restricted_to W) cls) := | exist (premconclW, conclW) eqp => inner_loop_partition W cls premconclW conclW _ m _. Proof. - - destruct prf as [subWV neW UW clsW mW]. + - destruct prf as [subWV neW UW oclsi clsW mW]. eapply (clauses_partition_spec clsW) in eqp as [eqprem eqconcl]. split => //. now rewrite -(clauses_conclusions_eq _ _ clsW). - apply prf. @@ -3670,29 +3929,6 @@ Proof. eapply model_of_subset; tea. Qed. -Lemma clauses_with_concl_union cls W W' : - Clauses.Equal (clauses_with_concl cls (LevelSet.union W W')) - (Clauses.union (clauses_with_concl cls W) (clauses_with_concl cls W')). -Proof. - intros x. rewrite Clauses.union_spec !in_clauses_with_concl LevelSet.union_spec. - firstorder. -Qed. - -Lemma strictly_updates_strenghten {cls W m m'} : - strictly_updates cls W m m' -> - strictly_updates (cls ↓ W) W m m'. -Proof. - induction 1. - - constructor. rewrite in_clauses_with_concl. split => //. - eapply LevelSet.singleton_spec; reflexivity. exact H0. - - rewrite clauses_with_concl_union. econstructor 2. - eapply strictly_updates_weaken; tea. intros x; clsets. - eapply strictly_updates_weaken; tea. intros x; clsets. -Qed. - -Lemma clauses_with_concl_subset cls W : (cls ↓ W) ⊂_clset cls. -Proof. now intros ?; rewrite in_clauses_with_concl. Qed. - Section Semantics. Section Interpretation. @@ -3820,9 +4056,6 @@ Proof. intros he. apply su. lsets. Qed. -Lemma union_idem cls : Clauses.Equal (Clauses.union cls cls) cls. -Proof. intros ?; rewrite Clauses.union_spec. firstorder. Qed. - Lemma check_model_update_of {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> exists W', is_update_of cls W' m m' /\ W = LevelSet.union U W'. Proof. @@ -4373,44 +4606,6 @@ Proof. now eapply model_rel_partial_trans. Qed. -Definition clauses_premises_levels (cls : clauses) : LevelSet.t := - Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls LevelSet.empty. - -Lemma clauses_premises_levels_spec_aux l cls acc : - LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls acc) <-> - (exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl))) \/ LevelSet.In l acc. -Proof. - eapply ClausesProp.fold_rec. - - intros. - intuition auto. destruct H1 as [k [hin hl]]. clsets. - - intros x a s' s'' hin nin hadd ih. - rewrite LevelSet.union_spec. - split. - * intros [hin'|]. - left. exists x. split => //. - apply hadd. now left. - apply ih in H. - intuition auto. - left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. - * intros [[k [ins'' ?]]|inacc]. - eapply hadd in ins''. destruct ins''; subst. - + now left. - + right. apply ih. now left; exists k. - + right. intuition auto. -Qed. - -Lemma clauses_premises_levels_spec l cls : - LevelSet.In l (clauses_premises_levels cls) <-> - exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl)). -Proof. - unfold clauses_premises_levels. - rewrite clauses_premises_levels_spec_aux. - intuition auto. lsets. -Qed. - - -Definition infers_atom (m : model) (l : Level.t) (k : Z) := Some k ≤ level_value m l. - Lemma intro_sing {P : Level.t -> Prop} {cl} : P cl -> (forall l, LevelSet.In l (LevelSet.singleton cl) -> P l). Proof. @@ -4516,22 +4711,6 @@ Proof. lia. Qed. -Definition above_max_premise_model cls m := - forall l, LevelSet.In l (clauses_premises_levels cls) -> infers_atom m l (Z.of_nat (max_clause_premise cls)). - -Definition max_premise_model cls m := - (forall l, LevelSet.In l (clauses_premises_levels cls) -> - LevelMap.MapsTo l (Some (Z.of_nat (max_clause_premise cls))) m) /\ - (forall l k, LevelMap.MapsTo l (Some k) m -> LevelSet.In l (clauses_premises_levels cls) /\ k = Z.of_nat (max_clause_premise cls)). - -Lemma max_premise_model_above cls m : - max_premise_model cls m -> - above_max_premise_model cls m. -Proof. - move=> mp l hl; move: (proj1 mp l hl); rewrite /infers_atom. - move/level_value_MapsTo => ->. reflexivity. -Qed. - Lemma strictly_updates_entails {cls V mzero m} (hne : ~ LevelMap.Empty mzero) (hne' : ~ LevelMap.Empty m) : above_max_premise_model cls mzero -> strictly_updates cls V mzero m -> @@ -4552,9 +4731,10 @@ Proof. destruct hin as [[eq heq]|[neq hm]]. red in eq. subst l. noconf heq. have minp_pos : (z - Z.of_nat mink >= 0)%Z. - { forward (hmz minprem). eapply clauses_premises_levels_spec. eexists; split; eauto. cbn. - eapply levelexprset_levels_spec. now eexists. red in hmz. - rewrite hminprem in hmz. depelim hmz. + { have hmz' := above_max_premise_model_infers hmz. forward (hmz' minprem). + eapply clauses_premises_levels_incl. eapply clauses_premises_levels_spec. eexists; split; eauto. cbn. + eapply levelexprset_levels_spec. now eexists. red in hmz'. + rewrite hminprem in hmz'. depelim hmz'. have := max_clause_premise_spec (prems, (concl, k)) cls H. cbn. have [] := premise_max_spec prems => /(_ _ inprems) //= lemax _. @@ -4569,16 +4749,15 @@ Proof. assert (exists z', z = Z.of_nat z'). exists (Z.to_nat z). lia. destruct H0 as [z2 ->]. rename z2 into z. rewrite -hypss in hminprem. rewrite -> Nat2Z.id in *. - eapply hyps_entails; tea. rewrite hmin. lia_f_equal. + eapply hyps_entails; tea. have hmz' := above_max_premise_model_infers hmz. intros l hl; apply hmz'. + now apply clauses_premises_levels_incl. rewrite hmin. lia_f_equal. constructor. now rewrite of_level_map_spec. - have hnemid : ~ LevelMap.Empty m'. by exact: strictly_updates_non_empty_map su1. specialize (IHsu1 hne hnemid). specialize (IHsu2 hnemid hne'). forward IHsu1. auto. forward IHsu2. - { intros l hin. red. move: (hmz _ hin). unfold infers_atom. - intros leq; depelim leq. eapply strictly_updates_ext in su1. - eapply model_le_values in su1. etransitivity; [|eexact su1]. now apply hmz. } + { eapply above_max_premise_model_trans; tea. } eapply entails_all_trans; tea. Qed. @@ -4590,9 +4769,9 @@ Proof. now apply LevelSet.choose_spec2 in ch. Qed. -Lemma of_level_map_of_level_set cls V m hne hne' : - max_premise_model cls m -> - V =_lset clauses_premises_levels cls -> +Lemma of_level_map_of_level_set cls sel V m hne hne' : + max_premise_model cls sel m -> + V =_lset sel cls -> of_level_map m hne = of_level_set V (max_clause_premise cls) hne'. Proof. move=> mp hv. apply: eq_univ' => [[l k]]. @@ -4603,6 +4782,47 @@ Proof. now apply mp. Qed. +Lemma infers_atom_of_level_map {cls m hne l k} : + infers_atom m l (Z.of_nat k) -> + cls ⊢ of_level_map m hne → (l, k). +Proof. + rewrite /infers_atom. intros hle. depelim hle. + have [y' eq] : exists y', y = Z.of_nat (k + y'). exists (Z.to_nat y - k). lia. + eapply (entails_trans (concl := (l, k + y'))). + - constructor. rewrite of_level_map_spec. + eapply level_value_MapsTo'. rewrite H0. f_equal. lia. + - eapply (entails_pred_closure_n (n := y')). + constructor. now eapply LevelExprSet.singleton_spec. +Qed. + +Lemma of_level_map_entails_of_level_set cls V m hne hne' : + above_max_premise_model cls m -> + V ⊂_lset clauses_levels cls -> + cls ⊢a of_level_map m hne → of_level_set V (max_clause_premise cls) hne'. +Proof. + move=> mp hv. + intros [l k]. + rewrite levelexprset_of_levels_spec. + intros [hin ->]. + have hi := above_max_premise_model_infers mp. + move: (hi l (hv _ hin)). + eapply infers_atom_of_level_map. +Qed. + +(* +Lemma of_level_set_entails_of_level_map cls sel V m hne hne' : + above_max_premise_model cls sel m -> + V ⊂_lset sel cls -> + cls ⊢a of_level_set V (max_clause_premise cls) hne' → of_level_map m hne. +Proof. + move=> mp hv. + intros [l k]. + rewrite of_level_map_spec. levelexprset_of_levels_spec. + intros [hin ->]. + move: (mp l (hv _ hin)). + eapply infers_atom_of_level_map. +Qed. *) + (* The criterion for loops: when a set of updates manages to strictly update all the levels it started with, then we can deduce a looping constraint `x, ..., z -> x + 1, ... z + 1`. @@ -4612,9 +4832,13 @@ Qed. *) +Lemma max_premise_model_unique cls m : max_premise_model cls clauses_levels m -> m = max_premise_map cls. +Proof. +Admitted. + Lemma strictly_updates_entails_loop cls V (hne : ~ LevelSet.Empty V) mzero m : - max_premise_model cls mzero -> - V =_lset clauses_premises_levels cls -> + max_premise_model cls clauses_levels mzero -> + V =_lset clauses_levels cls -> total_model_of V mzero -> strictly_updates cls V mzero m -> entails_all cls (of_level_set V (max_clause_premise cls) hne) @@ -4629,7 +4853,7 @@ Proof. eapply (strictly_updates_entails nemzero nem) in su; tea. unshelve erewrite of_level_map_of_level_set in su; tea. move/entails_all_trans: su; apply. - 2:by eapply max_premise_model_above. + 2:{ right. have me := (max_premise_model_exists cls). eapply max_premise_model_unique in maxp; tea. } apply: entails_succ => l k. rewrite levelexprset_of_levels_spec => [[hin ->]]. rw of_level_map_spec. @@ -4646,6 +4870,31 @@ Proof. split => //. lia. Qed. +Lemma strictly_updates_entails_loop_relax cls V (hne : ~ LevelSet.Empty V) mzero m : + above_max_premise_model cls mzero -> + V =_lset clauses_levels cls -> + total_model_of V mzero -> + strictly_updates cls V mzero m -> + entails_all cls (of_level_set V (max_clause_premise cls) hne) + (of_level_set V (max_clause_premise cls + 1) hne). +Proof. + move=> habove hv tot su. + destruct habove as [[V' ha]|eq]. + * apply (strictly_updates_entails_loop cls V hne (max_premise_map cls) m); tea. + - apply max_premise_model_exists. + - have [hs hs'] := max_premise_model_exists cls. red. + intros k hm. rewrite hv in hm. specialize (hs _ hm). now eexists. + - have tr := strictly_updates_trans ha su. rewrite union_idem in tr. + eapply strictly_updates_incl in ha. + assert (V' ∪ V = V). + { apply LevelSet.eq_leibniz. red. + rewrite hv. move: (clauses_conclusions_levels cls). lsets. } + now rewrite H in tr. + * subst mzero. + eapply strictly_updates_entails_loop; tea. + apply max_premise_model_exists. +Qed. + Lemma add_prems_add {n lk prems} : add_prems n (add lk prems) = add (add_expr n lk) (add_prems n prems). Proof. apply eq_univ'. intros x. @@ -4653,16 +4902,18 @@ Proof. firstorder. subst. red in H; subst x0. now left. Qed. +Section Loop. + Variable (ocls : clauses). #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V, model_of V minit & is_update_of cls U minit m]) : result V U cls minit + (prf : [/\ clauses_levels cls ⊂_lset V, total_model_of V minit, cls ⊂_clset ocls, above_max_premise_model ocls minit & is_update_of cls U minit m]) : result V U cls minit by wf (loop_measure V U) lexprod_rel := loop V U cls minit m prf with inspect (check_model cls (U, m)) := | exist None eqm => Model U {| model_model := m |} _ | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { | exist true eq := Loop W (check_model_ne eqm) _ (* Loop on cls ↓ W, with |W| < |V| *) - | exist false neq with inner_loop V U minit loop W (cls ↓ W) m' _ := + | exist false neq with inner_loop V ocls U minit _ loop W (cls ↓ W) m' _ := { | Loop W' ne isloop := Loop W' ne (loop_on_subset _ isloop) | Model Wc mwc _ (* We get a model for (cls ↓ W), we check if it extends to all clauses. @@ -4686,22 +4937,32 @@ Proof. all:try solve [intuition auto]. all:try eapply levelset_neq in neq. all:have cls_sub := clauses_conclusions_levels cls. - all:destruct prf as [clsV mof isupd]. + all:destruct prf as [clsV mof inclocls abovemax isupd]. - do 2 red. eapply LevelSet.equal_spec in eq. set (prf := check_model_ne eqm); clearbody prf. eapply check_model_is_update_of in eqm; tea. rewrite eq in eqm. destruct eqm as [eqm incl]. rewrite union_idem in eqm. - eapply strictly_updates_strenghten in eqm. eapply strictly_updates_entails_loop with minit m'. - + apply todo. - + rewrite eq. intros x. eapply strictly_updates_incl in eqm. rewrite clauses_premises_levels_spec. - + + apply todo. (* max premise model *) + + rewrite eq. intros x. eapply strictly_updates_incl in eqm. + split. 2:apply clsV. + now move/eqm/clauses_conclusions_levels. + + now rewrite eq. + + now rewrite eq. + - exact abovemax. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hi := strictly_updates_incl eqm. rewrite union_idem in hi, eqm. (* apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. *) - split => //. split => //. lsets. now eapply strictly_updates_non_empty. - apply clauses_conclusions_clauses_with_concl. now eapply strictly_updates_strenghten. + split => //. + * split => //. lsets. + * now eapply strictly_updates_non_empty. + * transitivity cls => //. apply clauses_with_concl_subset. + * apply clauses_conclusions_clauses_with_concl. + * eapply strictly_updates_strenghten. exact eqm. + (* * eapply above_max_premise_model_strengthen; tea. 2: eapply clauses_with_concl_subset. + eapply clauses_levels_mon. + * now eapply strictly_updates_strenghten. *) - now intros ?; rewrite in_clauses_with_concl. - set (ne := check_model_ne eqm'). clearbody ne. have hu := model_updates mwc. @@ -4710,11 +4971,15 @@ Proof. eapply check_model_is_update_of in eqm as [eqm incl]; tea. rewrite union_idem in eqm. have tr := update_trans _ eqm eqm'. eapply LevelSet.equal_spec in e. rewrite e in tr. - assert (LevelSet.union W V =_lset V). eapply strictly_updates_incl in eqm. lsets. - rewrite H in tr. symmetry in e. + assert (hun : LevelSet.union W V =_lset V). eapply strictly_updates_incl in eqm. lsets. + rewrite hun in tr. symmetry in e. have [neV hl] := loop_on_proper _ _ ne cls e. apply hl. have vm := model_ok mwc. - apply todo. (* loop *) + eapply strictly_updates_entails_loop with minit mcls; tea. + + apply todo. (* minit is a max premise model *) + + split. 2:apply clsV. intros hinV. + eapply strictly_updates_incl in tr. apply tr in hinV. + now apply clauses_conclusions_levels. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hu := model_updates mwc. eapply strictly_updates_is_update_of in hu; tea. @@ -4724,14 +4989,14 @@ Proof. have tr := is_update_of_trans_eq hu upd. split => //. apply tr. clsets. lsets. - right. - eapply check_model_spec_V in eqm' as eqm''. 3:exact clsV. cbn in eqm''. + eapply check_model_spec_V in eqm' as eqm''. 3:etransitivity; [apply clauses_conclusions_levels|exact clsV]. cbn in eqm''. 2:{ eapply check_model_is_update_of in eqm as [eqm incl]; tea. eapply strictly_updates_is_update_of in eqm; tea. 2:apply mwc. - eapply strictly_updates_model_of_gen in eqm; tea. + eapply strictly_updates_model_of_gen in eqm; tea. 2:eapply total_model_of_sub; tea. eapply model_of_subset; tea. lsets. } 2:{ eapply is_update_of_total_model. apply mwc. } - destruct eqm'' as []. + destruct eqm'' as [Hwc Hwcls H1 mext tot]. eapply check_model_is_update_of in eqm as [eqm incl]; tea. rewrite union_idem in eqm. have hu := model_updates mwc. @@ -4744,42 +5009,46 @@ Proof. assert (exists l, LevelSet.In l Wcls /\ ~ LevelSet.In l W). { destruct H1 as [cl [clcls nvalid hcll hv]]. pose proof (model_ok mwc). - eapply is_model_invalid_clause in H1; tea. + eapply is_model_invalid_clause in H; tea. assert (~ LevelSet.In (levelexpr_level (concl cl)) W). - { intros hin. rewrite in_clauses_with_concl in H1. intuition auto. } + { intros hin. rewrite in_clauses_with_concl in H. intuition auto. } exists (concl cl). split => //. } assert (Wcls ⊂_lset V). lsets. - rewrite -!diff_cardinal //. clear -w_incl clsV incl H5. lsets. lsets. + rewrite -!diff_cardinal //. clear -w_incl clsV incl H0. have hincl := clauses_conclusions_levels cls. lsets. lsets. eapply strict_subset_cardinal. eapply (strict_subset_leq_right _ (LevelSet.diff V W)). 2:lsets. apply strict_subset_diff_incl => //. - { red. split => //. lsets. intros heq. destruct H4 as [l' [hin hnin]]. + { red. split => //. lsets. intros heq. destruct H as [l' [hin hnin]]. rewrite heq in hnin. apply hnin. lsets. } lsets. lsets. - eapply mcls'. - apply mcls'. - apply mcls'. - apply mcls'. - - eapply check_model_is_update_of in eqm as []; tea. rewrite union_idem in H. lsets. + - eapply check_model_is_update_of in eqm as []; tea. lsets. - eapply check_model_is_update_of in eqm as [suinit incl]; tea. rewrite union_idem in suinit. have hupd := model_updates mwc. eapply (is_update_of_weaken (cls' := cls)) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. eapply strictly_updates_is_update_of in suinit; tea. rewrite union_idem in suinit. eapply model_of_strictly_updates; tea. + * etransitivity; [eapply clauses_conclusions_levels|tea]. + * now eapply total_model_of_sub. - eapply check_model_is_update_of in eqm as [suinit incl]; tea. rewrite union_idem in suinit. have hupd := model_updates mwc. eapply (is_update_of_weaken (cls' := cls)) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. eapply is_update_of_trans_eq. eapply is_update_of_strictly_updates. tea. tea. clsets. lsets. - - assumption. + - eapply clauses_levels_conclusions; assumption. - now apply check_model_None in eqm'. - - eapply check_model_is_update_of in eqm as [suinit incl]; tea. rewrite union_idem in suinit. lsets. + - eapply check_model_is_update_of in eqm as [suinit incl]; tea. lsets. - move: isupd. rewrite /is_update_of. destruct LevelSet.is_empty. - * now intros ->. + * now intros ->; apply total_model_of_sub. * intros su. eapply model_of_strictly_updates; tea. + now apply clauses_levels_conclusions. + now apply total_model_of_sub. - exact isupd. - - assumption. + - apply clauses_levels_conclusions. assumption. - now eapply check_model_None in eqm. - lsets. Qed. @@ -4789,13 +5058,29 @@ Transparent lexprod_rel_wf. Definition zero_model levels := LevelSet.fold (fun l acc => LevelMap.add l (Some 0%Z) acc) levels (LevelMap.empty _). +(* To handle the constraint inference problem, + we must start with a model where all atoms [l + k] + appearing in premises are true. Otherwise the + [l := 0] model is minimal for [l+1-> l+2]. + Starting with [l := 1], we see that the minimal model above it + has [l := ∞]. + We also ensure that all levels in the conclusions are in the model. + *) + Definition add_max l k m := match LevelMap.find l m with | Some (Some k') => if (k' LevelMap.add l (Some k) m - end. + end. + +Definition min_model_map (m : LevelMap.t (option Z)) cls : LevelMap.t (option Z) := + Clauses.fold (fun '(cl, concl) acc => + LevelExprSet.fold (fun '(l, k) acc => + add_max l (Z.of_nat k) acc) cl (add_max (levelexpr_level concl) 0%Z acc)) cls m. + + Lemma In_add_max l l' k acc : LevelMap.In (elt:=option Z) l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). @@ -5047,20 +5332,6 @@ Proof. Qed. -(* To handle the constraint inference problem, - we must start with a model where all atoms [l + k] - appearing in premises are true. Otherwise the - [l := 0] model is minimal for [l+1-> l+2]. - Starting with [l := 1], we see that the minimal model above it - has [l := ∞]. - We also ensure that all levels in the conclusions are in the model. - *) - -Definition min_model_map (m : LevelMap.t (option Z)) cls : LevelMap.t (option Z) := - Clauses.fold (fun '(cl, concl) acc => - LevelExprSet.fold (fun '(l, k) acc => - add_max l (Z.of_nat k) acc) cl (add_max (levelexpr_level concl) 0%Z acc)) cls m. - Lemma min_model_map_levels m cls k : LevelMap.In k (min_model_map m cls) <-> LevelSet.In k (clauses_levels cls) \/ LevelMap.In k m. From 35aa35313e1edd933c88552af61944a1ba19a53b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 26 Aug 2025 17:05:54 +0200 Subject: [PATCH 016/164] WIP --- template-rocq/theories/PartialLoopChecking.v | 365 ++++++++++++++++--- 1 file changed, 321 insertions(+), 44 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 2aae7ed1b..ad85dc357 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -2746,14 +2746,14 @@ Lemma loop_on_subset {W hne cls cls'} : Clauses.Subset cls cls' -> loop_on W hne Proof. Admitted. -Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := - | Loop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne cls) +Inductive result (V U : LevelSet.t) (ocls cls : clauses) (m : model) := + | Loop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne ocls) | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). -Arguments Loop {V U cls m}. -Arguments Model {V U cls m}. +Arguments Loop {V U ocls cls m}. +Arguments Model {V U ocls cls m}. Arguments lexprod {A B}. -Definition option_of_result {V U m cls} (r : result V U m cls) : option model := +Definition option_of_result {V U m ocls cls} (r : result V U m ocls cls) : option model := match r with | Model w m _ => Some m.(model_model) | Loop w hne isloop => None @@ -3721,32 +3721,23 @@ Section InnerLoop. - lia. Qed. - (*Lemma above_max_premise_model_strengthen {cls cls' m} : - cls ⊂_clset cls' -> - above_max_premise_model cls m -> - above_max_premise_model cls' m. - Proof. - intros hincl [V' su]. exists V'. - eapply strictly_updates_weaken; tea. red in ha. - move/(hmon _ _ hincl)/(ha l) => ha'. - eapply infer_atom_downward; tea. - apply max_clause_premise_mon in hincl. lia. - Qed. *) - - Context (V : LevelSet.t) (ocls : clauses) (U : LevelSet.t) (init_model : model) (maxp : above_max_premise_model ocls init_model) + Context (V : LevelSet.t) (U : LevelSet.t) (ocls : clauses) + (init_model : model) (maxp : above_max_premise_model ocls init_model) (loop : forall (V' U' : LevelSet.t) (cls' : clauses) (minit m : model) - (prf : [/\ clauses_levels cls' ⊂_lset V', total_model_of V' minit, cls' ⊂_clset ocls, above_max_premise_model ocls minit & is_update_of cls' U' minit m]), - lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls' minit). + (prf : [/\ clauses_levels cls' ⊂_lset V', total_model_of V' minit, + cls' ⊂_clset ocls, above_max_premise_model ocls minit & is_update_of cls' U' minit m]), + lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' ocls cls' minit). Section innerloop_partition. Context (W : LevelSet.t) (cls : clauses). Context (premconclW conclW : clauses). - Context (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, cls ⊂_clset ocls, clauses_conclusions cls ⊂_lset W, + Context (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W, + cls ⊂_clset ocls, Clauses.Equal premconclW (cls ⇂ W) & Clauses.Equal conclW (Clauses.diff (cls ↓ W) (cls ⇂ W))]). #[tactic="idtac"] Equations? inner_loop_partition (m : model) (upd : strictly_updates cls W init_model m) : - result W LevelSet.empty cls m + result W LevelSet.empty ocls cls m by wf (measure W cls m) lt := inner_loop_partition m upd with loop W LevelSet.empty premconclW m m _ _ := { (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) @@ -3770,7 +3761,7 @@ Section InnerLoop. all:cbn [model_model]; clear loop inner_loop_partition. all:try apply LevelSet.subset_spec in hsub. all:auto. - all:try destruct prf as [WV neW UW oclsi clsW eqprem eqconcl]. + all:try destruct prf as [WV neW UW clsW oincl eqprem eqconcl]. all:try solve [intuition auto]. all:try rewrite eqconcl in eqm. - split => //. @@ -3780,7 +3771,7 @@ Section InnerLoop. * eapply strictly_updates_weaken in upd; tea. eapply above_max_premise_model_trans in maxp; tea. * eapply is_update_of_empty. - left. now eapply strict_subset_cardinal. - - rewrite eqprem. eapply restrict_clauses_subset. + (* - rewrite eqprem. eapply restrict_clauses_subset. *) (* - destruct prf. transitivity (cls ⇂ W) => //. now rewrite H3. eapply restrict_clauses_subset. *) - have mu := model_updates mr. eapply strictly_updates_is_update_of in upd; tea. @@ -3837,7 +3828,7 @@ Section InnerLoop. #[tactic="idtac"] Equations? inner_loop (W : LevelSet.t) (cls : clauses) (m : model) (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, cls ⊂_clset ocls, clauses_conclusions cls ⊂_lset W & - strictly_updates cls W init_model m]) : result W LevelSet.empty cls m := + strictly_updates cls W init_model m]) : result W LevelSet.empty ocls cls m := inner_loop W cls m prf with inspect (Clauses.partition (premise_restricted_to W) cls) := | exist (premconclW, conclW) eqp => inner_loop_partition W cls premconclW conclW _ m _. Proof. @@ -4646,7 +4637,7 @@ Definition hyps_map (hyps : univ) m := Lemma model_hyps_entails cls m hyps (prems : univ) concl : Clauses.In (prems, concl) cls -> - (forall l : Level.t, LevelSet.In l (clauses_premises_levels cls) -> Some (Z.of_nat (max_clause_premise cls)) ≤ level_value m l) -> + (forall l : Level.t, LevelSet.In l (clauses_premises_levels cls) -> Some (Z.of_nat 0) ≤ level_value m l) -> hyps_map hyps m -> cls ⊢a hyps → premise_values prems m. Proof. @@ -4676,7 +4667,7 @@ Qed. Lemma hyps_entails (hyps : univ) m cls : - forall (hmz : forall l : Level.t, LevelSet.In l (clauses_premises_levels cls) -> Some (Z.of_nat (max_clause_premise cls)) ≤ level_value m l), + forall (hmz : forall l : Level.t, LevelSet.In l (clauses_premises_levels cls) -> Some (Z.of_nat 0) ≤ level_value m l), (forall (l : Level.t) (k : nat), LevelExprSet.In (l, k) hyps <-> LevelMap.MapsTo l (Some (Z.of_nat k)) m) -> forall prems conclk, Clauses.In (prems, conclk) cls -> forall v, min_premise m prems = Some (Z.of_nat v) -> @@ -4700,19 +4691,43 @@ Proof. have hmz' := hmz prem. forward hmz'. { rewrite clauses_premises_levels_spec. eexists; split => //. exact H0. cbn. eapply levelexprset_levels_spec. now eexists. } - depelim hmz'. rewrite H4 //=. + depelim hmz'. rewrite H4 //=. clear H3. assert (v = Z.to_nat z - minpremk). lia. subst v. specialize (minsleq _ inprem). cbn in minsleq. rewrite H4 in minsleq. rewrite H1 in minsleq. depelim minsleq. have hmzz := hmz minprem. forward hmzz. { rewrite clauses_premises_levels_spec. eexists. split. eassumption. cbn. eapply levelexprset_levels_spec. now eexists. } - rewrite hl in hmzz. depelim hmzz. + rewrite hl in hmzz. depelim hmzz. clear H5. lia. Qed. +Definition model_above cls m := forall l, + LevelSet.In l (clauses_levels cls) -> + exists k', LevelMap.MapsTo l k' m /\ Some (Z.of_nat (max_clause_premise cls)) ≤ k'. + +Lemma model_above_infers {cls m} : + model_above cls m -> + (forall l, LevelSet.In l (clauses_levels cls) -> infers_atom m l (Z.of_nat (max_clause_premise cls))). +Proof. +Admitted. + +Lemma model_above_update {cls V' m m'} : + model_above cls m -> + strictly_updates cls V' m m' -> + model_above cls m'. +Proof. + move=> above /strictly_updates_ext. + move=> le l /above => [] [] k' [] hm hle. + apply le in hm as [k'' [hin' le']]. + exists k''. split => //. now transitivity k'. +Qed. + +Lemma max_premise_model_above cls m : max_premise_model cls clauses_levels m -> model_above cls m. +Admitted. + Lemma strictly_updates_entails {cls V mzero m} (hne : ~ LevelMap.Empty mzero) (hne' : ~ LevelMap.Empty m) : - above_max_premise_model cls mzero -> + model_above cls mzero -> strictly_updates cls V mzero m -> entails_all cls (of_level_map mzero hne) (of_level_map m hne'). Proof. @@ -4731,7 +4746,7 @@ Proof. destruct hin as [[eq heq]|[neq hm]]. red in eq. subst l. noconf heq. have minp_pos : (z - Z.of_nat mink >= 0)%Z. - { have hmz' := above_max_premise_model_infers hmz. forward (hmz' minprem). + { have hmz' := model_above_infers hmz. forward (hmz' minprem). eapply clauses_premises_levels_incl. eapply clauses_premises_levels_spec. eexists; split; eauto. cbn. eapply levelexprset_levels_spec. now eexists. red in hmz'. rewrite hminprem in hmz'. depelim hmz'. @@ -4749,15 +4764,18 @@ Proof. assert (exists z', z = Z.of_nat z'). exists (Z.to_nat z). lia. destruct H0 as [z2 ->]. rename z2 into z. rewrite -hypss in hminprem. rewrite -> Nat2Z.id in *. - eapply hyps_entails; tea. have hmz' := above_max_premise_model_infers hmz. intros l hl; apply hmz'. - now apply clauses_premises_levels_incl. rewrite hmin. lia_f_equal. + eapply hyps_entails; tea. + have hmz' := model_above_infers hmz. + { move=> l /clauses_premises_levels_incl hl. apply hmz' in hl. red in hl. + depelim hl. rewrite H1; constructor. lia. } + rewrite hmin. lia_f_equal. constructor. now rewrite of_level_map_spec. - have hnemid : ~ LevelMap.Empty m'. by exact: strictly_updates_non_empty_map su1. specialize (IHsu1 hne hnemid). specialize (IHsu2 hnemid hne'). forward IHsu1. auto. forward IHsu2. - { eapply above_max_premise_model_trans; tea. } + { eapply model_above_update; tea. } eapply entails_all_trans; tea. Qed. @@ -4853,7 +4871,97 @@ Proof. eapply (strictly_updates_entails nemzero nem) in su; tea. unshelve erewrite of_level_map_of_level_set in su; tea. move/entails_all_trans: su; apply. - 2:{ right. have me := (max_premise_model_exists cls). eapply max_premise_model_unique in maxp; tea. } + 2:{ now apply max_premise_model_above. } + (* right. have me := (max_premise_model_exists cls). eapply max_premise_model_unique in maxp; tea. } *) + apply: entails_succ => l k. + rewrite levelexprset_of_levels_spec => [[hin ->]]. + rw of_level_map_spec. + move: (mp l) => [] /(_ hin). + move: (tot _ hin) => [x hm]. + move/(_ _ hm) => [k' [hm' lt]]. + intros _. + exists (Z.to_nat k'). + unfold max_premise_model in maxp. + move: (proj1 maxp l) => hl. + forward hl. apply vincl, hin. + eapply LevelMapFact.F.MapsTo_fun in hm; tea. noconf hm. + rewrite Z2Nat.id. lia. + split => //. lia. +Qed. + + +Lemma in_pred_closure_subset {cls cls' prems concl} : + in_pred_closure cls (prems, concl) -> + cls ⊂_clset cls' -> + in_pred_closure cls' (prems, concl). +Proof. + induction 1. + - move/(_ _ H). now constructor. + - constructor. +Qed. + +Lemma entails_clauses_subset cls cls' prems concl : + cls ⊢ prems → concl -> + cls ⊂_clset cls' -> + cls' ⊢ prems → concl. +Proof. + induction 1 in cls' |- * => incl. + - now constructor. + - eapply clause_cut. + + eapply in_pred_closure_subset; tea. + + now apply IHentails. + + assumption. +Qed. + +Lemma entails_all_clauses_subset cls cls' prems concl : + cls ⊢a prems → concl -> + cls ⊂_clset cls' -> + cls' ⊢a prems → concl. +Proof. + intros d incl [l k]. + now move/d/entails_clauses_subset. +Qed. + +Definition new_model m V newk : model := + LevelMap.fold (fun l k acc => + let k' := if LevelSet.mem l V then newk else k in + LevelMap.add l k' acc) m (LevelMap.empty _). + +Lemma new_model_spec m V newk l k : + LevelMap.MapsTo l k (new_model m V newk) -> + (exists k', LevelMap.MapsTo l k' m /\ + if LevelSet.mem l V then k = newk else k = k'). +Proof. Admitted. + +Lemma strictly_updates_entails_loop2 cls V (hne : ~ LevelSet.Empty V) mzero m : + let bound := v_minus_w_bound V m in + let maxgain := max_gain cls in + let n := Z.to_nat bound + maxgain in + max_premise_model cls clauses_levels mzero -> + V =_lset clauses_levels cls -> + total_model_of V mzero -> + strictly_updates cls V mzero m -> + entails_all cls (of_level_set V n hne) (of_level_set V (n + 1) hne). +Proof. + intros bound maxgain n maxp vincl tot su. + have nemzero : ~ LevelMap.Empty mzero. + { have := not_empty_exists V hne => [[l]]. + now move/tot => [v hm] /(_ _ _ hm). } + have nem := strictly_updates_non_empty_map su. + eapply strictly_updates_strenghten in su. + set (m' := new_model mzero V (Some (Z.of_nat n))). + have [m'' su'] : exists m'', strictly_updates (cls ⇂ V) V m' m''. + admit. + have mp := strictly_updates_model_lt su'. + forward mp. admit. + eapply entails_all_clauses_subset. + eapply (strictly_updates_entails nemzero nem) in su'; tea. + + + unshelve erewrite of_level_map_of_level_set in su; tea. + move/entails_all_trans: su; apply. + 2:{ now apply max_premise_model_above. } + (* right. have me := (max_premise_model_exists cls). eapply max_premise_model_unique in maxp; tea. } *) apply: entails_succ => l k. rewrite levelexprset_of_levels_spec => [[hin ->]]. rw of_level_map_spec. @@ -4870,7 +4978,109 @@ Proof. split => //. lia. Qed. -Lemma strictly_updates_entails_loop_relax cls V (hne : ~ LevelSet.Empty V) mzero m : + + +Lemma model_max_max_premise_map cls : Z.to_nat (model_max (max_premise_map cls)) = max_clause_premise cls. +Proof. +Admitted. + +Lemma strictly_updates_entails_loop_max cls V (hne : ~ LevelSet.Empty V) m : + V =_lset clauses_levels cls -> + strictly_updates cls V (max_premise_map cls) m -> + entails_all cls (of_level_set V (Z.to_nat (model_max (max_premise_map cls))) hne) + (of_level_set V (Z.to_nat (model_max (max_premise_map cls)) + 1) hne). +Proof. + intros. + rewrite !model_max_max_premise_map. + eapply strictly_updates_entails_loop; tea. + eapply max_premise_model_exists. + apply todo. +Qed. + +#[program] +Definition of_level_map_n (m : LevelMap.t (option Z)) V n (hne : ~ LevelMap.Empty m) : nonEmptyLevelExprSet := + {| t_set := LevelMap.fold (fun l k acc => + if LevelSet.mem l V then LevelExprSet.add (l, n + option_default Z.to_nat k 0%nat) acc else + LevelExprSet.add (l, option_default Z.to_nat k 0%nat) acc) m LevelExprSet.empty |}. +Next Obligation. Admitted. + +Lemma of_level_map_n_spec m V hne : + forall l n k, LevelExprSet.In (l, k) (of_level_map_n m V n hne) <-> + (exists k', LevelMap.MapsTo l (Some (Z.of_nat k')) m /\ + (LevelSet.In l V -> k = n + k') /\ + (~ LevelSet.In l V -> k = k')). +Proof. +Admitted. + +Lemma entails_any_one V cls m nem m' nem' : + total_model_of V m -> + cls ⊢a of_level_map m nem → of_level_map m' nem' -> + model_rel_partial Z.lt V m m' -> + forall l k, LevelSet.In l V -> + LevelMap.MapsTo l (Some (Z.of_nat k)) m -> cls ⊢ of_level_map m nem → (l, k + 1). +Proof. + intros tot cla mp l k hin hm. + eapply entails_all_one; tea. + move: (proj1 (mp l) hin). + move: (tot _ hin) => [x hm']. + move/(_ _ hm) => [k'' [hm'' lt]]. + apply infers_atom_of_level_map. red. rewrite (level_value_MapsTo hm''). constructor. lia. +Qed. + +Lemma of_level_map_of_level_map_n m V ne : + of_level_map m ne = of_level_map_n m V 0 ne. +Proof. + apply eq_univ'. + intros [l k]. + rewrite of_level_map_spec of_level_map_n_spec. + firstorder. + destruct (LevelSetDecide.MSetDecideAuxiliary.dec_In l V) as [hin|hnin]. + now rewrite (H0 hin). + now rewrite (H1 hnin). +Qed. + +Lemma entails_any V cls m nem m' nem' : + total_model_of V m -> + cls ⊢a of_level_map m nem → of_level_map m' nem' -> + model_rel_partial Z.lt V m m' -> + cls ⊢a of_level_map m nem → of_level_map_n m V 1 nem. +Proof. + intros tot cla mp [l k]. + rewrite of_level_map_n_spec => []. + intros [k' [hm [hin hnin]]]. + destruct (LevelSetDecide.MSetDecideAuxiliary.dec_In l V). + rewrite (hin H). + rewrite -[1 + _]Nat.add_1_r. + eapply entails_any_one; tea. + rewrite (hnin H). + constructor. now rewrite of_level_map_spec. +Qed. + +(* Lemma entails_any V cls m nem m' nem' : + total_model_of V m -> + model_rel_partial Z.lt V m m' -> + cls ⊢a of_level_map_n m V 1 nem → of_level_map_n m V 2 nem. +Proof. *) + +Lemma strictly_updates_entails_loop_relax cls V mzero hne m : + model_above cls mzero -> + V =_lset clauses_levels cls -> + total_model_of V mzero -> + strictly_updates cls V mzero m -> + entails_all cls (of_level_map_n mzero V 0 hne) (of_level_map_n mzero V 1 hne). +Proof. + move=> habove hv tot su. + have mp := strictly_updates_model_lt su tot. + (* have nemzero : ~ LevelMap.Empty mzero. + { have := not_empty_exists V hne => [[l]]. + now move/tot => [v hm] /(_ _ _ hm). } *) + have nem := strictly_updates_non_empty_map su. + eapply (strictly_updates_entails hne nem) in su; tea. + rewrite -of_level_map_of_level_map_n. + eapply entails_any; tea. +Qed. + +Lemma strictly_updates_entails_loop_relax' cls V (hne : ~ LevelSet.Empty V) mzero m : above_max_premise_model cls mzero -> V =_lset clauses_levels cls -> total_model_of V mzero -> @@ -4894,6 +5104,21 @@ Proof. eapply strictly_updates_entails_loop; tea. apply max_premise_model_exists. Qed. +(* +Lemma strictly_updates_entails_loop_relax' ocls cls V (hne : ~ LevelSet.Empty V) mzero m : + above_max_premise_model ocls mzero -> + cls ⊂_clset ocls -> + V =_lset clauses_levels cls -> + total_model_of V mzero -> + strictly_updates cls V mzero m -> + entails_all cls (of_level_set V (max_clause_premise cls) hne) + (of_level_set V (max_clause_premise cls + 1) hne). +Proof. + move=> habove hincl hv tot su. + eapply strictly_updates_entails_loop_relax; tea. *) + + + Lemma add_prems_add {n lk prems} : add_prems n (add lk prems) = add (add_expr n lk) (add_prems n prems). Proof. @@ -4901,19 +5126,68 @@ Proof. rewrite In_add_prems LevelExprSet.add_spec In_add_prems /LevelExprSet.E.eq; rw LevelExprSet.add_spec. firstorder. subst. red in H; subst x0. now left. Qed. +(* +Lemma above_max_premise_model_strengthen {cls cls' m} : + cls ⊂_clset cls' -> + above_max_premise_model cls m -> + above_max_premise_model cls' m. +Proof. + intros hincl [[V' su]|eq]. + left. 2:{ subst. red. } exists V'. + eapply strictly_updates_weaken; tea. red in ha. + move/(hmon _ _ hincl)/(ha l) => ha'. + eapply infer_atom_downward; tea. + apply max_clause_premise_mon in hincl. lia. +Qed. *) + +Lemma entails_all_shift {cls : clauses} {prems concl : univ} (n : nat) : + cls ⊢a prems → concl -> + cls ⊢a add_prems n prems → add_prems n concl. +Proof. + intros cla cl. + rewrite In_add_prems => [[le' [hin ->]]]. + eapply (entails_shift (cl := (prems, le'))). + now apply cla in hin. +Qed. + +Lemma add_prems_of_level_set k W k' prf : + add_prems k (of_level_set W k' prf) = of_level_set W (k + k') prf. +Proof. + apply eq_univ' => [] [l n]. + rewrite In_add_prems /of_level_set //= levelexprset_of_levels_spec. + split. + - move=> [] [l' n']. rewrite levelexprset_of_levels_spec => [] [[inw eq] eq']. + subst n'. noconf eq'. split => //. lia. + - move=> [inW ->]. exists (l, k'). rewrite levelexprset_of_levels_spec. + split => //. cbn. f_equal; lia. +Qed. + +Lemma entails_of_level_set_strenghten cls W k' k prf : + k' <= k -> + cls ⊢a of_level_set W k' prf → of_level_set W (k' + 1) prf -> + cls ⊢a of_level_set W k prf → of_level_set W (k + 1) prf. +Proof. + intros le ea. + have := entails_all_shift (k - k') ea. + rewrite !add_prems_of_level_set. + have -> : k - k' + k' = k by lia. + now have -> : k - k' + (k' + 1) = k + 1 by lia. +Qed. + Section Loop. - Variable (ocls : clauses). + Context (ocls : clauses). #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) - (prf : [/\ clauses_levels cls ⊂_lset V, total_model_of V minit, cls ⊂_clset ocls, above_max_premise_model ocls minit & is_update_of cls U minit m]) : result V U cls minit + (prf : [/\ clauses_levels cls ⊂_lset V, total_model_of V minit, cls ⊂_clset ocls, + above_max_premise_model ocls minit & is_update_of cls U minit m]) : result V U ocls cls minit by wf (loop_measure V U) lexprod_rel := loop V U cls minit m prf with inspect (check_model cls (U, m)) := | exist None eqm => Model U {| model_model := m |} _ | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { | exist true eq := Loop W (check_model_ne eqm) _ (* Loop on cls ↓ W, with |W| < |V| *) - | exist false neq with inner_loop V ocls U minit _ loop W (cls ↓ W) m' _ := + | exist false neq with inner_loop V U ocls minit _ loop W (cls ↓ W) m' _ := { | Loop W' ne isloop := Loop W' ne (loop_on_subset _ isloop) | Model Wc mwc _ (* We get a model for (cls ↓ W), we check if it extends to all clauses. @@ -4938,12 +5212,14 @@ Proof. all:try eapply levelset_neq in neq. all:have cls_sub := clauses_conclusions_levels cls. all:destruct prf as [clsV mof inclocls abovemax isupd]. - - do 2 red. eapply LevelSet.equal_spec in eq. + - red. eapply LevelSet.equal_spec in eq. set (prf := check_model_ne eqm); clearbody prf. eapply check_model_is_update_of in eqm; tea. rewrite eq in eqm. destruct eqm as [eqm incl]. rewrite union_idem in eqm. - eapply strictly_updates_entails_loop with minit m'. - + apply todo. (* max premise model *) + eapply entails_all_clauses_subset; tea. + eapply entails_of_level_set_strenghten with (max_clause_premise cls). admit. + eapply strictly_updates_entails_loop_relax' with minit m'. + + destruct abovemax. left. admit. + rewrite eq. intros x. eapply strictly_updates_incl in eqm. split. 2:apply clsV. now move/eqm/clauses_conclusions_levels. @@ -4963,7 +5239,8 @@ Proof. (* * eapply above_max_premise_model_strengthen; tea. 2: eapply clauses_with_concl_subset. eapply clauses_levels_mon. * now eapply strictly_updates_strenghten. *) - - now intros ?; rewrite in_clauses_with_concl. + - reflexivity. + (* - now intros ?; rewrite in_clauses_with_concl. *) - set (ne := check_model_ne eqm'). clearbody ne. have hu := model_updates mwc. eapply check_model_is_update_of in eqm' as [eqm' incl']; tea. @@ -4973,7 +5250,7 @@ Proof. have tr := update_trans _ eqm eqm'. eapply LevelSet.equal_spec in e. rewrite e in tr. assert (hun : LevelSet.union W V =_lset V). eapply strictly_updates_incl in eqm. lsets. rewrite hun in tr. symmetry in e. - have [neV hl] := loop_on_proper _ _ ne cls e. apply hl. + have [neV hl] := loop_on_proper _ _ ne ocls e. apply hl. have vm := model_ok mwc. eapply strictly_updates_entails_loop with minit mcls; tea. + apply todo. (* minit is a max premise model *) From 43f4cb91eeb3414b6ff15bfa15ca4292c70d6a9f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 26 Aug 2025 17:21:56 +0200 Subject: [PATCH 017/164] WIP --- template-rocq/theories/PartialLoopChecking.v | 36 ++++++-------------- 1 file changed, 10 insertions(+), 26 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index ad85dc357..7bad0de83 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -4955,29 +4955,12 @@ Proof. have mp := strictly_updates_model_lt su'. forward mp. admit. eapply entails_all_clauses_subset. - eapply (strictly_updates_entails nemzero nem) in su'; tea. - - - unshelve erewrite of_level_map_of_level_set in su; tea. - move/entails_all_trans: su; apply. - 2:{ now apply max_premise_model_above. } - (* right. have me := (max_premise_model_exists cls). eapply max_premise_model_unique in maxp; tea. } *) - apply: entails_succ => l k. - rewrite levelexprset_of_levels_spec => [[hin ->]]. - rw of_level_map_spec. - move: (mp l) => [] /(_ hin). - move: (tot _ hin) => [x hm]. - move/(_ _ hm) => [k' [hm' lt]]. - intros _. - exists (Z.to_nat k'). - unfold max_premise_model in maxp. - move: (proj1 maxp l) => hl. - forward hl. apply vincl, hin. - eapply LevelMapFact.F.MapsTo_fun in hm; tea. noconf hm. - rewrite Z2Nat.id. lia. - split => //. lia. -Qed. + have nem' : ~ LevelMap.Empty m'. admit. + have nem'' : ~ LevelMap.Empty m''. admit. + (* have sue := strictly_updates_entails nem' nem'' _ su'. *) + (* forward sue. admit. apply sue in su'. (cls ⇂ V). in su'; tea *) +Abort. Lemma model_max_max_premise_map cls : Z.to_nat (model_max (max_premise_map cls)) = max_clause_premise cls. @@ -5219,7 +5202,7 @@ Proof. eapply entails_all_clauses_subset; tea. eapply entails_of_level_set_strenghten with (max_clause_premise cls). admit. eapply strictly_updates_entails_loop_relax' with minit m'. - + destruct abovemax. left. admit. + + admit. + rewrite eq. intros x. eapply strictly_updates_incl in eqm. split. 2:apply clsV. now move/eqm/clauses_conclusions_levels. @@ -5252,11 +5235,12 @@ Proof. rewrite hun in tr. symmetry in e. have [neV hl] := loop_on_proper _ _ ne ocls e. apply hl. have vm := model_ok mwc. - eapply strictly_updates_entails_loop with minit mcls; tea. + apply todo. + (* eapply strictly_updates_entails_loop with minit mcls; tea. + apply todo. (* minit is a max premise model *) - + split. 2:apply clsV. intros hinV. + + split. 2:exact clsV. intros hinV. eapply strictly_updates_incl in tr. apply tr in hinV. - now apply clauses_conclusions_levels. + now apply clauses_conclusions_levels. *) - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hu := model_updates mwc. eapply strictly_updates_is_update_of in hu; tea. From a16a2e69762ccc67dea60f99b29c5e162c116430 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 26 Aug 2025 17:45:07 +0200 Subject: [PATCH 018/164] Backtrack on max_premise_model hypothesis --- template-rocq/theories/PartialLoopChecking.v | 72 +++++++++----------- 1 file changed, 32 insertions(+), 40 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 7bad0de83..78e4d3847 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -2746,14 +2746,14 @@ Lemma loop_on_subset {W hne cls cls'} : Clauses.Subset cls cls' -> loop_on W hne Proof. Admitted. -Inductive result (V U : LevelSet.t) (ocls cls : clauses) (m : model) := - | Loop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne ocls) +Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := + | Loop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne cls) | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). -Arguments Loop {V U ocls cls m}. -Arguments Model {V U ocls cls m}. +Arguments Loop {V U cls m}. +Arguments Model {V U cls m}. Arguments lexprod {A B}. -Definition option_of_result {V U m ocls cls} (r : result V U m ocls cls) : option model := +Definition option_of_result {V U m cls} (r : result V U m cls) : option model := match r with | Model w m _ => Some m.(model_model) | Loop w hne isloop => None @@ -3721,23 +3721,21 @@ Section InnerLoop. - lia. Qed. - Context (V : LevelSet.t) (U : LevelSet.t) (ocls : clauses) - (init_model : model) (maxp : above_max_premise_model ocls init_model) + Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) (loop : forall (V' U' : LevelSet.t) (cls' : clauses) (minit m : model) - (prf : [/\ clauses_levels cls' ⊂_lset V', total_model_of V' minit, - cls' ⊂_clset ocls, above_max_premise_model ocls minit & is_update_of cls' U' minit m]), - lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' ocls cls' minit). + (prf : [/\ clauses_levels cls' ⊂_lset V', total_model_of V' minit & + is_update_of cls' U' minit m]), + lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls' minit). Section innerloop_partition. Context (W : LevelSet.t) (cls : clauses). Context (premconclW conclW : clauses). Context (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W, - cls ⊂_clset ocls, Clauses.Equal premconclW (cls ⇂ W) & Clauses.Equal conclW (Clauses.diff (cls ↓ W) (cls ⇂ W))]). #[tactic="idtac"] Equations? inner_loop_partition (m : model) (upd : strictly_updates cls W init_model m) : - result W LevelSet.empty ocls cls m + result W LevelSet.empty cls m by wf (measure W cls m) lt := inner_loop_partition m upd with loop W LevelSet.empty premconclW m m _ _ := { (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) @@ -3761,17 +3759,17 @@ Section InnerLoop. all:cbn [model_model]; clear loop inner_loop_partition. all:try apply LevelSet.subset_spec in hsub. all:auto. - all:try destruct prf as [WV neW UW clsW oincl eqprem eqconcl]. + all:try destruct prf as [WV neW UW clsW eqprem eqconcl]. all:try solve [intuition auto]. all:try rewrite eqconcl in eqm. - split => //. * rewrite eqprem. apply clauses_levels_restrict_clauses. * eapply (strictly_updates_total_model upd). - * rewrite eqprem. transitivity cls => //. apply restrict_clauses_subset. - * eapply strictly_updates_weaken in upd; tea. eapply above_max_premise_model_trans in maxp; tea. + (* * rewrite eqprem. transitivity cls => //. apply restrict_clauses_subset. *) + (* * eapply strictly_updates_weaken in upd; tea. eapply above_max_premise_model_trans in maxp; tea. *) * eapply is_update_of_empty. - left. now eapply strict_subset_cardinal. - (* - rewrite eqprem. eapply restrict_clauses_subset. *) + - rewrite eqprem. eapply restrict_clauses_subset. (* - destruct prf. transitivity (cls ⇂ W) => //. now rewrite H3. eapply restrict_clauses_subset. *) - have mu := model_updates mr. eapply strictly_updates_is_update_of in upd; tea. @@ -3827,12 +3825,12 @@ Section InnerLoop. *) #[tactic="idtac"] Equations? inner_loop (W : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, cls ⊂_clset ocls, clauses_conclusions cls ⊂_lset W & - strictly_updates cls W init_model m]) : result W LevelSet.empty ocls cls m := + (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & + strictly_updates cls W init_model m]) : result W LevelSet.empty cls m := inner_loop W cls m prf with inspect (Clauses.partition (premise_restricted_to W) cls) := | exist (premconclW, conclW) eqp => inner_loop_partition W cls premconclW conclW _ m _. Proof. - - destruct prf as [subWV neW UW oclsi clsW mW]. + - destruct prf as [subWV neW UW clsW mW]. eapply (clauses_partition_spec clsW) in eqp as [eqprem eqconcl]. split => //. now rewrite -(clauses_conclusions_eq _ _ clsW). - apply prf. @@ -5157,20 +5155,16 @@ Proof. now have -> : k - k' + (k' + 1) = k + 1 by lia. Qed. - -Section Loop. - Context (ocls : clauses). #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) - (prf : [/\ clauses_levels cls ⊂_lset V, total_model_of V minit, cls ⊂_clset ocls, - above_max_premise_model ocls minit & is_update_of cls U minit m]) : result V U ocls cls minit + (prf : [/\ clauses_levels cls ⊂_lset V, total_model_of V minit & is_update_of cls U minit m]) : result V U cls minit by wf (loop_measure V U) lexprod_rel := loop V U cls minit m prf with inspect (check_model cls (U, m)) := | exist None eqm => Model U {| model_model := m |} _ | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { | exist true eq := Loop W (check_model_ne eqm) _ (* Loop on cls ↓ W, with |W| < |V| *) - | exist false neq with inner_loop V U ocls minit _ loop W (cls ↓ W) m' _ := + | exist false neq with inner_loop V U minit loop W (cls ↓ W) m' _ := { | Loop W' ne isloop := Loop W' ne (loop_on_subset _ isloop) | Model Wc mwc _ (* We get a model for (cls ↓ W), we check if it extends to all clauses. @@ -5194,21 +5188,20 @@ Proof. all:try solve [intuition auto]. all:try eapply levelset_neq in neq. all:have cls_sub := clauses_conclusions_levels cls. - all:destruct prf as [clsV mof inclocls abovemax isupd]. + all:destruct prf as [clsV mof isupd]. - red. eapply LevelSet.equal_spec in eq. set (prf := check_model_ne eqm); clearbody prf. eapply check_model_is_update_of in eqm; tea. rewrite eq in eqm. destruct eqm as [eqm incl]. rewrite union_idem in eqm. - eapply entails_all_clauses_subset; tea. - eapply entails_of_level_set_strenghten with (max_clause_premise cls). admit. - eapply strictly_updates_entails_loop_relax' with minit m'. - + admit. + (* eapply entails_all_clauses_subset; tea. + eapply entails_of_level_set_strenghten with (max_clause_premise cls). admit. *) + eapply strictly_updates_entails_loop with minit m'. + + apply todo. + rewrite eq. intros x. eapply strictly_updates_incl in eqm. split. 2:apply clsV. now move/eqm/clauses_conclusions_levels. + now rewrite eq. + now rewrite eq. - - exact abovemax. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hi := strictly_updates_incl eqm. rewrite union_idem in hi, eqm. @@ -5216,14 +5209,14 @@ Proof. split => //. * split => //. lsets. * now eapply strictly_updates_non_empty. - * transitivity cls => //. apply clauses_with_concl_subset. + (* * transitivity cls => //. apply clauses_with_concl_subset. *) * apply clauses_conclusions_clauses_with_concl. * eapply strictly_updates_strenghten. exact eqm. (* * eapply above_max_premise_model_strengthen; tea. 2: eapply clauses_with_concl_subset. eapply clauses_levels_mon. * now eapply strictly_updates_strenghten. *) - - reflexivity. - (* - now intros ?; rewrite in_clauses_with_concl. *) + + - now intros ?; rewrite in_clauses_with_concl. - set (ne := check_model_ne eqm'). clearbody ne. have hu := model_updates mwc. eapply check_model_is_update_of in eqm' as [eqm' incl']; tea. @@ -5233,14 +5226,13 @@ Proof. have tr := update_trans _ eqm eqm'. eapply LevelSet.equal_spec in e. rewrite e in tr. assert (hun : LevelSet.union W V =_lset V). eapply strictly_updates_incl in eqm. lsets. rewrite hun in tr. symmetry in e. - have [neV hl] := loop_on_proper _ _ ne ocls e. apply hl. + have [neV hl] := loop_on_proper _ _ ne cls e. apply hl. have vm := model_ok mwc. - apply todo. - (* eapply strictly_updates_entails_loop with minit mcls; tea. + eapply strictly_updates_entails_loop with minit mcls; tea. + apply todo. (* minit is a max premise model *) - + split. 2:exact clsV. intros hinV. + + split. 2:apply clsV. intros hinV. eapply strictly_updates_incl in tr. apply tr in hinV. - now apply clauses_conclusions_levels. *) + now apply clauses_conclusions_levels. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hu := model_updates mwc. eapply strictly_updates_is_update_of in hu; tea. @@ -5274,8 +5266,8 @@ Proof. assert (~ LevelSet.In (levelexpr_level (concl cl)) W). { intros hin. rewrite in_clauses_with_concl in H. intuition auto. } exists (concl cl). split => //. } + rewrite -!diff_cardinal //. clear -w_incl clsV incl wcls_incl. have hincl := clauses_conclusions_levels cls. lsets. lsets. assert (Wcls ⊂_lset V). lsets. - rewrite -!diff_cardinal //. clear -w_incl clsV incl H0. have hincl := clauses_conclusions_levels cls. lsets. lsets. eapply strict_subset_cardinal. eapply (strict_subset_leq_right _ (LevelSet.diff V W)). 2:lsets. apply strict_subset_diff_incl => //. From 5b24205dd75a8d18e2a817bc83014337304adb21 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 26 Aug 2025 18:05:26 +0200 Subject: [PATCH 019/164] Simplify --- template-rocq/theories/PartialLoopChecking.v | 38 ++++++++++---------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 78e4d3847..d3a854209 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -2727,27 +2727,27 @@ Definition entails_clauses cls cl := Definition loop_on_univ cls prems := entails_clauses cls (to_clauses prems (succ_prems prems)). -Definition loop_on W (hne : ~ LevelSet.Empty W) cls := - cls ⊢a of_level_set W (max_clause_premise cls) hne → of_level_set W (max_clause_premise cls + 1) hne. +Definition loop_on W (hne : ~ LevelSet.Empty W) n cls := + cls ⊢a of_level_set W n hne → of_level_set W (n + 1) hne. -Lemma loop_on_proper W W' hne' cls : W =_lset W' -> exists hne, loop_on W hne cls -> loop_on W' hne' cls. +Lemma loop_on_proper W W' n hne' cls : W =_lset W' -> exists hne, loop_on W hne n cls -> loop_on W' hne' n cls. Proof. intros eq; rewrite /loop_on /loop_on_univ. assert (hne : ~ LevelSet.Empty W). now rewrite eq. exists hne. - assert (of_level_set W (max_clause_premise cls) hne = of_level_set W' (max_clause_premise cls) hne') as ->. + assert (of_level_set W n hne = of_level_set W' n hne') as ->. apply eq_univ'. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. - assert (of_level_set W (max_clause_premise cls + 1) hne = of_level_set W' (max_clause_premise cls + 1) hne') as ->. + assert (of_level_set W (n + 1) hne = of_level_set W' (n + 1) hne') as ->. apply eq_univ'. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. by []. Qed. -Lemma loop_on_subset {W hne cls cls'} : Clauses.Subset cls cls' -> loop_on W hne cls -> loop_on W hne cls'. +Lemma loop_on_subset {W hne n cls cls'} : Clauses.Subset cls cls' -> loop_on W hne n cls -> loop_on W hne n cls'. Proof. Admitted. Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := - | Loop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne cls) + | Loop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) n (islooping : loop_on w hne n cls) | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). Arguments Loop {V U cls m}. Arguments Model {V U cls m}. @@ -2756,7 +2756,7 @@ Arguments lexprod {A B}. Definition option_of_result {V U m cls} (r : result V U m cls) : option model := match r with | Model w m _ => Some m.(model_model) - | Loop w hne isloop => None + | Loop w hne _ isloop => None end. Notation "#| V |" := (LevelSet.cardinal V). @@ -3739,14 +3739,14 @@ Section InnerLoop. by wf (measure W cls m) lt := inner_loop_partition m upd with loop W LevelSet.empty premconclW m m _ _ := { (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) - | Loop W ne isl => Loop W ne (loop_on_subset _ isl) + | Loop W ne n isl => Loop W ne n (loop_on_subset _ isl) (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). By invariant Wr ⊂ W *) | Model Wr mr empWr with inspect (check_model conclW (Wr, model_model mr)) := { | exist None eqm => Model Wr {| model_model := model_model mr |} _ | exist (Some (Wconcl, mconcl)) eqm with inner_loop_partition mconcl _ := { (* Here Wr ⊂ Wconcl by invariant *) - | Loop W ne isl => Loop W ne isl + | Loop W ne n isl => Loop W ne n isl | Model Wr' mr' UWconcl => Model (LevelSet.union Wconcl Wr') {| model_model := model_model mr' |} _ } (* Here Wr' ⊂ W by invariant *) (* We check if the new model [mr] for (cls ⇂ W) extends to a model of (cls ↓ W). *) @@ -4935,18 +4935,18 @@ Lemma strictly_updates_entails_loop2 cls V (hne : ~ LevelSet.Empty V) mzero m : let bound := v_minus_w_bound V m in let maxgain := max_gain cls in let n := Z.to_nat bound + maxgain in - max_premise_model cls clauses_levels mzero -> V =_lset clauses_levels cls -> total_model_of V mzero -> strictly_updates cls V mzero m -> entails_all cls (of_level_set V n hne) (of_level_set V (n + 1) hne). Proof. - intros bound maxgain n maxp vincl tot su. + intros bound maxgain n vincl tot su. have nemzero : ~ LevelMap.Empty mzero. { have := not_empty_exists V hne => [[l]]. now move/tot => [v hm] /(_ _ _ hm). } have nem := strictly_updates_non_empty_map su. eapply strictly_updates_strenghten in su. + eapply strictly_updates_entails in su. set (m' := new_model mzero V (Some (Z.of_nat n))). have [m'' su'] : exists m'', strictly_updates (cls ⇂ V) V m' m''. admit. @@ -4958,7 +4958,7 @@ Proof. (* have sue := strictly_updates_entails nem' nem'' _ su'. *) (* forward sue. admit. apply sue in su'. (cls ⇂ V). in su'; tea *) -Abort. +Admitted. Lemma model_max_max_premise_map cls : Z.to_nat (model_max (max_premise_map cls)) = max_clause_premise cls. @@ -5162,23 +5162,23 @@ Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : mod loop V U cls minit m prf with inspect (check_model cls (U, m)) := | exist None eqm => Model U {| model_model := m |} _ | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { - | exist true eq := Loop W (check_model_ne eqm) _ + | exist true eq := Loop W (check_model_ne eqm) (Z.to_nat (v_minus_w_bound W m') + max_gain cls) _ (* Loop on cls ↓ W, with |W| < |V| *) | exist false neq with inner_loop V U minit loop W (cls ↓ W) m' _ := - { | Loop W' ne isloop := Loop W' ne (loop_on_subset _ isloop) + { | Loop W' ne n isloop := Loop W' ne n (loop_on_subset _ isloop) | Model Wc mwc _ (* We get a model for (cls ↓ W), we check if it extends to all clauses. By invariant |Wc| cannot be larger than |W|. *) with inspect (check_model cls (Wc, mwc.(model_model))) := { | exist None eqm' => Model (LevelSet.union W Wc) {| model_model := mwc.(model_model) |} _ | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { - | exist true _ := Loop Wcls (check_model_ne eqm') _ + | exist true _ := Loop Wcls (check_model_ne eqm') (Z.to_nat (v_minus_w_bound Wcls mcls) + max_gain cls) _ | exist false neq' with loop V (LevelSet.union W Wcls) cls minit mcls _ := { (* Here Wcls < V, we've found a model for all of the clauses with conclusion in W, which can now be fixed. We concentrate on the clauses whose conclusion is different. Clearly |W| < |V|, but |Wcls| is not necessarily < |V| *) - | Loop W' ne isloop := Loop W' ne isloop + | Loop W' ne n isloop := Loop W' ne n isloop | Model Wvw mcls' hsub := Model Wvw {| model_model := model_model mcls' |} _ } } } } } @@ -5193,10 +5193,10 @@ Proof. set (prf := check_model_ne eqm); clearbody prf. eapply check_model_is_update_of in eqm; tea. rewrite eq in eqm. destruct eqm as [eqm incl]. rewrite union_idem in eqm. + set (n := Z.to_nat _ + _). (* eapply entails_all_clauses_subset; tea. eapply entails_of_level_set_strenghten with (max_clause_premise cls). admit. *) - eapply strictly_updates_entails_loop with minit m'. - + apply todo. + eapply strictly_updates_entails_loop2. + rewrite eq. intros x. eapply strictly_updates_incl in eqm. split. 2:apply clsV. now move/eqm/clauses_conclusions_levels. From 2719bfa2d3b25c157f5c93d1374421db6b133d5e Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 27 Aug 2025 15:11:25 +0200 Subject: [PATCH 020/164] Before Switch back to a total model --- template-rocq/theories/PartialLoopChecking.v | 471 ++++++++++++++----- 1 file changed, 346 insertions(+), 125 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index d3a854209..22c4099e0 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -688,7 +688,7 @@ Definition valid_clause (m : model) (cl : clause) := | None => true | Some k0 => let (l, k) := concl cl in - level_value_above m l (Z.of_nat k + k0) + (k0 None | Some k0 => + if k0 Some ((LevelSet.union (LevelSetProp.of_list l) wm.1), m) end. +Infix "=m" := LevelMap.Equal (at level 50). + Definition strict_update m '(prems, (l, k)) m' := - exists v, min_premise m prems = Some v - /\ ~~ level_value_above m l (Z.of_nat k + v) /\ - LevelMap.Equal m' (LevelMap.add l (Some (Z.of_nat k + v)) m). + exists v, + [/\ min_premise m prems = Some v, (0 <= v)%Z, ~~ level_value_above m l (Z.of_nat k + v) & + m' =m (LevelMap.add l (Some (Z.of_nat k + v)) m)]. Inductive strictly_updates cls : LevelSet.t -> model -> model -> Prop := | update_one m cl m' : Clauses.In cl cls -> @@ -889,12 +892,14 @@ Proof. split. induction 1 in y, H, y1, H'', y2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. now rewrite <- H. move: H1; unfold strict_update. destruct cl as [premse []]. + intros [v []]; exists v; split; try setoid_rewrite <- H; try setoid_rewrite <- H''; try setoid_rewrite <- H'''; firstorder. eapply IHstrictly_updates1; firstorder. firstorder. induction 1 in x, H, x1, H'', x2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. now rewrite H. move: H1; unfold strict_update. destruct cl as [premse []]. + intros [v []]; exists v; split; try setoid_rewrite H; try setoid_rewrite H''; try setoid_rewrite H'''; firstorder. @@ -911,7 +916,8 @@ Proof. unfold update_value, valid_clause. destruct cl as [prem [l k]]; cbn. destruct min_premise => //. - unfold level_value_above. + destruct Z.ltb; + unfold level_value_above; destruct level_value => //. destruct Z.leb => //. Qed. @@ -932,6 +938,7 @@ Proof. move: upd. unfold update_value. destruct cl as [prems [concl k]]. cbn. destruct min_premise => //. + elim: Z.ltb_spec => // leq. destruct level_value_above eqn:hl => //. intros [= <-]. exists z. split => //. rewrite hl. split => //. @@ -1004,8 +1011,9 @@ Lemma strict_update_invalid m cl m' : strict_update m cl m' -> ~~ valid_clause m Proof. destruct cl as [prems [concl k]]. cbn. - intros [v [him [hna heq]]]. - rewrite /valid_clause. rewrite him //= hna. + intros [v [him hlt hna heq]]. + rewrite /valid_clause. rewrite him //=. + elim: Z.ltb_spec => //. lia. Qed. Lemma strictly_updates_invalid cls w m m' : strictly_updates cls w m m' -> ~~ is_model cls m. @@ -1056,7 +1064,7 @@ Proof. induction 1. - intros he. specialize (he (clause_conclusion cl)). destruct cl as [prems [concl k]]. - destruct H0 as [? [? [? heq]]]. + destruct H0 as [? [? ? ? heq]]. setoid_rewrite heq in he. eapply (he (Some (Z.of_nat k + x))); cbn. rewrite LevelMapFact.F.add_mapsto_iff. firstorder. - intros he. now apply IHstrictly_updates2. @@ -1381,6 +1389,7 @@ Proof. unfold update_value, valid_clause. destruct cl as [prem [l k]]; cbn. destruct min_premise => //. + destruct Z.ltb => //. unfold level_value_above. destruct level_value => //. destruct Z.leb => //. @@ -1461,7 +1470,7 @@ Lemma strict_update_ext m cl m' : strict_update m cl m' -> m ⩽ m'. Proof. destruct cl as [prems [concl k]]. unfold strict_update. - intros [v [hm [ha heq]]]. + intros [v [hm hlt ha heq]]. intros x k' hin. setoid_rewrite heq. setoid_rewrite LevelMapFact.F.add_mapsto_iff. destruct (Level.eq_dec concl x). subst. @@ -1471,7 +1480,7 @@ Proof. split. left. split; reflexivity. destruct k' => //; constructor. move: ha. - rewrite -Z.ltb_antisym => /Z.ltb_lt hlt. lia. + rewrite -Z.ltb_antisym => /Z.ltb_lt. lia. exists k'. split => //. right; eauto. reflexivity. Qed. @@ -2037,6 +2046,9 @@ Qed. Definition total_model_of V (m : model) := forall k, LevelSet.In k V -> exists x, LevelMap.MapsTo k (Some x) m. +Definition only_model_of V (m : model) := + forall k, LevelSet.In k V <-> exists x, LevelMap.MapsTo k (Some x) m. + Definition check_model_invariants cls w m w' m' (modified : bool) := if modified then [/\ w ⊂_lset w', @@ -2307,7 +2319,7 @@ Proof. Qed. *) -Lemma strict_update_outside w m m' m'' cl : +(* Lemma strict_update_outside w m m' m'' cl : m ⩽ m' -> m' ⩽ m'' -> model_map_outside w m m' -> enabled_clause m cl -> @@ -2317,13 +2329,15 @@ Proof. apply wout in nout. destruct cl as [prems [concl k]]. unfold strict_update. - intros [v [minv []]]. + intros [v [minv ]]. cbn in nout. - unfold enabled_clause in enabled. cbn in enabled. destruct min_premise eqn:hmin => //. exists z; split=> //. + unfold enabled_clause in enabled. cbn in enabled. destruct min_premise eqn:hmin => //. + + exists z; split=> //. split => //. have hp := (min_premise_pres prems mext). rewrite hmin minv in hp. depelim hp. (* 2:{ eapply level_value_above_mon; tea. eapply level_value_above_MapsTo'; tea. rewrite -nout. } *) - Abort. + Abort. *) Definition model_of V (m : model) := forall k, LevelSet.In k V -> LevelMap.In k m. @@ -2454,6 +2468,7 @@ Proof. (* case: Z.ltb_spec => // hprem. *) destruct cl as [prem [l k]]; cbn. destruct min_premise eqn:hmin => //. + elim: Z.ltb_spec => // hle. move/negbTE/level_value_not_above_spec => hlt hin. have hne := (non_W_atoms_ne _ _ _ hin). cbn. unfold measure_w. unfold gain. @@ -2868,7 +2883,7 @@ Proof. induction 1. - intros W' tot x. destruct cl as [prems [concl cl]]. - destruct H0 as [minv [hmin []]]. setoid_rewrite H1. + destruct H0 as [minv [hmin ? ? heq]]. setoid_rewrite heq. setoid_rewrite LevelMapFact.F.add_mapsto_iff. cbn. destruct (Level.eq_dec concl x). { subst. exists (Z.of_nat cl + minv). now left. } @@ -2930,7 +2945,7 @@ Lemma strict_update_modify m cl m' : strict_update m cl m' -> Proof. rewrite /strict_update. destruct cl as [prems [concl k]]. - intros [v [hmin [hab eq]]]. now exists (Z.of_nat k + v). + intros [v [hmin hlt hab eq]]. now exists (Z.of_nat k + v). Qed. Lemma strictly_updates_model_of_gen {cls W m m'} : @@ -3032,7 +3047,7 @@ Proof. * exists cl. split => //. now eapply strict_update_invalid. unfold clause_conclusion. lsets. destruct cl as [prems [concl k]]. - destruct H0 as [minp [hin [hnabove habove]]]. + destruct H0 as [minp [hin hlt hnabove habove]]. move: hnabove habove. rewrite /level_value_above. cbn. destruct level_value eqn:hv => //; try constructor. intros hle. intros ->. rewrite level_value_add. constructor. @@ -3047,7 +3062,7 @@ Proof. clear -mof su. induction su. * move: H0; unfold strict_update. destruct cl as [prems [concl k]]. - intros [v [hmi [nabove eqm]]]. intros l. rewrite eqm. + intros [v [hmi hlt nabove eqm]]. intros l. rewrite eqm. rewrite LevelMapFact.F.add_in_iff. specialize (mof l). rewrite clauses_conclusions_spec in mof. firstorder. * specialize (IHsu1 mof). transitivity m' => //. @@ -3246,6 +3261,9 @@ Qed. Lemma clauses_with_concl_subset cls W : (cls ↓ W) ⊂_clset cls. Proof. now intros ?; rewrite in_clauses_with_concl. Qed. +Ltac rw l := rewrite_strat (topdown l). +Ltac rw_in l H := rewrite_strat (topdown l) in H. + Section InnerLoop. Definition sum_W W (f : LevelSet.elt -> nat) : nat := LevelSet.fold (fun w acc => acc + f w)%nat W 0%nat. @@ -3285,6 +3303,7 @@ Section InnerLoop. unfold valid_clause. destruct min_premise as [k0|] eqn:hk0 => //. destruct cl as [prem [l k]] => /=. cbn in hk0. + elim: Z.ltb_spec => //= ge. rewrite /clsdiff in hl. destruct (proj1 (Clauses.diff_spec _ _ _) hl) as [hlcls hl']. eapply in_clauses_with_concl in hlcls as [lW incls]. @@ -3613,6 +3632,112 @@ Section InnerLoop. eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. Qed. + Definition restrict_model W (m : model) := + LevelMapFact.filter (fun l k => LevelSet.mem l W) m. + + Lemma restrict_model_spec W m : + forall l k, LevelMap.MapsTo l k (restrict_model W m) <-> LevelMap.MapsTo l k m /\ LevelSet.In l W. + Proof. + intros l k; rewrite /restrict_model. + now rewrite LevelMapFact.filter_iff LevelSet.mem_spec. + Qed. + + (* Updates the entries in m with the values in m' if any *) + Definition model_update (m m' : model) : model := + LevelMap.mapi (fun l k => + match LevelMap.find l m' with + | Some k' => k' + | None => k + end) m. + + Inductive findSpec l m : option (option Z) -> Prop := + | inm k : LevelMap.MapsTo l k m -> findSpec l m (Some k) + | ninm : ~ LevelMap.In l m -> findSpec l m None. + + Lemma find_spec l m : findSpec l m (LevelMap.find l m). + Proof. + destruct (LevelMap.find l m) eqn:heq; constructor. + now apply LevelMap.find_2. + now apply LevelMapFact.F.not_find_in_iff in heq. + Qed. + + Lemma model_update_spec m m' : + forall l k, LevelMap.MapsTo l k (model_update m m') <-> + (~ LevelMap.In l m' /\ LevelMap.MapsTo l k m) \/ + (LevelMap.MapsTo l k m' /\ LevelMap.In l m). + Proof. + intros l k; split. + - unfold model_update => hl. + eapply LevelMapFact.F.mapi_inv in hl as [a [k' [-> [eqk mt]]]]. + move: eqk; elim: (find_spec l m'). + + intros ? hm <-. right; split => //. now exists a. + + intros nin ->. left. split => //. + - intros [[nin hm]|[inm' inm]]. + * eapply LevelMapFact.F.mapi_mapsto_iff. now intros x y e ->. + elim: (find_spec l m'). + + intros k0 hm'. elim nin. now exists k0. + + intros _. exists k. split => //. + * eapply LevelMapFact.F.mapi_mapsto_iff. now intros x y e ->. + elim: (find_spec l m'). + + intros k0 hm'. destruct inm as [a inm]. exists a. split => //. + now eapply LevelMapFact.F.MapsTo_fun in inm'; tea. + + intros nin; elim nin. now exists k. + Qed. + + Lemma model_update_restrict m W : model_update m (restrict_model W m) =m m. + Proof. + apply LevelMapFact.F.Equal_mapsto_iff. intros l k. + rewrite model_update_spec. + split => //. + - intros [[nin hk]|[hr inm]] => //. + now eapply restrict_model_spec in hr. + - intros hm. + destruct (find_spec l (restrict_model W m)). + + right. apply restrict_model_spec in H as [hm' hw]. + split. eapply LevelMapFact.F.MapsTo_fun in hm; tea. subst. apply restrict_model_spec; split => //. + now exists k. + + left. split => //. + Qed. + + Lemma min_premise_restrict m W prems v : min_premise (restrict_model W m) prems = Some v -> + min_premise m prems = Some v. + Proof. Admitted. + + (* If we can update starting from a restricted model with no values outside [W], + this can be lifted to the unrestricted model, applying the same updates *) + Lemma strictly_updates_restrict_model cls W W' m m' : + strictly_updates cls W' (restrict_model W m) m' -> + strictly_updates cls W' m (model_update m m'). + Proof. + intros H; depind H. + - constructor. auto. + destruct cl as [prems [concl k]]. + destruct H0 as [v [hmin hlt above heq]]. + exists v. split => //. + now eapply min_premise_restrict. + move: above. + rewrite /level_value_above /level_value. + elim: find_spec => //. + + intros kr hkr. destruct kr => //. + apply restrict_model_spec in hkr as [hkr hcl]. + now rewrite (LevelMap.find_1 hkr). + intros _. + elim: find_spec => // km hkm. + destruct km => //. + Admitted. + + Lemma strictly_updates_is_update_of_restrict cls W init m cls' W' m' : + strictly_updates cls W init m -> + is_update_of cls' W' (restrict_model W m) m' -> + strictly_updates (Clauses.union cls cls') (LevelSet.union W W') init (model_update m m'). + Proof. + move=> su /is_update_of_case; intros [[empw eq]|su']. + - subst m'. eapply (strictly_updates_weaken cls). clsets. + rewrite model_update_restrict. + eapply strictly_updates_W_eq; tea. lsets. + - eapply strictly_updates_restrict_model in su'. + eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. + Qed. Lemma union_with_concl cls W : Clauses.Equal (Clauses.union cls (cls ↓ W)) cls. Proof. @@ -3721,9 +3846,10 @@ Section InnerLoop. - lia. Qed. + Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) (loop : forall (V' U' : LevelSet.t) (cls' : clauses) (minit m : model) - (prf : [/\ clauses_levels cls' ⊂_lset V', total_model_of V' minit & + (prf : [/\ clauses_levels cls' ⊂_lset V', only_model_of V' minit & is_update_of cls' U' minit m]), lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls' minit). @@ -3737,12 +3863,12 @@ Section InnerLoop. Equations? inner_loop_partition (m : model) (upd : strictly_updates cls W init_model m) : result W LevelSet.empty cls m by wf (measure W cls m) lt := - inner_loop_partition m upd with loop W LevelSet.empty premconclW m m _ _ := { + inner_loop_partition m upd with loop W LevelSet.empty premconclW (restrict_model W m) (restrict_model W m) _ _ := { (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) | Loop W ne n isl => Loop W ne n (loop_on_subset _ isl) (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). By invariant Wr ⊂ W *) - | Model Wr mr empWr with inspect (check_model conclW (Wr, model_model mr)) := { + | Model Wr mr empWr with inspect (check_model conclW (Wr, model_update m (model_model mr))) := { | exist None eqm => Model Wr {| model_model := model_model mr |} _ | exist (Some (Wconcl, mconcl)) eqm with inner_loop_partition mconcl _ := { (* Here Wr ⊂ Wconcl by invariant *) @@ -3764,7 +3890,9 @@ Section InnerLoop. all:try rewrite eqconcl in eqm. - split => //. * rewrite eqprem. apply clauses_levels_restrict_clauses. - * eapply (strictly_updates_total_model upd). + * red. intros. rw restrict_model_spec. split => //. 2:clear; firstorder. + eapply strictly_updates_total_model in upd. move/[dup]/upd. clear; firstorder. + (* * eapply (strictly_updates_total_model upd). *) (* * rewrite eqprem. transitivity cls => //. apply restrict_clauses_subset. *) (* * eapply strictly_updates_weaken in upd; tea. eapply above_max_premise_model_trans in maxp; tea. *) * eapply is_update_of_empty. @@ -4015,7 +4143,7 @@ Proof. - intros mv l hin. apply mv in hin. red in hcls. setoid_rewrite clauses_conclusions_spec in hcls. destruct cl as [prems [concl k]]. - destruct H0 as [minv [eqmin [nabove eqm]]]. rewrite eqm. + destruct H0 as [minv [eqmin hlt nabove eqm]]. rewrite eqm. specialize (hcls concl). forward hcls. exists (prems, (concl, k)). split => //. rewrite LevelMapFact.F.add_in_iff. now right. - eauto. @@ -4029,7 +4157,7 @@ Proof. induction su. - intros W' mv l hin. apply mv in hin. destruct cl as [prems [concl k]]. - destruct H0 as [minv [eqmin [nabove eqm]]]. setoid_rewrite eqm. + destruct H0 as [minv [eqmin hlt nabove eqm]]. setoid_rewrite eqm. setoid_rewrite LevelMapFact.F.add_mapsto_iff. red in mv. destruct (eq_dec concl l). @@ -4066,7 +4194,7 @@ Proof. - intros l k hin hm. move: H0; rewrite /strict_update. destruct cl as [prems [concl gain]]. - move=> [] v [] minp []. cbn in hin. eapply LevelSet.singleton_spec in hin. red in hin; subst l. + move=> [] v [] minp hlt. cbn in hin. eapply LevelSet.singleton_spec in hin. red in hin; subst l. move/negbTE; rewrite /level_value_above. intros hle eq. setoid_rewrite eq. eexists. setoid_rewrite LevelMapFact.F.add_mapsto_iff. split; [left;split;eauto|] => //. @@ -4464,9 +4592,6 @@ Proof. eapply (entails_pred_closure_n (n:=k0)). constructor. now apply LevelExprSet.singleton_spec. Qed. -Ltac rw l := rewrite_strat (topdown l). -Ltac rw_in l H := rewrite_strat (topdown l) in H. - Lemma entails_all_concl_union {cls prems concl concl'} : cls ⊢a prems → concl -> cls ⊢a prems → concl' -> @@ -4571,7 +4696,7 @@ Proof. intros su; induction su. - intros htot l. split; revgoals. { intros nin k. destruct cl as [prems [concl conclk]]; cbn in *. - destruct H0 as [minp [hmin [nabove hm']]]. + destruct H0 as [minp [hmin hlt nabove hm']]. rewrite hm'. rewrite LevelMapFact.F.add_mapsto_iff. assert (concl <> l). intros ->. apply nin, in_singleton. @@ -4580,7 +4705,7 @@ Proof. red in htot. specialize (htot (clause_conclusion cl) (in_singleton _)) as [mconcl mt]. destruct cl as [prems [concl conclk]]; cbn in *. - destruct H0 as [minp [hmin [nabove hm']]]. + destruct H0 as [minp [hmin hlt nabove hm']]. eapply LevelSet.singleton_spec in inv; red in inv; subst l. eapply LevelMapFact.F.MapsTo_fun in hin; tea. noconf hin. exists (Z.of_nat conclk + minp)%Z. split => //. @@ -4635,7 +4760,7 @@ Definition hyps_map (hyps : univ) m := Lemma model_hyps_entails cls m hyps (prems : univ) concl : Clauses.In (prems, concl) cls -> - (forall l : Level.t, LevelSet.In l (clauses_premises_levels cls) -> Some (Z.of_nat 0) ≤ level_value m l) -> + (forall l k, LevelExprSet.In (l,k) prems -> Some (Z.of_nat 0) ≤ level_value m l) -> hyps_map hyps m -> cls ⊢a hyps → premise_values prems m. Proof. @@ -4644,10 +4769,7 @@ Proof. rewrite premise_values_spec in hin. destruct hin as [k' [inp ->]]. red in hm. constructor. rewrite hm. - specialize (hmx l). - forward hmx. - { rewrite clauses_premises_levels_spec. exists (prems, concl); split => //. cbn. - eapply levelexprset_levels_spec. now exists k'. } + specialize (hmx l _ inp). depelim hmx. rewrite H0 //=. rewrite Z2Nat.id. lia. now eapply level_value_MapsTo'. Qed. @@ -4663,17 +4785,18 @@ Proof. now constructor. Qed. - Lemma hyps_entails (hyps : univ) m cls : - forall (hmz : forall l : Level.t, LevelSet.In l (clauses_premises_levels cls) -> Some (Z.of_nat 0) ≤ level_value m l), (forall (l : Level.t) (k : nat), LevelExprSet.In (l, k) hyps <-> LevelMap.MapsTo l (Some (Z.of_nat k)) m) -> forall prems conclk, Clauses.In (prems, conclk) cls -> forall v, min_premise m prems = Some (Z.of_nat v) -> cls ⊢a hyps → add_prems v prems. Proof. - intros hmz H prems conclk H0 v H1. + intros H prems conclk H0 v H1. have [minsleq mineq] := min_premise_spec m prems. destruct mineq as [[minprem minpremk] [inprems eqminp]]. cbn. + have hmz' : forall l k, LevelExprSet.In (l, k) prems -> Some (Z.of_nat 0) ≤ level_value m l. + { intros l k hin. specialize (minsleq _ hin). rewrite H1 in minsleq. cbn in minsleq. destruct level_value => //. + depelim minsleq. constructor. lia. depelim minsleq. } move: eqminp. rewrite /min_atom_value. destruct level_value eqn:hl. intros hminp. 2:{ now rewrite H1. } @@ -4686,18 +4809,11 @@ Proof. intros [[prem premk] [inprem [= -> ->]]]. rw premise_values_spec. eexists. split. exists premk. split => //. - have hmz' := hmz prem. forward hmz'. - { rewrite clauses_premises_levels_spec. eexists; split => //. exact H0. cbn. - eapply levelexprset_levels_spec. now eexists. } - depelim hmz'. rewrite H4 //=. clear H3. + have hmz'' := hmz' prem _ inprem. + depelim hmz''. rewrite H4 //=. clear H3. assert (v = Z.to_nat z - minpremk). lia. subst v. specialize (minsleq _ inprem). cbn in minsleq. rewrite H4 in minsleq. - rewrite H1 in minsleq. depelim minsleq. - have hmzz := hmz minprem. forward hmzz. - { rewrite clauses_premises_levels_spec. eexists. split. eassumption. cbn. - eapply levelexprset_levels_spec. now eexists. } - rewrite hl in hmzz. depelim hmzz. clear H5. - lia. + rewrite H1 in minsleq. depelim minsleq. lia. Qed. Definition model_above cls m := forall l, @@ -4725,13 +4841,12 @@ Lemma max_premise_model_above cls m : max_premise_model cls clauses_levels m -> Admitted. Lemma strictly_updates_entails {cls V mzero m} (hne : ~ LevelMap.Empty mzero) (hne' : ~ LevelMap.Empty m) : - model_above cls mzero -> strictly_updates cls V mzero m -> entails_all cls (of_level_map mzero hne) (of_level_map m hne'). Proof. - intros hmz su; induction su. + intros su; induction su. - destruct cl as [prems [concl k]]. - destruct H0 as [minp [hmin [nabove eqm']]]. + destruct H0 as [minp [hmin hlt nabove eqm']]. have [minsleq mineq] := min_premise_spec m prems. destruct mineq as [minprem [inprems eqminp]]. cbn. move: eqminp. rewrite /min_atom_value. @@ -4743,15 +4858,6 @@ Proof. rewrite LevelMapFact.F.add_mapsto_iff in hin. destruct hin as [[eq heq]|[neq hm]]. red in eq. subst l. noconf heq. - have minp_pos : (z - Z.of_nat mink >= 0)%Z. - { have hmz' := model_above_infers hmz. forward (hmz' minprem). - eapply clauses_premises_levels_incl. eapply clauses_premises_levels_spec. eexists; split; eauto. cbn. - eapply levelexprset_levels_spec. now eexists. red in hmz'. - rewrite hminprem in hmz'. depelim hmz'. - have := max_clause_premise_spec (prems, (concl, k)) cls H. - cbn. - have [] := premise_max_spec prems => /(_ _ inprems) //= lemax _. - lia. } assert (k + (Z.to_nat z - mink) = k'). lia. subst k'. clear H0. have hypss := of_level_map_spec m hne. set (hyps := of_level_map m hne) in *. clearbody hyps. @@ -4763,17 +4869,11 @@ Proof. destruct H0 as [z2 ->]. rename z2 into z. rewrite -hypss in hminprem. rewrite -> Nat2Z.id in *. eapply hyps_entails; tea. - have hmz' := model_above_infers hmz. - { move=> l /clauses_premises_levels_incl hl. apply hmz' in hl. red in hl. - depelim hl. rewrite H1; constructor. lia. } rewrite hmin. lia_f_equal. constructor. now rewrite of_level_map_spec. - have hnemid : ~ LevelMap.Empty m'. by exact: strictly_updates_non_empty_map su1. specialize (IHsu1 hne hnemid). specialize (IHsu2 hnemid hne'). - forward IHsu1. auto. - forward IHsu2. - { eapply model_above_update; tea. } eapply entails_all_trans; tea. Qed. @@ -4869,8 +4969,6 @@ Proof. eapply (strictly_updates_entails nemzero nem) in su; tea. unshelve erewrite of_level_map_of_level_set in su; tea. move/entails_all_trans: su; apply. - 2:{ now apply max_premise_model_above. } - (* right. have me := (max_premise_model_exists cls). eapply max_premise_model_unique in maxp; tea. } *) apply: entails_succ => l k. rewrite levelexprset_of_levels_spec => [[hin ->]]. rw of_level_map_spec. @@ -4888,6 +4986,41 @@ Proof. Qed. +Lemma strictly_updates_entails_loop_above_max cls V (hne : ~ LevelSet.Empty V) mzero m : + above_max_premise_model cls mzero -> + V =_lset clauses_levels cls -> + total_model_of V mzero -> + strictly_updates cls V mzero m -> + entails_all cls (of_level_set V (max_clause_premise cls) hne) + (of_level_set V (max_clause_premise cls + 1) hne). +Proof. + move=> habove hv tot su. + destruct habove as [[V' ha]|eq]. + * apply (strictly_updates_entails_loop cls V hne (max_premise_map cls) m); tea. + - apply max_premise_model_exists. + - have [hs hs'] := max_premise_model_exists cls. red. + intros k hm. rewrite hv in hm. specialize (hs _ hm). now eexists. + - have tr := strictly_updates_trans ha su. rewrite union_idem in tr. + eapply strictly_updates_incl in ha. + assert (V' ∪ V = V). + { apply LevelSet.eq_leibniz. red. + rewrite hv. move: (clauses_conclusions_levels cls). lsets. } + now rewrite H in tr. + * subst mzero. + eapply strictly_updates_entails_loop; tea. + apply max_premise_model_exists. +Qed. + +Lemma entails_all_shift {cls : clauses} {prems concl : univ} (n : nat) : + cls ⊢a prems → concl -> + cls ⊢a add_prems n prems → add_prems n concl. +Proof. + intros cla cl. + rewrite In_add_prems => [[le' [hin ->]]]. + eapply (entails_shift (cl := (prems, le'))). + now apply cla in hin. +Qed. + Lemma in_pred_closure_subset {cls cls' prems concl} : in_pred_closure cls (prems, concl) -> cls ⊂_clset cls' -> @@ -4919,6 +5052,36 @@ Proof. intros d incl [l k]. now move/d/entails_clauses_subset. Qed. +(* +Lemma strictly_updates_restrict cls V m m' : + strictly_updates cls V m m' -> + (forall cl, Clauses.In cl (cls_diff cls V) -> valid_clause m cl) -> + strictly_updates (cls ⇂ V) V m m'. +Proof. + induction 1. + - intros hcl. constructor; auto. + move: {hcl} (hcl cl). + rewrite Clauses.diff_spec in_clauses_with_concl in_restrict_clauses. + destruct cl as [prems [concl k]]; cbn. + move=> h. split => //. eapply in_singleton. + forward h. + { split. split => //. apply in_singleton. + intros [insing hle incl']. + assert (~ LevelSet.Empty (levels prems)). admit. + have eqc : (forall l, LevelSet.In l (levels prems) -> l = concl). + { move=> l /hle. now rewrite LevelSet.singleton_spec. } + move: H0; rewrite /valid_clause //=. + intros [v [hmin hlt la eqm]]. + destruct min_premise eqn:hm => //. + have [minple [minprem [inprems eqm]]] := min_premise_spec m prems. + + + assert (LevelSet.Equal (levels prems) (LevelSet.singleton concl)). split => //. lsets. + rewrite LevelSet.singleton_spec => ->. destruct (LevelSet.choose (levels prems)) eqn:hc. + apply LevelSet.choose_spec1 in hc. apply hle in hc. apply LevelSet.singleton_spec in hc; red in hc; subst. + +*) + Definition new_model m V newk : model := LevelMap.fold (fun l k acc => @@ -4931,23 +5094,56 @@ Lemma new_model_spec m V newk l k : if LevelSet.mem l V then k = newk else k = k'). Proof. Admitted. +Definition domain (l : LevelMap.t (option Z)) : LevelSet.t := + LevelSetProp.of_list (List.map fst (LevelMap.elements l)). + +Lemma level_value_new_model {m V newk l} : + total_model_of V m -> + level_value (new_model m V newk) l = + if LevelSet.mem l V then newk else level_value m l. +Admitted. + Lemma strictly_updates_entails_loop2 cls V (hne : ~ LevelSet.Empty V) mzero m : let bound := v_minus_w_bound V m in let maxgain := max_gain cls in let n := Z.to_nat bound + maxgain in - V =_lset clauses_levels cls -> + (* V =_lset clauses_levels cls -> *) total_model_of V mzero -> strictly_updates cls V mzero m -> entails_all cls (of_level_set V n hne) (of_level_set V (n + 1) hne). Proof. - intros bound maxgain n vincl tot su. + intros bound maxgain n tot su. have nemzero : ~ LevelMap.Empty mzero. { have := not_empty_exists V hne => [[l]]. now move/tot => [v hm] /(_ _ _ hm). } have nem := strictly_updates_non_empty_map su. - eapply strictly_updates_strenghten in su. - eapply strictly_updates_entails in su. - set (m' := new_model mzero V (Some (Z.of_nat n))). + (* eapply strictly_updates_strenghten in su. *) + (* unshelve eapply strictly_updates_entails in su; tea. *) + set (m' := new_model m V (Some (Z.of_nat n))). + set (d := LevelSet.diff (domain mzero) V). + have vm : is_model (cls ↓ d) m'. + { eapply Clauses.for_all_spec. tc. intros cl hin. + unfold valid_clause. destruct min_premise eqn:hmin => //. + destruct cl as [prems [concl k]]. cbn in *. + elim: Z.ltb_spec => // ge //=. unfold level_value_above. + destruct level_value eqn:hl => //. eapply level_value_MapsTo' in hl. + apply new_model_spec in hl as [k' [hm cond]]. + destruct LevelSet.mem eqn:hmem. noconf cond. admit. subst k'. + have [minple minpeq] := min_premise_spec m' prems. + destruct minpeq as [[minpl minpk] [inminp mineq]]. + destruct (inLevelSet V minpl). + 3:{ admit. } + (* clause has its minimal premise in V which might have been updated in m. + In m' its value is hence n *) + unfold min_atom_value in mineq. + rewrite level_value_new_model in mineq => //. now eapply strictly_updates_total_model. + rewrite (LevelSetFact.mem_1 H) in mineq. + rewrite hmin in mineq. noconf mineq. + + + } + + have [m'' su'] : exists m'', strictly_updates (cls ⇂ V) V m' m''. admit. have mp := strictly_updates_model_lt su'. @@ -4986,13 +5182,21 @@ Definition of_level_map_n (m : LevelMap.t (option Z)) V n (hne : ~ LevelMap.Empt Next Obligation. Admitted. Lemma of_level_map_n_spec m V hne : - forall l n k, LevelExprSet.In (l, k) (of_level_map_n m V n hne) <-> + forall l n k, LevelExprSet.In (l, k) (of_level_map_n m V n hne) -> (exists k', LevelMap.MapsTo l (Some (Z.of_nat k')) m /\ (LevelSet.In l V -> k = n + k') /\ (~ LevelSet.In l V -> k = k')). Proof. Admitted. +Lemma of_level_map_n_spec_inv m V hne : + forall l n k, LevelMap.MapsTo l k m -> + exists k', LevelExprSet.In (l, k') (of_level_map_n m V n hne) /\ + (LevelSet.In l V -> k' = n + option_default Z.to_nat k 0%nat) /\ + (~ LevelSet.In l V -> k' = option_default Z.to_nat k 0%nat). +Proof. +Admitted. + Lemma entails_any_one V cls m nem m' nem' : total_model_of V m -> cls ⊢a of_level_map m nem → of_level_map m' nem' -> @@ -5013,11 +5217,18 @@ Lemma of_level_map_of_level_map_n m V ne : Proof. apply eq_univ'. intros [l k]. - rewrite of_level_map_spec of_level_map_n_spec. + rewrite of_level_map_spec. firstorder. - destruct (LevelSetDecide.MSetDecideAuxiliary.dec_In l V) as [hin|hnin]. - now rewrite (H0 hin). - now rewrite (H1 hnin). + - unshelve eapply (of_level_map_n_spec_inv _ V ne _ 0) in H. + destruct H as [k' [hin [inv ninv]]]. + destruct (inLevelSet V l) as [hvin|hnin]. + specialize (inv hvin). cbn in inv. subst k'. + now rewrite Nat2Z.id in hin. + specialize (ninv hnin). cbn in ninv. rewrite Nat2Z.id in ninv. now subst. + - eapply of_level_map_n_spec in H as [k' [hm [hin hnin]]]. + destruct (inLevelSet V l) as [hvin|hvnin]. + now rewrite (hin hvin). + now rewrite (hnin hvnin). Qed. Lemma entails_any V cls m nem m' nem' : @@ -5027,7 +5238,7 @@ Lemma entails_any V cls m nem m' nem' : cls ⊢a of_level_map m nem → of_level_map_n m V 1 nem. Proof. intros tot cla mp [l k]. - rewrite of_level_map_n_spec => []. + move/of_level_map_n_spec. intros [k' [hm [hin hnin]]]. destruct (LevelSetDecide.MSetDecideAuxiliary.dec_In l V). rewrite (hin H). @@ -5043,48 +5254,60 @@ Qed. cls ⊢a of_level_map_n m V 1 nem → of_level_map_n m V 2 nem. Proof. *) -Lemma strictly_updates_entails_loop_relax cls V mzero hne m : - model_above cls mzero -> - V =_lset clauses_levels cls -> +Lemma strictly_updates_entails_on_V cls V mzero hne m : total_model_of V mzero -> strictly_updates cls V mzero m -> - entails_all cls (of_level_map_n mzero V 0 hne) (of_level_map_n mzero V 1 hne). + entails_all (cls ↓ V) (of_level_map mzero hne) (of_level_map_n mzero V 1 hne). Proof. - move=> habove hv tot su. + move=> tot su. have mp := strictly_updates_model_lt su tot. - (* have nemzero : ~ LevelMap.Empty mzero. - { have := not_empty_exists V hne => [[l]]. - now move/tot => [v hm] /(_ _ _ hm). } *) have nem := strictly_updates_non_empty_map su. + eapply strictly_updates_strenghten in su. eapply (strictly_updates_entails hne nem) in su; tea. - rewrite -of_level_map_of_level_map_n. - eapply entails_any; tea. + eapply entails_any in su; tea. Qed. -Lemma strictly_updates_entails_loop_relax' cls V (hne : ~ LevelSet.Empty V) mzero m : - above_max_premise_model cls mzero -> - V =_lset clauses_levels cls -> +(* Lemma entails_concls cls V n m hne hne' : + total_model_of V m -> + entails_all cls (of_level_map_n m V n hne) (of_level_set V n hne'). +Proof. + move=> tot [l k]. + rewrite levelexprset_of_levels_spec => [] [] hin ->. + specialize (tot _ hin) as [k' hm]. + move/of_level_map_n_spec_inv in hm. + specialize (hm V hne n) as [k'' [hm [hin' hnin]]]. + specialize (hin' hin). subst k''. cbn in *. + exists + depind ent. + - move: H. + rewrite of_level_map_n_spec => [] [k' [mt [hin hnin]]]. + destruct (inLevelSet V l) as [H|H]. + * now left. + * right. apply hnin in H. now subst k'. + - specialize (IHent _ _ _ en l). + + intros [] *) + +(* +Lemma strictly_updates_entails_loop_relax cls V mzero hne m : + let bound := v_minus_w_bound V m in + let maxgain := max_gain cls in + let n := Z.to_nat bound + maxgain in total_model_of V mzero -> strictly_updates cls V mzero m -> - entails_all cls (of_level_set V (max_clause_premise cls) hne) - (of_level_set V (max_clause_premise cls + 1) hne). + entails_all cls (of_level_map_n mzero V n hne) (of_level_map_n mzero V (n + 1) hne). Proof. - move=> habove hv tot su. - destruct habove as [[V' ha]|eq]. - * apply (strictly_updates_entails_loop cls V hne (max_premise_map cls) m); tea. - - apply max_premise_model_exists. - - have [hs hs'] := max_premise_model_exists cls. red. - intros k hm. rewrite hv in hm. specialize (hs _ hm). now eexists. - - have tr := strictly_updates_trans ha su. rewrite union_idem in tr. - eapply strictly_updates_incl in ha. - assert (V' ∪ V = V). - { apply LevelSet.eq_leibniz. red. - rewrite hv. move: (clauses_conclusions_levels cls). lsets. } - now rewrite H in tr. - * subst mzero. - eapply strictly_updates_entails_loop; tea. - apply max_premise_model_exists. + move=> bound maxgain n tot su. + have mp := strictly_updates_model_lt su tot. + have nem := strictly_updates_non_empty_map su. + eapply (strictly_updates_entails hne nem) in su; tea. + eapply entails_any in su; tea. + eapply (entails_all_shift n) in su. + rewrite -of_level_map_of_level_map_n. Qed. +*) +(* Lemma of_level_map_n_split m V n hne : of_level_map_n m V n hne = of_level_set V n hne' *) + (* Lemma strictly_updates_entails_loop_relax' ocls cls V (hne : ~ LevelSet.Empty V) mzero m : above_max_premise_model ocls mzero -> @@ -5121,16 +5344,6 @@ Proof. apply max_clause_premise_mon in hincl. lia. Qed. *) -Lemma entails_all_shift {cls : clauses} {prems concl : univ} (n : nat) : - cls ⊢a prems → concl -> - cls ⊢a add_prems n prems → add_prems n concl. -Proof. - intros cla cl. - rewrite In_add_prems => [[le' [hin ->]]]. - eapply (entails_shift (cl := (prems, le'))). - now apply cla in hin. -Qed. - Lemma add_prems_of_level_set k W k' prf : add_prems k (of_level_set W k' prf) = of_level_set W (k + k') prf. Proof. @@ -5162,7 +5375,7 @@ Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : mod loop V U cls minit m prf with inspect (check_model cls (U, m)) := | exist None eqm => Model U {| model_model := m |} _ | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { - | exist true eq := Loop W (check_model_ne eqm) (Z.to_nat (v_minus_w_bound W m') + max_gain cls) _ + | exist true eq := Loop W (check_model_ne eqm) (max_clause_premise cls) _ (* Loop on cls ↓ W, with |W| < |V| *) | exist false neq with inner_loop V U minit loop W (cls ↓ W) m' _ := { | Loop W' ne n isloop := Loop W' ne n (loop_on_subset _ isloop) @@ -5172,7 +5385,7 @@ Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : mod with inspect (check_model cls (Wc, mwc.(model_model))) := { | exist None eqm' => Model (LevelSet.union W Wc) {| model_model := mwc.(model_model) |} _ | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { - | exist true _ := Loop Wcls (check_model_ne eqm') (Z.to_nat (v_minus_w_bound Wcls mcls) + max_gain cls) _ + | exist true _ := Loop Wcls (check_model_ne eqm') (max_clause_premise cls) _ | exist false neq' with loop V (LevelSet.union W Wcls) cls minit mcls _ := { (* Here Wcls < V, we've found a model for all of the clauses with conclusion in W, which can now be fixed. We concentrate on the clauses whose @@ -5193,9 +5406,15 @@ Proof. set (prf := check_model_ne eqm); clearbody prf. eapply check_model_is_update_of in eqm; tea. rewrite eq in eqm. destruct eqm as [eqm incl]. rewrite union_idem in eqm. - set (n := Z.to_nat _ + _). + have nem : ~ LevelMap.Empty minit. + { intros he. apply prf. rewrite eq. red in mof. intros a hin. apply mof in hin as [x hm]. + now apply he in hm. } + unshelve eapply strictly_updates_entails_on_V in eqm; tea. (* eapply entails_all_clauses_subset; tea. eapply entails_of_level_set_strenghten with (max_clause_premise cls). admit. *) + eapply strictly_updates_entails_loop_above_max; tea. + apply LevelSet.eq_leibniz in eq. subst W. + rewrite eq. eapply strictly_updates_entails_loop2. + rewrite eq. intros x. eapply strictly_updates_incl in eqm. split. 2:apply clsV. @@ -5226,13 +5445,15 @@ Proof. have tr := update_trans _ eqm eqm'. eapply LevelSet.equal_spec in e. rewrite e in tr. assert (hun : LevelSet.union W V =_lset V). eapply strictly_updates_incl in eqm. lsets. rewrite hun in tr. symmetry in e. - have [neV hl] := loop_on_proper _ _ ne cls e. apply hl. + set (n := Z.to_nat _ + _). + have [neV hl] := loop_on_proper _ _ n ne cls e. apply hl. have vm := model_ok mwc. - eapply strictly_updates_entails_loop with minit mcls; tea. + apply todo. + (* eapply strictly_updates_entails_loop with minit mcls; tea. + apply todo. (* minit is a max premise model *) + split. 2:apply clsV. intros hinV. eapply strictly_updates_incl in tr. apply tr in hinV. - now apply clauses_conclusions_levels. + now apply clauses_conclusions_levels. *) - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hu := model_updates mwc. eapply strictly_updates_is_update_of in hu; tea. From 933cfdbc4439af4e63085e3ce9d7738d5527b334 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 27 Aug 2025 23:14:45 +0200 Subject: [PATCH 021/164] Finally ! Now to clean up --- template-rocq/theories/PartialLoopChecking.v | 3718 ++++++++++-------- 1 file changed, 2011 insertions(+), 1707 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 22c4099e0..f1829032e 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -8,6 +8,10 @@ From MetaRocq.Common Require Universes. From Equations Require Import Equations. Set Equations Transparent. +Ltac rw l := rewrite_strat (topdown l). +Ltac rw_in l H := rewrite_strat (topdown l) in H. + + (* TODO move *) Arguments exist {A P}. Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. @@ -86,7 +90,7 @@ Module Type LoopCheckingItf (Level : LevelOrderedType) (LevelExprSet : LevelExprSet_fun Level LevelExpr) (LevelMap : FMapOTInterface Level). - Definition model := LevelMap.t (option Z). + Definition model := LevelMap.t nat. Definition valuation := LevelMap.t nat. Definition clause : Type := LevelExprSet.nonEmptyLevelExprSet × LevelExpr.t. @@ -431,10 +435,59 @@ Module NonEmptySetFacts. eapply Forall_forall in H2; tea. Qed. + Lemma add_comm {le le' e} : add le (add le' e) = add le' (add le e). + Proof. + apply eq_univ'. intros x. + rewrite !LevelExprSet.add_spec. firstorder. + Qed. + + #[program] + Definition univ_union (prems prems' : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + {| t_set := LevelExprSet.union prems prems' |}. + Next Obligation. + destruct prems, prems'; cbn. + destruct (LevelExprSet.is_empty (LevelExprSet.union _ _)) eqn:ise => //. + eapply LevelExprSetFact.is_empty_2 in ise. + eapply not_Empty_is_empty in t_ne0, t_ne1. + destruct t_ne0. lesets. + Qed. + + Lemma univ_union_spec u u' l : + LevelExprSet.In l (univ_union u u') <-> + LevelExprSet.In l u \/ LevelExprSet.In l u'. + Proof. + destruct u, u'; unfold univ_union; cbn. + apply LevelExprSet.union_spec. + Qed. + + Lemma univ_union_add_singleton u le : univ_union u (singleton le) = add le u. + Proof. + apply eq_univ'. + intros x. rewrite univ_union_spec LevelExprSet.singleton_spec add_spec. + intuition auto. + Qed. + + Lemma univ_union_comm {u u'} : univ_union u u' = univ_union u' u. + Proof. + apply eq_univ'. + intros x. rewrite !univ_union_spec. + intuition auto. + Qed. + + Lemma univ_union_add_distr {le u u'} : univ_union (add le u) u' = add le (univ_union u u'). + Proof. + apply eq_univ'. + intros x. rewrite !univ_union_spec !add_spec !univ_union_spec. + intuition auto. + Qed. + + End NonEmptySetFacts. Import NonEmptySetFacts. -Definition clause : Type := nonEmptyLevelExprSet × LevelExpr.t. +Notation univ := nonEmptyLevelExprSet. + +Definition clause : Type := univ × LevelExpr.t. Module Clause. Definition t := clause. @@ -630,24 +683,20 @@ Qed. Definition clause_conclusion cl := levelexpr_level (concl cl). -Definition model := LevelMap.t (option Z). +Definition model := LevelMap.t nat. -Definition level_value (m : model) (level : Level.t) : option Z := - match LevelMap.find level m with - | None => None - | Some v => v - end. +Definition level_value (m : model) (level : Level.t) : option nat := LevelMap.find level m. Definition levelexpr_value (m : model) (atom : LevelExpr.t) := level_value m (levelexpr_level atom). Extraction Inline levelexpr_value. -Definition min_atom_value (m : model) (atom : LevelExpr.t) := +Definition min_atom_value (m : model) (atom : LevelExpr.t) : option Z := let '(l, k) := atom in match level_value m l with | None => None - | Some val => Some (val - Z.of_nat k)%Z + | Some val => Some (Z.of_nat val - Z.of_nat k)%Z end. Definition option_map2 {A} (f : A -> A -> A) (o o' : option A) : option A := @@ -662,12 +711,10 @@ Definition min_premise (m : model) (l : nonEmptyLevelExprSet) : option Z := let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in fold_left (fun min atom => option_map2 Z.min (min_atom_value m atom) min) tl (min_atom_value m hd). -Open Scope Z_scope. - Definition satisfiable_atom (m : model) (atom : Level.t * nat) : bool := let '(l, k) := atom in match level_value m l with - | Some val => Z.of_nat k <=? val + | Some val => k <=? val | None => false end. @@ -688,7 +735,7 @@ Definition valid_clause (m : model) (cl : clause) := | None => true | Some k0 => let (l, k) := concl cl in - (k0 None | Some k0 => - if k0 model -> model -> Prop := | update_one m cl m' : Clauses.In cl cls -> @@ -906,7 +953,6 @@ Proof. eapply IHstrictly_updates1; firstorder. firstorder. Qed. - Lemma update_value_valid {m cl} : match update_value m cl with | None => valid_clause m cl @@ -919,7 +965,7 @@ Proof. destruct Z.ltb; unfold level_value_above; destruct level_value => //. - destruct Z.leb => //. + destruct Nat.leb => //. Qed. Lemma check_clause_model_spec {cl w m w' m'} : @@ -1065,7 +1111,7 @@ Proof. - intros he. specialize (he (clause_conclusion cl)). destruct cl as [prems [concl k]]. destruct H0 as [? [? ? ? heq]]. - setoid_rewrite heq in he. eapply (he (Some (Z.of_nat k + x))); cbn. + setoid_rewrite heq in he. eapply (he (k + Z.to_nat x)); cbn. rewrite LevelMapFact.F.add_mapsto_iff. firstorder. - intros he. now apply IHstrictly_updates2. Qed. @@ -1165,8 +1211,8 @@ Definition in_clauses_conclusions (cls : clauses) (x : Level.t): Prop := exists cl, Clauses.In cl cls /\ (level cl.2) = x. Definition v_minus_w_bound (W : LevelSet.t) (m : model) := - LevelMap.fold (fun w v acc => Z.max (option_get 0%Z v) acc) - (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0%Z. + LevelMap.fold (fun w v acc => Nat.max v acc) + (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0%nat. Definition levelexpr_k : LevelExpr.t -> nat := snd. Coercion levelexpr_k : LevelExpr.t >-> nat. @@ -1217,14 +1263,16 @@ Proof. now transitivity y. Qed. -Infix "≤" := (opt_le Z.le) (at level 50). +Infix "≤" := (opt_le Nat.le) (at level 50). + +Infix "≤Z" := (opt_le Z.le) (at level 50). Definition model_rel R (m m' : model) := forall l k, LevelMap.MapsTo l k m -> exists k', LevelMap.MapsTo l k' m' /\ R k k'. -Infix "⩽" := (model_rel (opt_le Z.le)) (at level 70). (* \leqslant *) +Infix "⩽" := (model_rel Nat.le) (at level 70). (* \leqslant *) -Infix "⩹" := (model_rel (opt_le Z.lt)) (at level 70). +Infix "⩹" := (model_rel Nat.lt) (at level 70). Definition model_map_outside V (m m' : model) := forall l, ~ LevelSet.In l V -> @@ -1276,12 +1324,19 @@ Qed. Instance Zmin_comm : Commutative Z.min := Z.min_comm. Instance Zmax_comm : Commutative Z.max := Z.max_comm. +Instance nat_min_comm : Commutative Nat.min := Nat.min_comm. +Instance nat_max_comm : Commutative Nat.max := Nat.max_comm. + Class Associative {A} (f : A -> A -> A) := assoc : forall x y z, f x (f y z) = f (f x y) z. Instance option_map_2_assoc {A} f : @Associative A f -> @Associative (option A) (option_map2 f). Proof. intros assoc [x|] [y|] [z|]; cbn => //. now rewrite assoc. Qed. +Instance nat_min_assoc : Associative Nat.min := Nat.min_assoc. +Instance nat_max_assoc : Associative Nat.max := Nat.max_assoc. + + Instance Zmin_assoc : Associative Z.min := Z.min_assoc. Instance Zmax_assoc : Associative Z.max := Z.max_assoc. @@ -1392,10 +1447,10 @@ Proof. destruct Z.ltb => //. unfold level_value_above. destruct level_value => //. - destruct Z.leb => //. + destruct Nat.leb => //. Qed. -Lemma level_value_not_above_spec m l k : level_value_above m l k = false -> opt_le Z.lt (level_value m l) (Some k). +Lemma level_value_not_above_spec m l k : level_value_above m l k = false -> opt_le Nat.lt (level_value m l) (Some k). Proof. unfold level_value_above; destruct level_value => // hlt; constructor. lia. Qed. @@ -1435,12 +1490,12 @@ Proof. intros l' k' maps. unfold update_model. cbn. destruct (eqb_spec l l'). - - subst l'. exists (Some k). move: hl. + - subst l'. exists k. move: hl. unfold level_value. rewrite (LevelMap.find_1 maps). intros hle. - split => //. eapply LevelMap.add_1. eapply LevelMap.OT.eq_refl. - - exists k'. split => //. apply LevelMap.add_2 => //. reflexivity. + split => //. eapply LevelMap.add_1. eapply LevelMap.OT.eq_refl. now depelim hle. + - exists k'. split => //. apply LevelMap.add_2 => //. Qed. Lemma update_model_not_above m l k : level_value_above m l k = false -> m ⩽ update_model m l k. @@ -1452,20 +1507,19 @@ Proof. Qed. Lemma level_value_MapsTo {l k} {m : model} : - LevelMap.MapsTo l k m -> level_value m l = k. + LevelMap.MapsTo l k m -> level_value m l = Some k. Proof. unfold level_value. move=> mapto; rewrite (LevelMap.find_1 mapto) //. Qed. Lemma level_value_MapsTo' {l k} {m : model} : - level_value m l = Some k -> LevelMap.MapsTo l (Some k) m. + level_value m l = Some k -> LevelMap.MapsTo l k m. Proof. unfold level_value. destruct LevelMap.find eqn:hfind => //. - eapply LevelMap.find_2 in hfind. now intros ->. + eapply LevelMap.find_2 in hfind. now intros [= ->]. Qed. - Lemma strict_update_ext m cl m' : strict_update m cl m' -> m ⩽ m'. Proof. destruct cl as [prems [concl k]]. @@ -1476,12 +1530,12 @@ Proof. destruct (Level.eq_dec concl x). subst. move: ha; rewrite /level_value_above. eapply level_value_MapsTo in hin. rewrite hin. - exists (Some (Z.of_nat k + v)). - split. left. split; reflexivity. - destruct k' => //; constructor. - move: ha. - rewrite -Z.ltb_antisym => /Z.ltb_lt. lia. - exists k'. split => //. right; eauto. reflexivity. + intros hlt'. + exists (k + Z.to_nat v)%nat. + split. left. split; reflexivity. red. + move/negbTE: hlt'. + elim: Nat.leb_spec => //. lia. + exists k'. split => //. right; eauto. Qed. Lemma strictly_updates_ext cls w m m' : strictly_updates cls w m m' -> m ⩽ m'. @@ -1531,7 +1585,7 @@ Proof. unfold level_value. destruct LevelMap.find eqn:hl => //. - apply LevelMap.find_2 in hl. specialize (lem _ hl) as [k' [mapsto leq]]. - now rewrite (LevelMap.find_1 mapsto). + rewrite (LevelMap.find_1 mapsto). now constructor. - constructor. Qed. @@ -1624,9 +1678,9 @@ Proof. - now apply out. Qed. -Definition max_premise_value (m : model) (l : nonEmptyLevelExprSet) : option Z := +Definition max_premise_value (m : model) (l : nonEmptyLevelExprSet) : option nat := let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (fun min atom => option_map2 Z.max (levelexpr_value m atom) min) tl (levelexpr_value m hd). + fold_left (fun min atom => option_map2 Nat.max (levelexpr_value m atom) min) tl (levelexpr_value m hd). Definition non_W_atoms W (l : LevelExprSet.t) := LevelExprSet.filter (fun lk => ~~ LevelSet.mem lk.1 W) l. @@ -1723,12 +1777,12 @@ Section MoreNonEmpty. Import NonEmptySetFacts. Notation min_opt := (option_map2 Z.min). - Lemma Zmin_opt_left x y : min_opt x y ≤ x. + Lemma Zmin_opt_left x y : min_opt x y ≤Z x. Proof. destruct x as [x|], y as [y|]; constructor. lia. Qed. - Lemma Zmin_opt_right x y : min_opt x y ≤ y. + Lemma Zmin_opt_right x y : min_opt x y ≤Z y. Proof. destruct x as [x|], y as [y|]; constructor. lia. Qed. @@ -1742,7 +1796,7 @@ Section MoreNonEmpty. Lemma min_premise_spec_aux (m : model) s k : min_premise m s = k -> - (forall x, LevelExprSet.In x s -> (k ≤ min_atom_value m x)%Z) /\ + (forall x, LevelExprSet.In x s -> (k ≤Z min_atom_value m x)) /\ (exists x, LevelExprSet.In x s /\ k = min_atom_value m x). Proof. unfold min_premise. @@ -1775,7 +1829,7 @@ Section MoreNonEmpty. Qed. Lemma min_premise_spec (m : model) (s : nonEmptyLevelExprSet) : - (forall x, LevelExprSet.In x s -> min_premise m s ≤ min_atom_value m x) /\ + (forall x, LevelExprSet.In x s -> min_premise m s ≤Z min_atom_value m x) /\ (exists x, LevelExprSet.In x s /\ min_premise m s = min_atom_value m x). Proof. now apply min_premise_spec_aux. @@ -1783,7 +1837,7 @@ Section MoreNonEmpty. Lemma min_premise_subset (m : model) (s s' : nonEmptyLevelExprSet) : LevelExprSet.Subset s s' -> - min_premise m s' ≤ min_premise m s. + min_premise m s' ≤Z min_premise m s. Proof. intros sub. have [has [mins [ins eqs]]] := min_premise_spec m s. @@ -1873,30 +1927,26 @@ Section MoreNonEmpty. lia. Qed. + Lemma fold_comm_assoc_nat x y z : option_map2 Nat.max x (option_map2 Nat.max y z) = + option_map2 Nat.max y (option_map2 Nat.max x z). + Proof. + now rewrite (assoc (f := option_map2 Nat.max)) (comm (f := option_map2 Nat.max) x y) -assoc. + Qed. + Lemma fold_comm_assoc x y z : option_map2 Z.max x (option_map2 Z.max y z) = option_map2 Z.max y (option_map2 Z.max x z). Proof. now rewrite (assoc (f := option_map2 Z.max)) (comm (f := option_map2 Z.max) x y) -assoc. Qed. - Notation max_opt := (option_map2 Z.max). - Lemma max_opt_spec x y z : max_opt x y = Some z -> exists x' y', x = Some x' /\ y = Some y' /\ z = Z.max x' y'. + Notation max_opt := (option_map2 Nat.max). + + Lemma max_opt_spec x y z : max_opt x y = Some z -> exists x' y', x = Some x' /\ y = Some y' /\ z = Nat.max x' y'. Proof. destruct x as [x|], y as [y|]; cbn; intuition eauto; try noconf H. exists x, y. auto. Qed. - (* Lemma Zmax_opt_left x y : x ≤ max_opt x y. *) - (* Proof. *) - (* destruct x as [x|], y as [y|]; try constructor. lia. *) - (* Qed. *) -(* - Lemma Zmax_opt_right x y : min_opt x y ≤ y. - Proof. - destruct x as [x|], y as [y|]; constructor. lia. - Qed. *) - - Lemma max_premise_value_spec_aux (m : model) s k : max_premise_value m s = Some k -> (forall x, LevelExprSet.In x s -> exists k', levelexpr_value m x = Some k' /\ Some k' ≤ Some k) /\ @@ -1911,7 +1961,7 @@ Section MoreNonEmpty. intros eq. split. intros x [->|] => //. exists k. split => //. reflexivity. now exists t0; split => //. - - cbn. rewrite fold_left_comm. intros; apply fold_comm_assoc. + - cbn. rewrite fold_left_comm. intros; apply fold_comm_assoc_nat. intros heq. apply max_opt_spec in heq as [y' [z' [eqa [eqf ->]]]]. specialize (IHl _ eqf). destruct IHl as [ha hex]. split; intros. @@ -1920,7 +1970,7 @@ Section MoreNonEmpty. { specialize (ha _ inih) as [k' []]. exists k'; intuition eauto. constructor. depelim H0; lia. } destruct hex as [maxval [inmax ih]]. cbn. - destruct (Z.leb_spec z' y'). + destruct (Nat.leb_spec z' y'). exists a. split; [intuition|]. rewrite eqa. f_equal. lia. exists maxval. cbn in inmax; split; [intuition auto|]. rewrite -ih. f_equal; lia. Qed. @@ -1936,7 +1986,7 @@ End MoreNonEmpty. Lemma min_premise_pos_spec {m prem k} : min_premise m prem = Some k -> - forall x, LevelExprSet.In x prem -> Some (Z.of_nat (levelexpr_k x) + k)%Z ≤ levelexpr_value m x. + forall x, LevelExprSet.In x prem -> Some (Z.of_nat (levelexpr_k x) + k)%Z ≤Z option_map Z.of_nat (levelexpr_value m x). Proof. pose proof (min_premise_spec m prem) as [amin [exmin [inminpre eqminpre]]]. intros hprem x hin. @@ -1973,7 +2023,7 @@ Proof. rewrite (LevelMap.find_1 H) //. destruct (LevelMap.find _ m) eqn:hl' => //. eapply LevelMap.find_2 in hl'. - assert (LevelMap.MapsTo x o fm). + assert (LevelMap.MapsTo x n fm). eapply LevelMapFact.filter_iff. tc. split => //. now rewrite [_ = true]not_mem. now rewrite (LevelMap.find_1 H) in hl. } @@ -1988,7 +2038,7 @@ Proof. unfold level_value. cbn. rewrite hadd LevelMapFact.F.add_o. destruct LevelMap.OT.eq_dec. do 2 red in e0. subst x. - intros hf. destruct e; cbn; constructor. lia. + intros hf. constructor. lia. destruct LevelMap.find => hf; depelim hf; constructor; lia. Qed. @@ -2043,11 +2093,11 @@ Proof. now etransitivity; tea. Qed. -Definition total_model_of V (m : model) := - forall k, LevelSet.In k V -> exists x, LevelMap.MapsTo k (Some x) m. +Definition model_of V (m : model) := + forall k, LevelSet.In k V -> LevelMap.In k m. Definition only_model_of V (m : model) := - forall k, LevelSet.In k V <-> exists x, LevelMap.MapsTo k (Some x) m. + forall k, LevelSet.In k V <-> exists x, LevelMap.MapsTo k x m. Definition check_model_invariants cls w m w' m' (modified : bool) := if modified then @@ -2057,10 +2107,10 @@ Definition check_model_invariants cls w m w' m' (modified : bool) := let cll := (levelexpr_level (concl cl)) in [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' & - opt_le Z.lt (level_value m cll) (level_value m' cll)], + opt_le Nat.lt (level_value m cll) (level_value m' cll)], model_extension w' m m' & - total_model_of w' m'] - else (w, m) = (w', m') /\ total_model_of w m. + model_of w' m'] + else (w, m) = (w', m') /\ model_of w m. Lemma nEmpty_exists ls : ~ (LevelSet.Empty ls) -> exists l, LevelSet.In l ls. Proof. @@ -2075,22 +2125,22 @@ Proof. lsets. Qed. -Lemma level_value_above_MapsTo m l k : level_value_above m l k -> exists k', LevelMap.MapsTo l k' m /\ Some k ≤ k'. +Lemma level_value_above_MapsTo m l k : level_value_above m l k -> exists k', LevelMap.MapsTo l k' m /\ (k <= k')%nat. Proof. unfold level_value_above. destruct level_value eqn:hl => //. - move/Z.leb_le => hle; exists (Some z). - eapply level_value_MapsTo' in hl. split => //. constructor; lia. + move/Nat.leb_le => hle; exists n. + eapply level_value_MapsTo' in hl. split => //. Qed. -Lemma level_value_above_MapsTo' m l k k' : LevelMap.MapsTo l k' m -> Some k ≤ k' -> level_value_above m l k. +Lemma level_value_above_MapsTo' m l k k' : LevelMap.MapsTo l k' m -> (k <= k')%nat -> level_value_above m l k. Proof. unfold level_value_above. intros H; apply LevelMap.find_1 in H. rewrite /level_value H. - intros hleq; depelim hleq. now apply Z.leb_le. + intros hleq; depelim hleq; now apply Nat.leb_le. Qed. -Lemma level_value_add m l k : level_value (LevelMap.add l k m) l = k. +Lemma level_value_add m l k : level_value (LevelMap.add l k m) l = Some k. Proof. rewrite /level_value LevelMapFact.F.add_eq_o //. Qed. @@ -2126,7 +2176,8 @@ Proof. now setoid_rewrite <-eqcls. Qed. -Lemma min_atom_value_levelexpr_value m l a lv : min_atom_value m l = Some a -> levelexpr_value m l = Some lv -> (a <= (lv - Z.of_nat l))%Z. +Lemma min_atom_value_levelexpr_value m l a lv : min_atom_value m l = Some a -> levelexpr_value m l = Some lv -> + (a <= (Z.of_nat lv - Z.of_nat l))%Z. Proof. destruct l as [l k]; cbn. unfold levelexpr_value. cbn. destruct level_value => //. intros [= <-] [= <-]. lia. @@ -2172,9 +2223,9 @@ Proof. intros [] H'; depelim H'; constructor. lia. Qed. -Lemma total_model_of_update w m l k : total_model_of w m -> total_model_of (LevelSet.add l w) (update_model m l k). +Lemma model_of_update w m l k : model_of w m -> model_of (LevelSet.add l w) (update_model m l k). Proof. - rewrite /total_model_of => hint l'. rewrite LevelSet.add_spec. + rewrite /model_of => hint l'. rewrite LevelSet.add_spec. intros [->|hadd]. - exists k. now apply LevelMap.add_1. - specialize (hint _ hadd). unfold update_model. @@ -2222,7 +2273,7 @@ Proof. firstorder eauto. Qed. -Lemma min_premise_some_pres {m m' prems k} : m ⩽ m' -> min_premise m prems = Some k -> exists k', min_premise m' prems = Some k'. +(* Lemma min_premise_some_pres {m m' prems k} : m ⩽ m' -> min_premise m prems = Some k -> exists k', min_premise m' prems = Some k'. Proof. intros ext minp. apply (@min_premise_pos_spec_inv m' prems). @@ -2230,19 +2281,19 @@ Proof. pose proof (min_premise_spec m prems) as [le eq]. specialize (le x hin). rewrite minp in le. depelim le. move: H0; rewrite /min_atom_value /levelexpr_value /level_value. destruct x as [l k']. - destruct LevelMap.find eqn:hfind => //. destruct o => //; intros [= <-]. + destruct LevelMap.find eqn:hfind => //. intros [= <-]. eapply LevelMap.find_2 in hfind. eapply ext in hfind as [? [map2 hsome]]. - eapply LevelMap.find_1 in map2. rewrite map2. depelim hsome. now exists y. -Qed. + eapply LevelMap.find_1 in map2. rewrite map2. depelim hsome. now exists n. +Qed. *) Lemma min_premise_spec' {m prems z} : min_premise m prems = Some z -> (forall l k, LevelExprSet.In (l, k) prems -> - exists v, level_value m l = Some v /\ z <= (v - Z.of_nat k))%Z. + exists v, level_value m l = Some v /\ z <= (Z.of_nat v - Z.of_nat k))%Z. Proof. intros hmin. have [hall hhmin'] := min_premise_spec m prems. intros l k hin; specialize (hall _ hin). rewrite hmin in hall. - depelim hall. destruct level_value => //. noconf H0. exists z0. split => //. + depelim hall. destruct level_value => //. noconf H0. exists n. split => //. Qed. Lemma nonEmptyLevelExprSet_elim {P : nonEmptyLevelExprSet -> Prop} : @@ -2270,7 +2321,7 @@ Proof. cbn. firstorder. subst x'. now left. Qed. -Lemma min_premise_pres {m m'} prems : m ⩽ m' -> min_premise m prems ≤ min_premise m' prems. +Lemma min_premise_pres {m m'} prems : m ⩽ m' -> min_premise m prems ≤Z min_premise m' prems. Proof. intros ext. destruct (min_premise m prems) eqn:hmin. @@ -2281,9 +2332,9 @@ Proof. rewrite eqminz. destruct e' as [min' []]. rewrite H0. transitivity (min_atom_value m min'). 2:{ unfold min_atom_value. destruct min'. - unfold level_value. destruct (LevelMap.find t m) eqn:hfind. destruct o => //. 2:constructor. + unfold level_value. destruct (LevelMap.find t m) eqn:hfind. 2:constructor. apply LevelMap.find_2 in hfind. apply ext in hfind as [k' [hfind hle]]. - apply LevelMap.find_1 in hfind. rewrite hfind. depelim hle. constructor. lia. constructor. + apply LevelMap.find_1 in hfind. rewrite hfind. depelim hle. constructor. lia. constructor. lia. } destruct min'. specialize (leq _ _ H) as [? []]. unfold min_atom_value at 2. rewrite H1. rewrite -eqminz. constructor. lia. @@ -2292,8 +2343,8 @@ Qed. Lemma level_value_above_mon m m' l k : m ⩽ m' -> level_value_above m l k -> level_value_above m' l k. Proof. intros ext; move/level_value_above_MapsTo => [v [hm hleq]]. - eapply ext in hm. destruct hm as [v' [hm' leq']]. depelim hleq. depelim leq'. - eapply level_value_above_MapsTo'; tea. now constructor; lia. + eapply ext in hm. destruct hm as [v' [hm' leq']]. + eapply level_value_above_MapsTo'; tea. lia. Qed. (* Lemma strict_update_ext_right m cl m' m'' : strict_update m cl m' -> m' ⩽ m'' -> strict_update m cl m''. @@ -2339,30 +2390,32 @@ Proof. (* 2:{ eapply level_value_above_mon; tea. eapply level_value_above_MapsTo'; tea. rewrite -nout. } *) Abort. *) -Definition model_of V (m : model) := - forall k, LevelSet.In k V -> LevelMap.In k m. - Lemma model_of_subset V V' m : model_of V m -> V' ⊂_lset V -> model_of V' m. Proof. - rewrite /model_of. intros ih hv k. specialize (ih k). + intros ih hv k. specialize (ih k). now move/hv. Qed. -Lemma total_model_of_subset V V' m : - total_model_of V m -> V' ⊂_lset V -> total_model_of V' m. +Instance only_model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) only_model_of. Proof. - intros ih hv k. specialize (ih k). - now move/hv. + intros ? ? eq ? ? eq'. + rewrite /only_model_of. now setoid_rewrite eq; setoid_rewrite eq'. +Qed. + +Lemma only_model_of_eq V V' m : + only_model_of V m -> V' =_lset V -> only_model_of V' m. +Proof. + intros ih hv k. now rewrite hv. Qed. -Lemma total_model_of_sub V m : total_model_of V m -> model_of V m. +Lemma model_of_sub V m : model_of V m -> model_of V m. Proof. - rewrite /total_model_of /model_of. + rewrite /model_of /model_of. intros H k hin. specialize (H k hin) as [? ?]. - now exists (Some x). + now exists x. Qed. -Coercion total_model_of_sub : total_model_of >-> model_of. +Coercion model_of_sub : model_of >-> model_of. Lemma clauses_conclusions_subset {cls cls'} : Clauses.Subset cls cls' -> @@ -2399,7 +2452,7 @@ Qed. Lemma check_model_update {W cls m wm'} : model_of (clauses_conclusions cls) m -> - total_model_of W m -> + model_of W m -> check_model cls (W, m) = Some wm' -> ~~ is_model cls m /\ m ⩽ wm'.2. Proof. intros mof tot. @@ -2410,12 +2463,12 @@ Proof. Qed. Definition level_value_default m l := - match level_value m l with Some x => x | None => 0 end%Z. + match level_value m l with Some x => x | None => 0 end%nat. Definition measure_w W cls m w := let bound := v_minus_w_bound W m in let maxgain := max_gain (cls_diff cls W) in - (bound + Z.of_nat maxgain - level_value_default m w)%Z. + (Z.of_nat bound + Z.of_nat maxgain - Z.of_nat (level_value_default m w))%Z. Lemma min_premise_max_premise m prem k : min_premise m prem = Some k -> @@ -2426,7 +2479,7 @@ Proof. assert (forall l k, fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (let '(l0, k0) := atom in match level_value m l0 with - | Some val => Some (val - Z.of_nat k0)%Z + | Some val => Some (Z.of_nat val - Z.of_nat k0)%Z | None => None end) min) l None = @@ -2435,8 +2488,8 @@ Proof. destruct a, level_value; cbn; auto. } assert (forall x y, fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (Some x) = Some k -> -exists k' : Z, - fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.max (levelexpr_value m atom) min) l (Some y) = Some k'). +exists k', + fold_left (fun (min : option nat) (atom : LevelExpr.t) => option_map2 Nat.max (levelexpr_value m atom) min) l (Some y) = Some k'). { induction l; cbn. - intros x y [= <-]. now eexists. - intros x y. @@ -2448,8 +2501,8 @@ exists k' : Z, intros; exfalso. now eapply H. Qed. -Lemma total_model_of_value_None W m l : - total_model_of W m -> +Lemma model_of_value_None W m l : + model_of W m -> LevelSet.In l W -> level_value m l = None -> False. Proof. @@ -2459,7 +2512,7 @@ Proof. Qed. Lemma invalid_clause_measure W cls cl m : - total_model_of W m -> + model_of W m -> ~~ valid_clause m cl -> Clauses.In cl (cls_diff cls W) -> (0 < measure_w W cls m (concl cl))%Z. @@ -2474,7 +2527,7 @@ Proof. cbn. unfold measure_w. unfold gain. set (clsdiff := Clauses.diff _ _). set (bound := v_minus_w_bound W m). - enough (level_value_default m l < bound + Z.of_nat (max_gain clsdiff))%Z. lia. + enough (Z.of_nat (level_value_default m l) < Z.of_nat bound + Z.of_nat (max_gain clsdiff))%Z. lia. set (prem' := non_W_atoms W prem). set (preml := {| t_set := prem'; t_ne := hne |}). assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff)%nat. @@ -2483,16 +2536,16 @@ Proof. pose proof (premise_min_subset preml prem). rewrite !Z2Nat.inj_sub //; try lia. rewrite !Nat2Z.id. forward H. eapply non_W_atoms_subset. lia. } - eapply Z.lt_le_trans with (bound + Z.of_nat (Z.to_nat (gain (preml, (l, k)))))%Z; try lia. + eapply Z.lt_le_trans with (Z.of_nat bound + Z.of_nat (Z.to_nat (gain (preml, (l, k)))))%Z; try lia. unfold gain; cbn. - enough (level_value_default m l < v_minus_w_bound W m + Z.of_nat (k - premise_min preml))%Z. lia. + enough (Z.of_nat (level_value_default m l) < Z.of_nat (v_minus_w_bound W m) + Z.of_nat (k - premise_min preml))%Z. lia. unfold level_value_default. destruct (level_value m l) as [vl|] eqn:hl; revgoals. - { eapply total_model_of_value_None in hl; tea => //. + { eapply model_of_value_None in hl; tea => //. eapply Clauses.diff_spec in hin as [hin _]. now apply in_clauses_with_concl in hin as [hin _]. } depelim hlt. - enough (Z.of_nat k + z <= v_minus_w_bound W m + Z.of_nat (k - premise_min preml))%Z. lia. - assert (min_premise m prem ≤ min_premise m preml)%Z. + enough (Z.of_nat k + z <= Z.of_nat (v_minus_w_bound W m) + Z.of_nat (k - premise_min preml))%Z. lia. + assert (min_premise m prem ≤Z min_premise m preml)%Z. { eapply min_premise_subset. eapply non_W_atoms_subset. } rewrite hmin in H1. depelim H1. transitivity (Z.of_nat k + y)%Z. lia. @@ -2503,7 +2556,7 @@ Proof. assert (premise_min prem <= premise_min preml)%nat. { eapply premise_min_subset. eapply non_W_atoms_subset. } (* transitivity (v_minus_w_bound W m + (k - premise_min preml)). 2:lia. *) - assert (y <= maxpreml - Z.of_nat (premise_min preml))%Z. + assert (y <= Z.of_nat maxpreml - Z.of_nat (premise_min preml))%Z. { rewrite eqpminpre. rewrite H2 in eqminpre; symmetry in eqminpre. (* eqmaxpre eqminpre. *) pose proof (min_atom_value_levelexpr_value m exmin). @@ -2513,15 +2566,15 @@ Proof. specialize (H4 _ _ eqminpre eqexmin). depelim ltexmin. etransitivity; tea. rewrite -eqmaxpre in H6. noconf H6. unfold level_expr_elt in *. lia. } - transitivity (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)))%Z. lia. + transitivity (Z.of_nat k + (Z.of_nat maxpreml - Z.of_nat (premise_min preml)))%Z. lia. (* assert (Z.of_nat (premise_min preml) <= maxpreml)%Z. { rewrite eqmaxpre. move/min_premise_pos_spec: hprem => hprem. transitivity exmax. apply apmin => //. eapply hprem. now apply (non_W_atoms_subset W prem). } *) - assert (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)) = - (maxpreml + Z.of_nat k - Z.of_nat (premise_min preml)))%Z as ->. lia. - enough (maxpreml <= v_minus_w_bound W m)%Z. lia. + assert (Z.of_nat k + (Z.of_nat maxpreml - Z.of_nat (premise_min preml)) = + (Z.of_nat maxpreml + Z.of_nat k - Z.of_nat (premise_min preml)))%Z as ->. lia. + enough (Z.of_nat maxpreml <= Z.of_nat (v_minus_w_bound W m))%Z. lia. { have vm := v_minus_w_bound_spec W m exmax. unfold levelexpr_value in eqmaxpre. rewrite -eqmaxpre in vm. have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). @@ -2529,7 +2582,7 @@ Proof. forward hlevels. exists exmax.2. now destruct exmax. rewrite LevelSet.diff_spec in hlevels. - destruct hlevels as [_ nw]. specialize (vm nw). now depelim vm. } + destruct hlevels as [_ nw]. specialize (vm nw). depelim vm. lia. } Qed. Module ClausesOrd := OrdProperties Clauses. @@ -2565,7 +2618,7 @@ Proof. Qed. *) Definition is_update_of cls upd minit m := - if LevelSet.is_empty upd then minit = m + if LevelSet.is_empty upd then minit =m m else strictly_updates cls upd minit m. Record valid_model_def (V W : LevelSet.t) (m : model) (cls : clauses) := @@ -2590,6 +2643,15 @@ Lemma add_expr_add_expr n n' lk : add_expr n (add_expr n' lk) = add_expr (n + n' Proof. destruct lk; unfold add_expr. f_equal; lia. Qed. Definition add_prems n s := map (add_expr n) s. +Lemma In_add_prems k (prems : nonEmptyLevelExprSet): + forall le, LevelExprSet.In le (add_prems k prems) <-> + exists le', LevelExprSet.In le' prems /\ le = add_expr k le'. +Proof. + intros [l k']. + now rewrite /add_prems map_spec. +Qed. + + Lemma map_map f g x : map f (map g x) = map (f ∘ g) x. Proof. apply eq_univ'. @@ -2701,568 +2763,921 @@ Proof. intros [e [hin ->]]. exists e. firstorder. Qed. -Definition to_clauses (prems : nonEmptyLevelExprSet) (concl : nonEmptyLevelExprSet) : clauses := - LevelExprSet.fold (fun lk cls => Clauses.add (prems, lk) cls) concl Clauses.empty. - -Definition is_loop (cls : clauses) (t : nonEmptyLevelExprSet) := - let cls' := to_clauses t (succ_prems t) in - Clauses.For_all (fun cl' => entails cls cl') cls'. - -(* Definition is_looping (w : LevelSet.t) n (cls : clauses) := - let preml := LevelSet.elements w in - let prem := List.map (fun e => (e, n)) preml in - is_loop cls prem. *) -Definition levelexprset_of_levels (ls : LevelSet.t) n : LevelExprSet.t := - LevelSet.fold (fun x => LevelExprSet.add (x, n)) ls LevelExprSet.empty. +Derive Signature for entails. -Lemma levelexprset_of_levels_spec {ls : LevelSet.t} {l k n} : - LevelExprSet.In (l, k) (levelexprset_of_levels ls n) <-> LevelSet.In l ls /\ k = n. +Open Scope nat_scope. +Lemma entails_pred_closure {cls prems concl k} : + cls ⊢ prems → (concl, 1 + k) -> cls ⊢ prems → (concl, k). Proof. - rewrite /levelexprset_of_levels. - eapply LevelSetProp.fold_rec. - - intros s' he. rewrite LevelExprSetFact.empty_iff. firstorder. - - intros x a s' s'' hin hnin hadd ih. - rewrite LevelExprSet.add_spec; unfold LevelExprSet.E.eq. - firstorder eauto; try noconf H1 => //. - apply hadd in H1. firstorder. subst. now left. -Qed. - -#[program] -Definition of_level_set (ls : LevelSet.t) n (hne : ~ LevelSet.Empty ls) : nonEmptyLevelExprSet := - {| t_set := levelexprset_of_levels ls n |}. -Next Obligation. - apply not_Empty_is_empty => he. apply hne. - intros l nin. specialize (he (l,n)). apply he. - now rewrite levelexprset_of_levels_spec. + intros he. + depind he. + - eapply clause_cut. + constructor. + 2:{ intros l hin. rewrite LevelExprSet.singleton_spec in hin. red in hin; subst l. rewrite Nat.add_1_r; exact H. } + constructor. + rewrite LevelExprSet.add_spec. lesets. + - eapply clause_cut; tea. Qed. -Definition entails_clauses cls cl := - Clauses.For_all (entails cls) cl. - -Definition loop_on_univ cls prems := entails_clauses cls (to_clauses prems (succ_prems prems)). - -Definition loop_on W (hne : ~ LevelSet.Empty W) n cls := - cls ⊢a of_level_set W n hne → of_level_set W (n + 1) hne. - -Lemma loop_on_proper W W' n hne' cls : W =_lset W' -> exists hne, loop_on W hne n cls -> loop_on W' hne' n cls. +Lemma entails_pred_closure_n {cls prems concl k n} : + entails cls (prems, (concl, k + n)) -> entails cls (prems, (concl, k)). Proof. - intros eq; rewrite /loop_on /loop_on_univ. - assert (hne : ~ LevelSet.Empty W). now rewrite eq. - exists hne. - assert (of_level_set W n hne = of_level_set W' n hne') as ->. - apply eq_univ'. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. - assert (of_level_set W (n + 1) hne = of_level_set W' (n + 1) hne') as ->. - apply eq_univ'. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. - by []. + induction n in k |- *. + - rewrite Nat.add_0_r. tauto. + - intros hen. rewrite Nat.add_succ_r in hen. + eapply IHn. now eapply entails_pred_closure in hen. Qed. -Lemma loop_on_subset {W hne n cls cls'} : Clauses.Subset cls cls' -> loop_on W hne n cls -> loop_on W hne n cls'. -Proof. -Admitted. - -Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := - | Loop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) n (islooping : loop_on w hne n cls) - | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). -Arguments Loop {V U cls m}. -Arguments Model {V U cls m}. -Arguments lexprod {A B}. - -Definition option_of_result {V U m cls} (r : result V U m cls) : option model := - match r with - | Model w m _ => Some m.(model_model) - | Loop w hne _ isloop => None - end. - -Notation "#| V |" := (LevelSet.cardinal V). - -Notation loop_measure V W := (#|V|, #|V| - #|W|)%nat. - -Definition lexprod_rel := lexprod lt lt. - -#[local] Instance lexprod_rel_wf : WellFounded lexprod_rel. -Proof. - eapply (Acc_intro_generator 1000). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. -Defined. - -Lemma strictly_updates_trans {cls cls' W W' m m' m''} : - strictly_updates cls W m m' -> - strictly_updates cls' W' m' m'' -> - strictly_updates (Clauses.union cls cls') (LevelSet.union W W') m m''. - Proof. - intros su su'. - eapply update_trans; eapply strictly_updates_weaken; tea; clsets. - Qed. - -Lemma check_model_is_update_of {cls cls' U W minit m m'} : is_update_of cls U minit m -> check_model cls' (U, m) = Some (W, m') -> - strictly_updates (Clauses.union cls cls') W minit m' /\ U ⊂_lset W. +Lemma add_clause_0 cl : add_clause 0 cl = cl. Proof. - rewrite /is_update_of. - destruct LevelSet.is_empty eqn:he. - - intros ->. eapply LevelSetFact.is_empty_2 in he. - eapply LevelSetProp.empty_is_empty_1 in he. - eapply LevelSet.eq_leibniz in he. rewrite he. - move/check_model_updates_spec_empty. intros H; split => //. 2:lsets. - eapply strictly_updates_weaken; tea. clsets. - - intros hs. move/check_model_spec => [w'' [su ->]]. split; [|lsets]. - eapply strictly_updates_trans; tea. + destruct cl as [prems [concl k]]; cbn. + f_equal. 2:now rewrite Nat.add_0_r. + unfold add_prems. + eapply eq_univ'. intros [l k']. + rewrite NonEmptySetFacts.map_spec. + unfold add_expr. firstorder. destruct x. noconf H0. + now rewrite Nat.add_0_r. Qed. -Lemma is_update_of_case cls W m m' : - is_update_of cls W m m' -> - (LevelSet.Empty W /\ m = m') \/ strictly_updates cls W m m'. +Lemma incls0 {cls cl} : Clauses.In cl cls -> in_pred_closure cls cl. Proof. - rewrite /is_update_of. - destruct LevelSet.is_empty eqn:he. - - intros ->. left => //. now eapply LevelSetFact.is_empty_2 in he. - - intros H; now right. + intros hin. + have hcl := incls _ _ 0 hin. + now rewrite add_clause_0 in hcl. Qed. - -Lemma model_incl {V W m cls} : valid_model V W m cls -> W ⊂_lset V. +Lemma entails_in {cls cl} : Clauses.In cl cls -> entails cls cl. Proof. - intros vm; have upd := model_updates vm. - move/is_update_of_case: upd => []. - - intros [ne eq]. lsets. - - move/strictly_updates_incl. have hv := model_clauses_conclusions vm. lsets. + intros hin. + destruct cl as [prems concl]. + eapply clause_cut. + - now eapply incls0. + - constructor. eapply LevelExprSet.add_spec. now left. + - reflexivity. Qed. -(* - model_of_W : total_model_of W model_model; - model_incl : ; -model_extends : model_extension V m model_model; -Arguments model_of_W {V W m cls}. -Arguments model_incl {V W m cls}. -Arguments model_extends {V W m cls}. - *) -Lemma total_model_of_ext {W m m'} : - total_model_of W m -> m ⩽ m' -> total_model_of W m'. +Lemma in_pred_closure_shift {cls cl} n : in_pred_closure cls cl -> in_pred_closure cls (add_clause n cl). Proof. - intros mof ext. - intros k hin. destruct (mof k hin). specialize (ext _ _ H) as [k' []]. depelim H1. now exists y. + destruct 1. + - rewrite add_clause_add_clause. now constructor. + - cbn. eapply in_pred_closure_equal with (singleton (x, k + 1 + n)). + { intros le. rewrite In_add_prems; rewrite_strat (topdown LevelExprSet.singleton_spec). + intuition auto. exists (x, k + 1). split => //. + now destruct H as [le' [-> ->]]. } + rewrite -Nat.add_assoc. rewrite -[1 + _](Nat.add_1_r n) Nat.add_assoc. constructor. Qed. -Lemma valid_model_total W W' m cls : - forall vm : valid_model W W' m cls, total_model_of W m -> total_model_of W (model_model vm). +Lemma add_clause_singleton n le concl k : add_clause n (singleton le, (concl, k)) = (singleton (add_expr n le), (concl, k + n)). Proof. - intros []; cbn => htot. - move/is_update_of_case: model_updates0 => []. - - intros [ne ->] => //. - - intros su. eapply strictly_updates_ext in su. - eapply total_model_of_ext; tea. + rewrite /add_clause //=. f_equal. + apply eq_univ'. intros le'. rewrite In_add_prems. + rewrite_strat (topdown LevelExprSet.singleton_spec). + unfold LevelExprSet.E.eq. firstorder. subst. reflexivity. Qed. -Lemma is_update_of_ext {cls W m m'} : is_update_of cls W m m' -> m ⩽ m'. +Lemma entails_shift {cls cl} n : entails cls cl -> entails cls (add_clause n cl). Proof. - move/is_update_of_case => []. - - intros [he%LevelSetProp.empty_is_empty_1]. now subst. - - apply strictly_updates_ext. + induction 1. + - unfold add_clause. constructor. + rewrite In_add_prems. exists concl0. split => //. + - eapply (clause_cut _ (add_prems n prems') (add_expr n concl')). + 2:{ unfold add_clause in *. eapply entails_equal; tea. + intros le. setoid_rewrite In_add_prems. setoid_rewrite LevelExprSet.add_spec. + setoid_rewrite In_add_prems. + unfold LevelExprSet.E.eq. firstorder. subst. now left. } + 2:{ intros x. rewrite !In_add_prems. firstorder. } + eapply (in_pred_closure_shift _ H). Qed. -Lemma total_model_of_union {U V cls} : total_model_of U cls -> total_model_of V cls -> total_model_of (LevelSet.union U V) cls. +Lemma entails_subset cls (prems prems' : nonEmptyLevelExprSet) concl : LevelExprSet.Subset prems prems' -> + entails cls (prems, concl) -> + entails cls (prems', concl). Proof. - intros hu hv x. - rewrite LevelSet.union_spec; move => [] hin. - now apply hu. now apply hv. + intros hsubt. + intros H; revert prems' hsubt; depind H. + - constructor. eapply hsubt, H. + - intros prems'' hsub. + eapply clause_cut. 2:eapply IHentails. tea. + 2:lesets. intros x; rewrite !LevelExprSet.add_spec. firstorder. Qed. -Lemma total_model_of_union_inv U V cls : total_model_of (LevelSet.union U V) cls -> total_model_of U cls /\ total_model_of V cls. -Proof. - rewrite /total_model_of. - setoid_rewrite LevelSet.union_spec. firstorder. +Lemma entails_trans {cls prems concl concl'} : + entails cls (prems, concl) -> + entails cls (singleton concl, concl') -> + entails cls (prems, concl'). +Proof. + intros H; depind H. + - intros he. + depelim he. + * rewrite LevelExprSet.singleton_spec in H0. red in H0; subst concl0. + now constructor. + * eapply (clause_cut _ prems'). tea. + eapply entails_subset; tea. + intros ?; rewrite !LevelExprSet.add_spec LevelExprSet.singleton_spec; firstorder. + red in H2; subst a. now right. intros x. firstorder. apply H1 in H2. + rewrite LevelExprSet.singleton_spec in H2. now red in H2; subst x. + - intros he. + specialize (IHentails concl'0 he). + eapply clause_cut; tea. Qed. - -Lemma strictly_updates_total_model_gen cls W m m' : - strictly_updates cls W m m' -> - forall W', total_model_of W' m -> total_model_of (LevelSet.union W' W) m'. +Lemma entails_weak {cls prem concl concl'} : + entails cls (prem, concl) -> + entails cls (add concl' prem, concl). Proof. - clear. - induction 1. - - intros W' tot x. - destruct cl as [prems [concl cl]]. - destruct H0 as [minv [hmin ? ? heq]]. setoid_rewrite heq. - setoid_rewrite LevelMapFact.F.add_mapsto_iff. cbn. - destruct (Level.eq_dec concl x). - { subst. exists (Z.of_nat cl + minv). now left. } - { rewrite LevelSet.union_spec; intros [hin|hin]. - { eapply tot in hin as [wit mt]. exists wit. now right. } - { eapply LevelSet.singleton_spec in hin. red in hin; subst. congruence. } } - - intros W' tot. - eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. - eapply total_model_of_subset; tea. intros x; lsets. + intros H. depind H. + - constructor. apply LevelExprSet.add_spec. now right. + - eapply (clause_cut _ _ concl'); tea. + rewrite add_comm. apply IHentails. + intros x; rewrite LevelExprSet.add_spec. firstorder. Qed. -Lemma total_model_of_empty m : total_model_of LevelSet.empty m. -Proof. intros x; now move/LevelSet.empty_spec. Qed. - -Instance total_model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) total_model_of. +Lemma entails_weak_union {cls prem concl concl'} : + entails cls (prem, concl) -> + entails cls (univ_union concl' prem, concl). Proof. - intros ? ? H ? ? H'. unfold total_model_of. setoid_rewrite H. - now setoid_rewrite H'. + intros hyp. + move: concl'. + apply: nonEmptyLevelExprSet_elim. + - intros le. rewrite univ_union_comm univ_union_add_singleton. + now apply entails_weak. + - intros le prems ih. + rewrite univ_union_add_distr. + now eapply entails_weak. Qed. -Lemma strictly_updates_total_model {cls W m m'} : - strictly_updates cls W m m' -> - total_model_of W m'. +Lemma entails_all_weak {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (add concl' prem) concl. Proof. - move/strictly_updates_total_model_gen/(_ LevelSet.empty). - intros H. forward H. apply total_model_of_empty. - rewrite LevelSetProp.empty_union_1 in H => //. lsets. + intros hcl x hin. + specialize (hcl _ hin). cbn in hcl. + now apply entails_weak. Qed. -Lemma is_update_of_total_model cls W m m' : is_update_of cls W m m' -> total_model_of W m'. +Lemma entails_all_weak_union {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (univ_union concl' prem) concl. Proof. - move/is_update_of_case => []. - - intros [he ->]. - rewrite /total_model_of. lsets. - - eapply strictly_updates_total_model. + intros hcl x hin. + specialize (hcl _ hin). cbn in hcl. + now apply entails_weak_union. Qed. -Instance model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) model_of. +Lemma entails_all_weak' {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (add concl' prem) (add concl' concl). Proof. - intros ? ? H ? ? H'. unfold model_of. setoid_rewrite H. - now setoid_rewrite H'. + intros hcl x hin. + eapply LevelExprSet.add_spec in hin as []. red in H; subst. + - constructor. eapply LevelExprSet.add_spec. now left. + - specialize (hcl _ H). cbn in hcl. + now apply entails_weak. Qed. -Lemma model_of_union U V cls : model_of U cls -> model_of V cls -> model_of (LevelSet.union U V) cls. +Lemma entails_cut_all {cls prems' concl' prems concls} : + in_pred_closure cls (prems', concl') -> + cls ⊢a add concl' prems → concls -> + prems' ⊂_leset prems -> + cls ⊢a prems → concls. Proof. - intros hu hv x. - rewrite LevelSet.union_spec; move => [] hin. - now apply hu. now apply hv. + intros inp he hp x hin. + eapply clause_cut; tea. + now apply he in hin. Qed. -Lemma model_of_union_inv U V cls : model_of (LevelSet.union U V) cls -> model_of U cls /\ model_of V cls. +Lemma entails_all_subset {cls} {prems prems' prems'' : nonEmptyLevelExprSet} : + prems'' ⊂_leset prems' -> + cls ⊢a prems → prems' -> + cls ⊢a prems → prems''. Proof. - rewrite /model_of. - setoid_rewrite LevelSet.union_spec. firstorder. + intros incl ha x hin. + eapply incl in hin. now apply ha in hin. Qed. -Lemma strict_update_modify m cl m' : strict_update m cl m' -> - exists k, LevelMap.Equal m' (LevelMap.add (clause_conclusion cl) (Some k) m). +(* Lemma entails_all_one {cls prems concl concl'} : + entails_all cls prems concl -> + entails cls (univ_union concl prems, concl') -> + entails cls (prems, concl'). Proof. - rewrite /strict_update. - destruct cl as [prems [concl k]]. - intros [v [hmin hlt hab eq]]. now exists (Z.of_nat k + v). -Qed. + intros hall he; depind he. + - eapply LevelExprSet.union_spec in H as []. + 2:now constructor. + now eapply hall in H. + - eapply clause_cut in he; tea. 3:reflexivity. specialize (IHhe _ _ concl0 hall). *) -Lemma strictly_updates_model_of_gen {cls W m m'} : - strictly_updates cls W m m' -> forall W', model_of W' m -> model_of (LevelSet.union W' W) m'. +Lemma entails_all_add cls prem l prems' : + cls ⊢a prem → add l prems' <-> + cls ⊢ prem → l /\ cls ⊢a prem → prems'. Proof. - induction 1. - - intros W' mw'. - intros k. rewrite LevelSet.union_spec LevelSet.singleton_spec //=. - specialize (mw' k). - eapply strict_update_modify in H0 as [k' ->]. - rewrite LevelMapFact.F.add_in_iff. firstorder. now left. - - intros W' mw'. eapply IHstrictly_updates1 in mw'. - eapply IHstrictly_updates2 in mw'. - now rewrite -LevelSetProp.union_assoc. + rewrite /entails_all /LevelExprSet.For_all. + setoid_rewrite LevelExprSet.add_spec; rewrite /LevelExprSet.E.eq. + firstorder. now subst. Qed. -Lemma model_of_empty m : model_of LevelSet.empty m. -Proof. intros x; now move/LevelSet.empty_spec. Qed. - -Lemma strictly_updates_model_of {cls W m m'} : - strictly_updates cls W m m' -> model_of W m'. +Lemma entails_add {cls prems cl concl} : + entails cls (prems, cl) -> + entails cls (add cl prems, concl) -> + entails cls (prems, concl). Proof. - move/strictly_updates_model_of_gen/(_ LevelSet.empty). - rewrite LevelSetProp.empty_union_1. lsets. - intros H; apply H. apply model_of_empty. + intros H; depind H. + - intros he. + depelim he. + * rewrite LevelExprSet.add_spec in H0. destruct H0 as []. + { red in H0; subst concl0. now constructor. } + { now constructor. } + * have eq : prems = add concl0 prems. + { eapply eq_univ'. intros x; rewrite LevelExprSet.add_spec. firstorder. now red in H2; subst. } + rewrite -eq in H1. + eapply (clause_cut _ prems' _ prems). tea. 2:tea. + now rewrite -eq in he. + - intros he. + eapply clause_cut. tea. eapply IHentails. + rewrite add_comm. now eapply entails_weak. + exact H1. Qed. -Lemma strictly_updates_modify {cls W m m'} : - strictly_updates cls W m m' -> - forall l k, LevelMap.MapsTo l k m' -> LevelSet.In l W \/ LevelMap.MapsTo l k m. +Lemma entails_cumul_one {cls prems prems' concl} : + entails_all cls prems prems' -> + entails cls (univ_union prems prems', concl) -> + entails cls (prems, concl). Proof. - induction 1. - + eapply strict_update_modify in H0 as [k eq]. - intros l k'. rewrite LevelSet.singleton_spec. - rewrite eq. - rewrite LevelMapFact.F.add_mapsto_iff. - intros [[]|] => //. red in H0; subst. - left. lsets. now right. - + intros. eapply IHstrictly_updates2 in H1. - destruct H1. left; lsets. - eapply IHstrictly_updates1 in H1 as []. left; lsets. - now right. + revert prems' prems concl. + apply: nonEmptyLevelExprSet_elim. + - intros. specialize (H le). forward H by now apply LevelExprSet.singleton_spec. + cbn in H. + eapply entails_add; tea. + now rewrite -univ_union_add_singleton. + - intros le prems ih prem concl' hadd hadd'. + rewrite univ_union_comm univ_union_add_distr -univ_union_comm -univ_union_add_distr in hadd'. + eapply ih in hadd'. 2:{ apply entails_all_weak. apply entails_all_add in hadd as []. exact H0. } + apply entails_all_add in hadd as []. + eapply entails_add; tea. Qed. -Lemma strictly_updates_modify_inv {cls W m m'} : - strictly_updates cls W m m' -> - forall l k, LevelMap.MapsTo l k m -> LevelSet.In l W \/ LevelMap.MapsTo l k m'. +Lemma entails_all_cumul {cls prems prems' concl} : + entails_all cls prems prems' -> + entails_all cls (univ_union prems prems') concl -> + entails_all cls prems concl. Proof. - induction 1. - + eapply strict_update_modify in H0 as [k eq]. - intros l k'. rewrite LevelSet.singleton_spec. - rewrite eq. - rewrite LevelMapFact.F.add_mapsto_iff. - intros hm. unfold Level.eq. - destruct (eq_dec l (clause_conclusion cl)). subst. now left. - right. right. auto. - + intros. eapply IHstrictly_updates1 in H1 as []. - left; lsets. - eapply IHstrictly_updates2 in H1 as []. left; lsets. - now right. + intros hp hc. + intros x hin. apply hc in hin. + eapply entails_cumul_one; tea. Qed. -Lemma strictly_updates_outside cls W m m' : - strictly_updates cls W m m' -> model_map_outside W m m'. +Lemma entails_all_one {cls prem concl concl'} : + entails_all cls prem concl -> + entails cls (concl, concl') -> + entails cls (prem, concl'). Proof. - move=> su. - have lr := strictly_updates_modify su. - have rl := strictly_updates_modify_inv su. - intros l nin k. - split; intros. - - apply rl in H as [] => //. - - apply lr in H as [] => //. + intros ha he. + eapply entails_cumul_one; tea. + now eapply entails_weak_union. Qed. -Lemma valid_model_model_map_outside {W W' m cls} (vm : valid_model W W' m cls) : model_map_outside W m (model_model vm). +Lemma entails_all_trans {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls concl concl' -> + entails_all cls prem concl'. Proof. - destruct vm as [m' mV mupd mcls mok]; cbn. - - move/is_update_of_case: mupd => []. - * intros [ne <-]. red. intros. reflexivity. - * intros su. eapply (model_map_outside_weaken (W:=W')). - 2:{ eapply strictly_updates_incl in su. lsets. } - clear -su. revert su. - eapply strictly_updates_outside. + intros ha he cl hin. + apply he in hin. + eapply entails_all_one; tea. Qed. +Lemma entails_incr_shift cls concl k n : entails cls (singleton (concl, k), (concl, k + 1)) -> + entails cls (singleton (concl, k), (concl, k + 1 + n)). +Proof. + induction n in k |- *; auto. + - now rewrite Nat.add_0_r. + - intros en. + have hs := entails_shift 1 en. rewrite add_clause_singleton /= in hs. + apply IHn in hs. + rewrite -Nat.add_assoc Nat.add_1_l in hs. + now eapply entails_trans. +Qed. -Lemma check_model_has_invariants {cls w m w' m'} : - model_of (clauses_conclusions cls) m -> - total_model_of w m -> - check_model cls (w, m) = Some (w', m') -> - check_model_invariants cls w m w' m' true. +Lemma entails_incr_all cls concl k : entails cls (singleton (concl, k), (concl, k + 1)) -> + forall k', entails cls (singleton (concl, k), (concl, k')). Proof. - intros mof tot. - move/check_model_spec => [w'' [su ->]]. - cbn. split. - - lsets. - - apply strictly_updates_incl in su. lsets. - - clear -su. induction su. - * exists cl. split => //. now eapply strict_update_invalid. - unfold clause_conclusion. lsets. - destruct cl as [prems [concl k]]. - destruct H0 as [minp [hin hlt hnabove habove]]. - move: hnabove habove. rewrite /level_value_above. - cbn. destruct level_value eqn:hv => //; try constructor. - intros hle. intros ->. rewrite level_value_add. constructor. - move/negbTE: hle. lia. - * destruct IHsu1 as [cl []]. - exists cl. split => //. lsets. - apply strictly_updates_ext in su2. - depelim H2; rewrite ?H3. 2:{ rewrite H2; constructor. } - eapply level_value_MapsTo', su2 in H4 as [k' [map le]]. - eapply level_value_MapsTo in map. rewrite map. depelim le; constructor. lia. - - constructor. now eapply strictly_updates_ext. - clear -mof su. - induction su. - * move: H0; unfold strict_update. destruct cl as [prems [concl k]]. - intros [v [hmi hlt nabove eqm]]. intros l. rewrite eqm. - rewrite LevelMapFact.F.add_in_iff. specialize (mof l). - rewrite clauses_conclusions_spec in mof. firstorder. - * specialize (IHsu1 mof). transitivity m' => //. - apply IHsu2. intros l hin. specialize (mof _ hin). now apply IHsu1 in mof. - * eapply model_map_outside_weaken. now eapply strictly_updates_outside. lsets. - - eapply strictly_updates_total_model_gen in su; tea. + intros en k'. + destruct (Nat.lt_trichotomy k k') as [|[]]; subst; auto. + - eapply (entails_incr_shift _ _ _ (k' - k - 1)) in en. + assert (k + 1 + (k' - k - 1) = k') by lia. now rewrite H0 in en. + - constructor. now rewrite LevelExprSet.singleton_spec. + - have [k0 ->] : (exists kd, k = k' + kd). { exists (k - k'). lia. } + eapply (entails_pred_closure_n (n:=k0)). constructor. now apply LevelExprSet.singleton_spec. Qed. -Lemma clauses_levels_conclusions cls V : clauses_levels cls ⊂_lset V -> - clauses_conclusions cls ⊂_lset V. +Lemma entails_all_concl_union {cls prems concl concl'} : + cls ⊢a prems → concl -> + cls ⊢a prems → concl' -> + cls ⊢a prems → univ_union concl concl'. Proof. - intros hin x; rewrite clauses_conclusions_spec; move => [cl [hin' eq]]; apply hin. - rewrite clauses_levels_spec. exists cl. split => //. subst x. - rewrite clause_levels_spec. now right. + intros l r. + rewrite /entails_all. + intros x. rewrite univ_union_spec. intros []. now apply l. now apply r. Qed. -Definition clauses_premises_levels (cls : clauses) : LevelSet.t := - Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls LevelSet.empty. -Lemma clauses_premises_levels_spec_aux l cls acc : - LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls acc) <-> - (exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl))) \/ LevelSet.In l acc. +Lemma entails_all_union {cls prems concl prems' concl'} : + cls ⊢a prems → concl -> + cls ⊢a prems' → concl' -> + cls ⊢a univ_union prems prems' → univ_union concl concl'. Proof. - eapply ClausesProp.fold_rec. - - intros. - intuition auto. destruct H1 as [k [hin hl]]. clsets. - - intros x a s' s'' hin nin hadd ih. - rewrite LevelSet.union_spec. - split. - * intros [hin'|]. - left. exists x. split => //. - apply hadd. now left. - apply ih in H. - intuition auto. - left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. - * intros [[k [ins'' ?]]|inacc]. - eapply hadd in ins''. destruct ins''; subst. - + now left. - + right. apply ih. now left; exists k. - + right. intuition auto. + intros l r. + apply entails_all_concl_union. + rewrite univ_union_comm. + now eapply entails_all_weak_union. + now eapply entails_all_weak_union. Qed. -Lemma clauses_premises_levels_spec l cls : - LevelSet.In l (clauses_premises_levels cls) <-> - exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl)). -Proof. - unfold clauses_premises_levels. - rewrite clauses_premises_levels_spec_aux. - intuition auto. lsets. -Qed. -Lemma clauses_levels_premises cls V : clauses_levels cls ⊂_lset V -> - clauses_premises_levels cls ⊂_lset V. +Lemma entails_all_shift {cls : clauses} {prems concl : univ} (n : nat) : + cls ⊢a prems → concl -> + cls ⊢a add_prems n prems → add_prems n concl. Proof. - intros hin x; rewrite clauses_premises_levels_spec; move => [cl [hin' eq]]; apply hin. - rewrite clauses_levels_spec. exists cl. split => //. - rewrite clause_levels_spec. now left. + intros cla cl. + rewrite In_add_prems => [[le' [hin ->]]]. + eapply (entails_shift (cl := (prems, le'))). + now apply cla in hin. Qed. -Lemma clauses_premises_levels_incl cls : clauses_premises_levels cls ⊂_lset clauses_levels cls. +Lemma in_pred_closure_subset {cls cls' prems concl} : + in_pred_closure cls (prems, concl) -> + cls ⊂_clset cls' -> + in_pred_closure cls' (prems, concl). Proof. - intros x; rewrite clauses_premises_levels_spec clauses_levels_spec; move => [cl [hin' eq]]. - exists cl; split => //. - rewrite clause_levels_spec. now left. + induction 1. + - move/(_ _ H). now constructor. + - constructor. Qed. -Lemma clauses_premises_levels_mon {cls cls'} : cls ⊂_clset cls' -> - clauses_premises_levels cls ⊂_lset clauses_premises_levels cls'. +Lemma entails_clauses_subset cls cls' prems concl : + cls ⊢ prems → concl -> + cls ⊂_clset cls' -> + cls' ⊢ prems → concl. Proof. - intros hin x; rewrite !clauses_premises_levels_spec; move => [cl [hin' eq]]. - exists cl; split => //. now apply hin. + induction 1 in cls' |- * => incl. + - now constructor. + - eapply clause_cut. + + eapply in_pred_closure_subset; tea. + + now apply IHentails. + + assumption. Qed. -Definition monotone_selector sel := - forall cls' cls, cls' ⊂_clset cls -> sel cls' ⊂_lset sel cls. - -Lemma clauses_levels_mon : monotone_selector clauses_levels. +Lemma entails_all_clauses_subset cls cls' prems concl : + cls ⊢a prems → concl -> + cls ⊂_clset cls' -> + cls' ⊢a prems → concl. Proof. - intros cls' cls hin x; rewrite !clauses_levels_spec; move => [cl [hin' eq]]. - exists cl; split => //. now apply hin. + intros d incl [l k]. + now move/d/entails_clauses_subset. Qed. -Definition infers_atom (m : model) (l : Level.t) (k : Z) := Some k ≤ level_value m l. - -Definition max_premise_model cls sel m := - (forall l, LevelSet.In l (sel cls) -> - LevelMap.MapsTo l (Some (Z.of_nat (max_clause_premise cls))) m) /\ - (forall l k, LevelMap.MapsTo l (Some k) m -> LevelSet.In l (sel cls) /\ k = Z.of_nat (max_clause_premise cls)). +Definition to_clauses (prems : nonEmptyLevelExprSet) (concl : nonEmptyLevelExprSet) : clauses := + LevelExprSet.fold (fun lk cls => Clauses.add (prems, lk) cls) concl Clauses.empty. -Definition max_premise_map cls : model := - let max := max_clause_premise cls in - let ls := clauses_levels cls in - LevelSet.fold (fun l acc => LevelMap.add l (Some (Z.of_nat max)) acc) ls (LevelMap.empty _). +Definition is_loop (cls : clauses) (t : nonEmptyLevelExprSet) := + let cls' := to_clauses t (succ_prems t) in + Clauses.For_all (fun cl' => entails cls cl') cls'. -Definition above_max_premise_model cls m := - (exists V, strictly_updates cls V (max_premise_map cls) m) \/ m = max_premise_map cls. +(* Definition is_looping (w : LevelSet.t) n (cls : clauses) := + let preml := LevelSet.elements w in + let prem := List.map (fun e => (e, n)) preml in + is_loop cls prem. *) -Lemma max_premise_model_exists cls : max_premise_model cls clauses_levels (max_premise_map cls). -Proof. - rewrite /max_premise_map; split. - - intros l. - eapply LevelSetProp.fold_rec. - { intros s he hin. now apply he in hin. } - intros. - destruct (Level.eq_dec l x). subst. - * eapply LevelMapFact.F.add_mapsto_iff. left; split => //. - * eapply LevelMapFact.F.add_mapsto_iff. right. split => //. now unfold Level.eq. apply H2. - specialize (H1 l). apply H1 in H3. destruct H3 => //. congruence. - - intros l k. - eapply LevelSetProp.fold_rec. - { intros s' he hm. now eapply LevelMapFact.F.empty_mapsto_iff in hm. } - intros. - eapply LevelMapFact.F.add_mapsto_iff in H3 as []. - * destruct H3. noconf H4. split => //. apply H1. now left. - * destruct H3. firstorder. -Qed. +Definition levelexprset_of_levels (ls : LevelSet.t) n : LevelExprSet.t := + LevelSet.fold (fun x => LevelExprSet.add (x, n)) ls LevelExprSet.empty. -Lemma infer_atom_downward {m l k k'} : - infers_atom m l k -> - (k' <= k)%Z -> - infers_atom m l k'. +Lemma levelexprset_of_levels_spec {ls : LevelSet.t} {l k n} : + LevelExprSet.In (l, k) (levelexprset_of_levels ls n) <-> LevelSet.In l ls /\ k = n. Proof. - rewrite /infers_atom. - intros infa le. - transitivity (Some k) => //. now constructor. + rewrite /levelexprset_of_levels. + eapply LevelSetProp.fold_rec. + - intros s' he. rewrite LevelExprSetFact.empty_iff. firstorder. + - intros x a s' s'' hin hnin hadd ih. + rewrite LevelExprSet.add_spec; unfold LevelExprSet.E.eq. + firstorder eauto; try noconf H1 => //. + apply hadd in H1. firstorder. subst. now left. Qed. -Lemma infers_atom_le {m m' l k} : - infers_atom m l k -> - m ⩽ m' -> - infers_atom m' l k. -Proof. - rewrite /infers_atom. - intros infa le. - depelim infa. eapply level_value_MapsTo' in H0. eapply le in H0 as [k' [hm hle]]. - depelim hle. - rewrite (level_value_MapsTo hm). constructor; lia. +#[program] +Definition of_level_set (ls : LevelSet.t) n (hne : ~ LevelSet.Empty ls) : nonEmptyLevelExprSet := + {| t_set := levelexprset_of_levels ls n |}. +Next Obligation. + apply not_Empty_is_empty => he. apply hne. + intros l nin. specialize (he (l,n)). apply he. + now rewrite levelexprset_of_levels_spec. Qed. -Lemma infers_atom_mapsto m l k : infers_atom m l k <-> - exists k', LevelMap.MapsTo l (Some k') m /\ k <= k'. -Proof. - rewrite /infers_atom; split. - - intros hle; depelim hle. - eapply level_value_MapsTo' in H0. exists y. split => //. - - intros [k' [hm hle]]. - eapply level_value_MapsTo in hm. rewrite hm. now constructor. -Qed. +Definition loop_on_univ cls u := cls ⊢a u → succ_prems u. -Lemma above_max_premise_model_infers {cls m} : - above_max_premise_model cls m -> - (forall l, LevelSet.In l (clauses_levels cls) -> infers_atom m l (Z.of_nat (max_clause_premise cls))). -Proof. - intros ha l hl. - have hm := max_premise_model_exists cls. - destruct ha as [[V su]|eq]. - * eapply strictly_updates_ext in su. - eapply infers_atom_le; tea. - eapply infers_atom_mapsto. - destruct hm. exists (Z.of_nat (max_clause_premise cls)). split => //. 2:lia. - now eapply H. - * subst m. eapply infers_atom_mapsto. destruct hm. - specialize (H l hl). eexists; split. exact H. lia. -Qed. +(* Definition loop_on W (hne : ~ LevelSet.Empty W) n cls := + cls ⊢a of_level_set W n hne → of_level_set W (n + 1) hne. -(* Lemma max_premise_model_above cls sel sel' m : - (sel' cls ⊂_lset sel cls) -> - max_premise_model cls sel m -> - above_max_premise_model cls m. +Lemma loop_on_proper W W' n hne' cls : W =_lset W' -> exists hne, loop_on W hne n cls -> loop_on W' hne' n cls. Proof. - move=> incl mp l hl; move: (proj1 mp l (incl _ hl)); rewrite /infers_atom. - move/level_value_MapsTo => ->. reflexivity. + intros eq; rewrite /loop_on /loop_on_univ. + assert (hne : ~ LevelSet.Empty W). now rewrite eq. + exists hne. + assert (of_level_set W n hne = of_level_set W' n hne') as ->. + apply eq_univ'. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. + assert (of_level_set W (n + 1) hne = of_level_set W' (n + 1) hne') as ->. + apply eq_univ'. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. + by []. Qed. *) - -Lemma clauses_with_concl_union cls W W' : - Clauses.Equal (clauses_with_concl cls (LevelSet.union W W')) - (Clauses.union (clauses_with_concl cls W) (clauses_with_concl cls W')). -Proof. - intros x. rewrite Clauses.union_spec !in_clauses_with_concl LevelSet.union_spec. - firstorder. -Qed. - -Lemma strictly_updates_strenghten {cls W m m'} : - strictly_updates cls W m m' -> - strictly_updates (cls ↓ W) W m m'. +Lemma loop_on_subset {cls cls' u} : Clauses.Subset cls cls' -> loop_on_univ cls u -> loop_on_univ cls' u. Proof. - induction 1. - - constructor. rewrite in_clauses_with_concl. split => //. - eapply LevelSet.singleton_spec; reflexivity. exact H0. - - rewrite clauses_with_concl_union. econstructor 2. - eapply strictly_updates_weaken; tea. intros x; clsets. - eapply strictly_updates_weaken; tea. intros x; clsets. -Qed. -Lemma clauses_with_concl_subset cls W : (cls ↓ W) ⊂_clset cls. -Proof. now intros ?; rewrite in_clauses_with_concl. Qed. +Admitted. -Ltac rw l := rewrite_strat (topdown l). -Ltac rw_in l H := rewrite_strat (topdown l) in H. +Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := + | Loop (v : univ) (islooping : loop_on_univ cls v) + | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). +Arguments Loop {V U cls m}. +Arguments Model {V U cls m}. +Arguments lexprod {A B}. + +Definition option_of_result {V U m cls} (r : result V U m cls) : option model := + match r with + | Model w m _ => Some m.(model_model) + | Loop w hne _ isloop => None + end. + +Notation "#| V |" := (LevelSet.cardinal V). + +Notation loop_measure V W := (#|V|, #|V| - #|W|)%nat. + +Definition lexprod_rel := lexprod lt lt. + +#[local] Instance lexprod_rel_wf : WellFounded lexprod_rel. +Proof. + eapply (Acc_intro_generator 1000). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. +Defined. + +Lemma strictly_updates_trans {cls cls' W W' m m' m''} : + strictly_updates cls W m m' -> + strictly_updates cls' W' m' m'' -> + strictly_updates (Clauses.union cls cls') (LevelSet.union W W') m m''. + Proof. + intros su su'. + eapply update_trans; eapply strictly_updates_weaken; tea; clsets. + Qed. + +Lemma check_model_is_update_of {cls cls' U W minit m m'} : is_update_of cls U minit m -> check_model cls' (U, m) = Some (W, m') -> + strictly_updates (Clauses.union cls cls') W minit m' /\ U ⊂_lset W. +Proof. + rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros ->. eapply LevelSetFact.is_empty_2 in he. + eapply LevelSetProp.empty_is_empty_1 in he. + eapply LevelSet.eq_leibniz in he. rewrite he. + move/check_model_updates_spec_empty. intros H; split => //. 2:lsets. + eapply strictly_updates_weaken; tea. clsets. + - intros hs. move/check_model_spec => [w'' [su ->]]. split; [|lsets]. + eapply strictly_updates_trans; tea. +Qed. + +Lemma is_update_of_case cls W m m' : + is_update_of cls W m m' -> + (LevelSet.Empty W /\ m =m m') \/ strictly_updates cls W m m'. +Proof. + rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros ->. left => //. now eapply LevelSetFact.is_empty_2 in he. + - intros H; now right. +Qed. + + +Lemma model_incl {V W m cls} : valid_model V W m cls -> W ⊂_lset V. +Proof. + intros vm; have upd := model_updates vm. + move/is_update_of_case: upd => []. + - intros [ne eq]. lsets. + - move/strictly_updates_incl. have hv := model_clauses_conclusions vm. lsets. +Qed. + +(* + model_of_W : model_of W model_model; + model_incl : ; +model_extends : model_extension V m model_model; + +Arguments model_of_W {V W m cls}. +Arguments model_incl {V W m cls}. +Arguments model_extends {V W m cls}. + *) + +Lemma model_of_ext {W m m'} : + model_of W m -> m ⩽ m' -> model_of W m'. +Proof. + intros mof ext. + intros k hin. destruct (mof k hin). specialize (ext _ _ H) as [k' []]. now exists k'. +Qed. + +Lemma valid_model_total W W' m cls : + forall vm : valid_model W W' m cls, model_of W m -> model_of W (model_model vm). +Proof. + intros []; cbn => htot. + move/is_update_of_case: model_updates0 => []. + - intros [ne eq] => //. + - intros su. eapply strictly_updates_ext in su. + eapply model_of_ext; tea. +Qed. + +Lemma is_update_of_ext {cls W m m'} : is_update_of cls W m m' -> m ⩽ m'. +Proof. + move/is_update_of_case => []. + - intros [he%LevelSetProp.empty_is_empty_1]. red. setoid_rewrite H. firstorder. + - apply strictly_updates_ext. +Qed. + +Lemma model_of_union {U V cls} : model_of U cls -> model_of V cls -> model_of (LevelSet.union U V) cls. +Proof. + intros hu hv x. + rewrite LevelSet.union_spec; move => [] hin. + now apply hu. now apply hv. +Qed. + +Lemma model_of_union_inv U V cls : model_of (LevelSet.union U V) cls -> model_of U cls /\ model_of V cls. +Proof. + rewrite /model_of. + setoid_rewrite LevelSet.union_spec. firstorder. +Qed. + +Lemma strictly_updates_model_of_gen cls W m m' : + strictly_updates cls W m m' -> + forall W', model_of W' m -> model_of (LevelSet.union W' W) m'. +Proof. + clear. + induction 1. + - intros W' tot x. + destruct cl as [prems [concl cl]]. + destruct H0 as [minv [hmin ? ? heq]]. setoid_rewrite heq. + setoid_rewrite LevelMapFact.F.add_in_iff. cbn. + destruct (Level.eq_dec concl x). + { now left. } + { rewrite LevelSet.union_spec; intros [hin|hin]. + { eapply tot in hin as [wit mt]. right; exists wit. assumption. } + { eapply LevelSet.singleton_spec in hin. red in hin; subst. congruence. } } + - intros W' tot. + eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. + eapply model_of_subset; tea. intros x; lsets. +Qed. + + +Lemma model_of_empty m : model_of LevelSet.empty m. +Proof. intros x; now move/LevelSet.empty_spec. Qed. + +Instance model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) model_of. +Proof. + intros ? ? H ? ? H'. unfold model_of. setoid_rewrite H. + now setoid_rewrite H'. +Qed. + +Lemma strictly_updates_total_model {cls W m m'} : + strictly_updates cls W m m' -> + model_of W m'. +Proof. + move/strictly_updates_model_of_gen/(_ LevelSet.empty). + intros H. forward H. apply model_of_empty. + rewrite LevelSetProp.empty_union_1 in H => //. lsets. +Qed. + +Lemma strictly_updates_only_model_gen cls W m m' : + strictly_updates cls W m m' -> + forall W', only_model_of W' m -> only_model_of (LevelSet.union W' W) m'. +Proof. + clear. + induction 1. + - intros W' tot x. + destruct cl as [prems [concl cl]]. + destruct H0 as [minv [hmin ? ? heq]]. setoid_rewrite heq. + setoid_rewrite LevelMapFact.F.add_mapsto_iff. cbn. + destruct (Level.eq_dec concl x). + { subst. rewrite LevelSet.union_spec LevelSet.singleton_spec. + firstorder; exists (cl + Z.to_nat minv)%nat; left; split => //. } + { rewrite LevelSet.union_spec LevelSet.singleton_spec /LevelSet.E.eq. + firstorder. subst x. congruence. } + - intros W' tot. + eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. + eapply only_model_of_eq; tea. intros x; lsets. +Qed. + +Lemma is_update_of_total_model cls W m m' : is_update_of cls W m m' -> model_of W m'. +Proof. + move/is_update_of_case => []. + - intros [he eq]. + rewrite /model_of. lsets. + - eapply strictly_updates_total_model. +Qed. + +Lemma strict_update_modify m cl m' : strict_update m cl m' -> + exists k, LevelMap.Equal m' (LevelMap.add (clause_conclusion cl) k m). +Proof. + rewrite /strict_update. + destruct cl as [prems [concl k]]. + intros [v [hmin hlt hab eq]]. now exists (k + Z.to_nat v)%nat. +Qed. + +Lemma strictly_updates_model_of {cls W m m'} : + strictly_updates cls W m m' -> model_of W m'. +Proof. + move/strictly_updates_model_of_gen/(_ LevelSet.empty). + rewrite LevelSetProp.empty_union_1. lsets. + intros H; apply H. apply model_of_empty. +Qed. + +Lemma strictly_updates_modify {cls W m m'} : + strictly_updates cls W m m' -> + forall l k, LevelMap.MapsTo l k m' -> LevelSet.In l W \/ LevelMap.MapsTo l k m. +Proof. + induction 1. + + eapply strict_update_modify in H0 as [k eq]. + intros l k'. rewrite LevelSet.singleton_spec. + rewrite eq. + rewrite LevelMapFact.F.add_mapsto_iff. + intros [[]|] => //. red in H0; subst. + left. lsets. now right. + + intros. eapply IHstrictly_updates2 in H1. + destruct H1. left; lsets. + eapply IHstrictly_updates1 in H1 as []. left; lsets. + now right. +Qed. + +Lemma strictly_updates_modify_inv {cls W m m'} : + strictly_updates cls W m m' -> + forall l k, LevelMap.MapsTo l k m -> LevelSet.In l W \/ LevelMap.MapsTo l k m'. +Proof. + induction 1. + + eapply strict_update_modify in H0 as [k eq]. + intros l k'. rewrite LevelSet.singleton_spec. + rewrite eq. + rewrite LevelMapFact.F.add_mapsto_iff. + intros hm. unfold Level.eq. + destruct (eq_dec l (clause_conclusion cl)). subst. now left. + right. right. auto. + + intros. eapply IHstrictly_updates1 in H1 as []. + left; lsets. + eapply IHstrictly_updates2 in H1 as []. left; lsets. + now right. +Qed. + +Lemma strictly_updates_outside cls W m m' : + strictly_updates cls W m m' -> model_map_outside W m m'. +Proof. + move=> su. + have lr := strictly_updates_modify su. + have rl := strictly_updates_modify_inv su. + intros l nin k. + split; intros. + - apply rl in H as [] => //. + - apply lr in H as [] => //. +Qed. + +Lemma valid_model_model_map_outside {W W' m cls} (vm : valid_model W W' m cls) : model_map_outside W m (model_model vm). +Proof. + destruct vm as [m' mV mupd mcls mok]; cbn. + - move/is_update_of_case: mupd => []. + * intros [ne <-]. red. intros. reflexivity. + * intros su. eapply (model_map_outside_weaken (W:=W')). + 2:{ eapply strictly_updates_incl in su. lsets. } + clear -su. revert su. + eapply strictly_updates_outside. +Qed. + + +Lemma check_model_has_invariants {cls w m w' m'} : + model_of (clauses_conclusions cls) m -> + model_of w m -> + check_model cls (w, m) = Some (w', m') -> + check_model_invariants cls w m w' m' true. +Proof. + intros mof tot. + move/check_model_spec => [w'' [su ->]]. + cbn. split. + - lsets. + - apply strictly_updates_incl in su. lsets. + - clear -su. induction su. + * exists cl. split => //. now eapply strict_update_invalid. + unfold clause_conclusion. lsets. + destruct cl as [prems [concl k]]. + destruct H0 as [minp [hin hlt hnabove habove]]. + move: hnabove habove. rewrite /level_value_above. + cbn. destruct level_value eqn:hv => //; try constructor. + intros hle. intros ->. rewrite level_value_add. constructor. + move/negbTE: hle. lia. + * destruct IHsu1 as [cl []]. + exists cl. split => //. lsets. + apply strictly_updates_ext in su2. + depelim H2; rewrite ?H3. 2:{ rewrite H2; constructor. } + eapply level_value_MapsTo', su2 in H4 as [k' [map le]]. + eapply level_value_MapsTo in map. rewrite map. constructor; lia. + - constructor. now eapply strictly_updates_ext. + clear -mof su. + induction su. + * move: H0; unfold strict_update. destruct cl as [prems [concl k]]. + intros [v [hmi hlt nabove eqm]]. intros l. rewrite eqm. + rewrite LevelMapFact.F.add_in_iff. specialize (mof l). + rewrite clauses_conclusions_spec in mof. firstorder. + * specialize (IHsu1 mof). transitivity m' => //. + apply IHsu2. intros l hin. specialize (mof _ hin). now apply IHsu1 in mof. + * eapply model_map_outside_weaken. now eapply strictly_updates_outside. lsets. + - eapply strictly_updates_model_of_gen in su; tea. +Qed. + +Lemma clauses_levels_conclusions cls V : clauses_levels cls ⊂_lset V -> + clauses_conclusions cls ⊂_lset V. +Proof. + intros hin x; rewrite clauses_conclusions_spec; move => [cl [hin' eq]]; apply hin. + rewrite clauses_levels_spec. exists cl. split => //. subst x. + rewrite clause_levels_spec. now right. +Qed. +Definition clauses_premises_levels (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls LevelSet.empty. + +Lemma clauses_premises_levels_spec_aux l cls acc : + LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls acc) <-> + (exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl))) \/ LevelSet.In l acc. +Proof. + eapply ClausesProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k [hin hl]]. clsets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.union_spec. + split. + * intros [hin'|]. + left. exists x. split => //. + apply hadd. now left. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. + * intros [[k [ins'' ?]]|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma clauses_premises_levels_spec l cls : + LevelSet.In l (clauses_premises_levels cls) <-> + exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl)). +Proof. + unfold clauses_premises_levels. + rewrite clauses_premises_levels_spec_aux. + intuition auto. lsets. +Qed. + +Lemma clauses_levels_premises cls V : clauses_levels cls ⊂_lset V -> + clauses_premises_levels cls ⊂_lset V. +Proof. + intros hin x; rewrite clauses_premises_levels_spec; move => [cl [hin' eq]]; apply hin. + rewrite clauses_levels_spec. exists cl. split => //. + rewrite clause_levels_spec. now left. +Qed. + +Lemma clauses_premises_levels_incl cls : clauses_premises_levels cls ⊂_lset clauses_levels cls. +Proof. + intros x; rewrite clauses_premises_levels_spec clauses_levels_spec; move => [cl [hin' eq]]. + exists cl; split => //. + rewrite clause_levels_spec. now left. +Qed. + +Lemma clauses_premises_levels_mon {cls cls'} : cls ⊂_clset cls' -> + clauses_premises_levels cls ⊂_lset clauses_premises_levels cls'. +Proof. + intros hin x; rewrite !clauses_premises_levels_spec; move => [cl [hin' eq]]. + exists cl; split => //. now apply hin. +Qed. + +Definition monotone_selector sel := + forall cls' cls, cls' ⊂_clset cls -> sel cls' ⊂_lset sel cls. + +Lemma clauses_levels_mon : monotone_selector clauses_levels. +Proof. + intros cls' cls hin x; rewrite !clauses_levels_spec; move => [cl [hin' eq]]. + exists cl; split => //. now apply hin. +Qed. + +Definition infers_atom (m : model) (l : Level.t) (k : nat) := Some k ≤ level_value m l. + +Definition max_premise_model cls sel m := + (forall l, LevelSet.In l (sel cls) -> + LevelMap.MapsTo l (max_clause_premise cls) m) /\ + (forall l k, LevelMap.MapsTo l k m -> LevelSet.In l (sel cls) /\ k = max_clause_premise cls). + + +Definition max_premise_map cls : model := + let max := max_clause_premise cls in + let ls := clauses_levels cls in + LevelSet.fold (fun l acc => LevelMap.add l max acc) ls (LevelMap.empty _). + +Definition above_max_premise_model cls m := + (exists V, strictly_updates cls V (max_premise_map cls) m) \/ m = max_premise_map cls. + +Lemma max_premise_model_exists cls : max_premise_model cls clauses_levels (max_premise_map cls). +Proof. + rewrite /max_premise_map; split. + - intros l. + eapply LevelSetProp.fold_rec. + { intros s he hin. now apply he in hin. } + intros. + destruct (Level.eq_dec l x). subst. + * eapply LevelMapFact.F.add_mapsto_iff. left; split => //. + * eapply LevelMapFact.F.add_mapsto_iff. right. split => //. now unfold Level.eq. apply H2. + specialize (H1 l). apply H1 in H3. destruct H3 => //. congruence. + - intros l k. + eapply LevelSetProp.fold_rec. + { intros s' he hm. now eapply LevelMapFact.F.empty_mapsto_iff in hm. } + intros. + eapply LevelMapFact.F.add_mapsto_iff in H3 as []. + * destruct H3. noconf H4. split => //. apply H1. now left. + * destruct H3. firstorder. +Qed. + +Lemma infer_atom_downward {m l k k'} : + infers_atom m l k -> + (k' <= k)%nat -> + infers_atom m l k'. +Proof. + rewrite /infers_atom. + intros infa le. + transitivity (Some k) => //. now constructor. +Qed. + +Lemma infers_atom_le {m m' l k} : + infers_atom m l k -> + m ⩽ m' -> + infers_atom m' l k. +Proof. + rewrite /infers_atom. + intros infa le. + depelim infa. eapply level_value_MapsTo' in H0. eapply le in H0 as [k' [hm hle]]. + rewrite (level_value_MapsTo hm). constructor; lia. +Qed. + +Lemma infers_atom_mapsto m l k : infers_atom m l k <-> + exists k', LevelMap.MapsTo l k' m /\ (k <= k')%nat. +Proof. + rewrite /infers_atom; split. + - intros hle; depelim hle. + eapply level_value_MapsTo' in H0. exists y. split => //. + - intros [k' [hm hle]]. + eapply level_value_MapsTo in hm. rewrite hm. now constructor. +Qed. + +Lemma above_max_premise_model_infers {cls m} : + above_max_premise_model cls m -> + (forall l, LevelSet.In l (clauses_levels cls) -> infers_atom m l (max_clause_premise cls)). +Proof. + intros ha l hl. + have hm := max_premise_model_exists cls. + destruct ha as [[V su]|eq]. + * eapply strictly_updates_ext in su. + eapply infers_atom_le; tea. + eapply infers_atom_mapsto. + destruct hm. exists (max_clause_premise cls). split => //. + now eapply H. + * subst m. eapply infers_atom_mapsto. destruct hm. + specialize (H l hl). eexists; split. exact H. lia. +Qed. + +(* Lemma max_premise_model_above cls sel sel' m : + (sel' cls ⊂_lset sel cls) -> + max_premise_model cls sel m -> + above_max_premise_model cls m. +Proof. + move=> incl mp l hl; move: (proj1 mp l (incl _ hl)); rewrite /infers_atom. + move/level_value_MapsTo => ->. reflexivity. +Qed. *) + + +Lemma clauses_with_concl_union cls W W' : + Clauses.Equal (clauses_with_concl cls (LevelSet.union W W')) + (Clauses.union (clauses_with_concl cls W) (clauses_with_concl cls W')). +Proof. + intros x. rewrite Clauses.union_spec !in_clauses_with_concl LevelSet.union_spec. + firstorder. +Qed. + +Lemma strictly_updates_strenghten {cls W m m'} : + strictly_updates cls W m m' -> + strictly_updates (cls ↓ W) W m m'. +Proof. + induction 1. + - constructor. rewrite in_clauses_with_concl. split => //. + eapply LevelSet.singleton_spec; reflexivity. exact H0. + - rewrite clauses_with_concl_union. econstructor 2. + eapply strictly_updates_weaken; tea. intros x; clsets. + eapply strictly_updates_weaken; tea. intros x; clsets. +Qed. + +Lemma clauses_with_concl_subset cls W : (cls ↓ W) ⊂_clset cls. +Proof. now intros ?; rewrite in_clauses_with_concl. Qed. Section InnerLoop. Definition sum_W W (f : LevelSet.elt -> nat) : nat := @@ -3271,21 +3686,21 @@ Section InnerLoop. Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := sum_W W (fun w => Z.to_nat (measure_w W cls m w)). - Lemma maps_to_value_default {x k m} : LevelMap.MapsTo x k m -> level_value m x = k. + Lemma maps_to_value_default {x k m} : LevelMap.MapsTo x k m -> level_value m x = Some k. Proof. intros h; apply LevelMap.find_1 in h. now rewrite /level_value h. Qed. Lemma measure_model W cls m : - total_model_of W m -> + model_of W m -> let clsdiff := cls_diff cls W in measure W cls m = 0%nat -> is_model clsdiff m. Proof using. unfold measure, sum_W, measure_w, is_model. set (clsdiff := Clauses.diff _ _). intros hv hm. - assert (LevelSet.For_all (fun w => Some (v_minus_w_bound W m + Z.of_nat (max_gain clsdiff)) ≤ level_value m w)%Z W). + assert (LevelSet.For_all (fun w => Some (v_minus_w_bound W m + max_gain clsdiff) ≤ level_value m w)%nat W). { move: hm. generalize (v_minus_w_bound W m) => vbound. eapply LevelSetProp.fold_rec. @@ -3315,7 +3730,7 @@ Section InnerLoop. assert (ne : LevelExprSet.is_empty prem' = false). { now eapply (non_W_atoms_ne W (prem, (l, k)) cls). } set (preml := {| t_set := prem'; t_ne := ne |}). - assert (min_premise m prem ≤ min_premise m preml). + assert (min_premise m prem ≤Z min_premise m preml). { eapply min_premise_subset. eapply non_W_atoms_subset. } (* min_i (f(x_i)-k_i) <= max_i(f(x_i)) - min(k_i) *) pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. @@ -3324,7 +3739,7 @@ Section InnerLoop. pose proof (max_premise_value_spec m preml _ eqmaxp) as [amax [exmax [inmaxpre eqmaxpre]]]. rewrite -eqmaxp in eqmaxpre. pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. - assert (min_premise m preml ≤ Some (maxpreml - Z.of_nat (premise_min preml)))%Z. + assert (min_premise m preml ≤Z Some (Z.of_nat maxpreml - Z.of_nat (premise_min preml)))%Z. { rewrite eqminpre in H1. specialize (amax _ inminpre). destruct amax as [k' [lk' hk']]. depelim hk'. @@ -3333,33 +3748,20 @@ Section InnerLoop. rewrite eqmaxpre in eqmaxp. assert (expmin <= exmin)%nat. specialize (apmin _ inminpre). lia. unfold level_expr_elt in *. lia. } - apply Z.leb_le. rewrite H1 in H2. depelim H2. - transitivity (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)))%Z. lia. + apply Nat.leb_le. rewrite H1 in H2. depelim H2. + transitivity (k + (maxpreml - premise_min preml))%nat. lia. assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff)%nat. { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. unfold gain. cbn. pose proof (premise_min_subset preml prem). rewrite !Z2Nat.inj_sub //; try lia. rewrite !Nat2Z.id. forward H3. eapply non_W_atoms_subset. lia. } - transitivity (v_minus_w_bound W m + (gain (preml, (l, k))))%Z. + transitivity (v_minus_w_bound W m + Z.to_nat (gain (preml, (l, k))))%nat. 2:lia. unfold gain. cbn -[max_premise_value premise_min]. - (* assert (Z.of_nat (premise_min preml) <= maxpreml)%Z. - { - (* rewrite eqmaxpre. *) - move/min_premise_pos_spec: hk0 => hprem. - transitivity (Z.of_nat (levelexpr_k exmax)). - specialize (apmin _ inmaxpre). now apply inj_le. - rewrite eqmaxp in eqmaxpre. unfold levelexpr_value in eqmaxpre. - unfold levelexpr_k. - specialize (amax _ inmaxpre) as [k' [eqk' k'max]]. - eapply hprem. - now apply (non_W_atoms_subset W prem). } *) - assert (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)) = - (maxpreml + Z.of_nat k - Z.of_nat (premise_min preml)))%Z as ->. lia. - (* rewrite Z2Nat.inj_sub. lia. *) - (* rewrite !Nat2Z.id. *) - assert (maxpreml <= v_minus_w_bound W m)%Z. + assert (k + (maxpreml - premise_min preml) = + (maxpreml + k - premise_min preml))%nat as ->. lia. + assert (maxpreml <= v_minus_w_bound W m)%nat. { pose proof (v_minus_w_bound_spec W m exmax). have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). rewrite levelexprset_levels_spec in hlevels. @@ -3378,19 +3780,19 @@ Section InnerLoop. Proof. unfold level_value_default. now intros ->. Qed. Lemma w_values_ext m m' W : - m ⩽ m' -> total_model_of W m -> total_model_of W m'. + m ⩽ m' -> model_of W m -> model_of W m'. Proof. intros ext hf x hin. specialize (hf x hin) as [k hl]. specialize (ext _ _ hl) as [? []]. - depelim H0. now exists y. + now exists x0. Qed. Lemma level_values_in_W m m' W x : - total_model_of W m -> + model_of W m -> m ⩽ m' -> LevelSet.In x W -> level_value m x ≤ level_value m' x -> - exists k k', level_value m x = Some k /\ level_value m' x = Some k' /\ (k <= k')%Z. + exists k k', level_value m x = Some k /\ level_value m' x = Some k' /\ (k <= k')%nat. Proof. intros hwv ext hin hleq. specialize (hwv _ hin) as x'. destruct x' as [k hl]. rewrite (maps_to_value_default hl) in hleq. @@ -3403,7 +3805,7 @@ Section InnerLoop. Qed. Lemma measure_le {W cls m m'} : - total_model_of W m -> + model_of W m -> model_map_outside W m m' -> m ⩽ m' -> (measure W cls m' <= measure W cls m)%nat. @@ -3420,11 +3822,11 @@ Section InnerLoop. Qed. Lemma measure_lt {W cls m m'} : - total_model_of W m -> + model_of W m -> model_map_outside W m m' -> m ⩽ m' -> (exists l, [/\ LevelSet.In l W, (0 < measure_w W cls m l)%Z & - opt_le Z.lt (level_value m l) (level_value m' l)])%Z -> + opt_le Nat.lt (level_value m l) (level_value m' l)])%Z -> (measure W cls m' < measure W cls m)%nat. Proof. intros hwv hout hle. @@ -3449,7 +3851,7 @@ Section InnerLoop. intros acc acc' accle. eapply Nat.add_le_lt_mono => //. depelim hlev. rewrite /level_value_default ?H0 ?H1 in hbound |- *. - lia. now eapply total_model_of_value_None in H; tea. + lia. now eapply model_of_value_None in H; tea. Qed. Lemma is_model_equal {cls cls' m} : Clauses.Equal cls cls' -> is_model cls m -> is_model cls' m. @@ -3498,1120 +3900,1013 @@ Section InnerLoop. Lemma measure_Z_lt x y : (x < y)%Z -> (0 < y)%Z -> - (Z.to_nat x < Z.to_nat y)%nat. - Proof. intros. lia. Qed. - - Lemma sum_pos W f : - (0 < sum_W W f)%nat -> - exists w, LevelSet.In w W /\ (0 < f w)%nat. - Proof. - unfold sum_W. - eapply LevelSetProp.fold_rec => //. - intros. lia. - intros. - destruct (Nat.ltb_spec 0 a). - - destruct (H2 H4) as [w [hin hlt]]. exists w. split => //. apply H1. now right. - - exists x. split => //. apply H1. now left. lia. - Qed. - - Lemma measure_pos {W cls m} : - (0 < measure W cls m)%nat -> - exists l, LevelSet.In l W /\ (0 < measure_w W cls m l)%Z. - Proof. - unfold measure. - move/sum_pos => [w [hin hlt]]. - exists w. split => //. lia. - Qed. - - Lemma model_of_diff cls W m : - model_of W m -> model_of (clauses_conclusions (cls_diff cls W)) m. - Proof. - intros; eapply model_of_subset; tea. - eapply clauses_conclusions_diff_left. - Qed. - Hint Resolve model_of_diff : core. - - Lemma check_model_spec_diff {cls w m w' m' w''} : - model_of w m -> - total_model_of w'' m -> - let cls := (cls_diff cls w) in - check_model cls (w'', m) = Some (w', m') -> - [/\ w'' ⊂_lset w', w' ⊂_lset (w'' ∪ w), - exists cl : clause, - let cll := levelexpr_level (concl cl) in - [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' - & (opt_le Z.lt (level_value m cll) (level_value m' cll))%Z] - & model_extension w' m m']. - Proof. - cbn; intros mof tot cm. - pose proof (clauses_conclusions_diff_left cls w (cls ⇂ w)). - apply check_model_has_invariants in cm as []. - split => //. lsets. - eapply model_of_subset; tea. exact tot. - Qed. - - Lemma model_of_ext {W W' m m'} : - model_of W m -> model_extension W' m m' -> model_of W m'. - Proof. - intros mof [_ dom _]. - intros k hin. apply dom. now apply mof. - Qed. - - Lemma clauses_partition_spec {cls W allW conclW} : - clauses_conclusions cls ⊂_lset W -> - Clauses.partition (premise_restricted_to W) cls = (allW, conclW) -> - (Clauses.Equal allW (cls ⇂ W)) /\ - (Clauses.Equal conclW (Clauses.diff cls (cls ⇂ W))). - Proof. - intros clW. - destruct Clauses.partition eqn:eqp. - intros [= <- <-]. - change t with (t, t0).1. - change t0 with (t, t0).2 at 2. - rewrite -eqp. clear t t0 eqp. - split. - - intros cl. rewrite Clauses.partition_spec1. - rewrite in_restrict_clauses Clauses.filter_spec. - rewrite /premise_restricted_to LevelSet.subset_spec. firstorder eauto. - apply clW, clauses_conclusions_spec. now exists cl. - - intros cl. rewrite Clauses.partition_spec2. - rewrite Clauses.filter_spec Clauses.diff_spec. - rewrite /premise_restricted_to. intuition auto. - move/negbTE: H1. eapply eq_true_false_abs. - eapply LevelSet.subset_spec. - now eapply in_restrict_clauses in H as []. - apply eq_true_not_negb. move/LevelSet.subset_spec => he. - apply H1. apply in_restrict_clauses. split => //. - apply clW, clauses_conclusions_spec. now exists cl. - Qed. - - Lemma clauses_conclusions_eq cls W : - clauses_conclusions cls ⊂_lset W -> - Clauses.Equal cls (cls ↓ W). - Proof. - intros cl x. - rewrite in_clauses_with_concl. intuition auto. - apply cl, clauses_conclusions_spec. now exists x. - Qed. - - (* Inductive inner_result (V U : LevelSet.t) (cls : clauses) (m : model) := - | InLoop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne cls) - | InModel (w : LevelSet.t) (m : valid_model V w m cls). - (* (prf : U ⊂_lset w /\ w ⊂_lset V). *) - Arguments InLoop {V U cls m}. - Arguments InModel {V U cls m}. *) - - Lemma is_update_of_empty cls m : - is_update_of cls LevelSet.empty m m. - Proof. - unfold is_update_of. - rewrite LevelSetFact.is_empty_1 //. lsets. - Qed. - - Lemma strictly_updates_W_eq cls W init m W' : - LevelSet.Equal W W' -> - strictly_updates cls W init m -> - strictly_updates cls W' init m. - Proof. now intros ->. Qed. - - Lemma strictly_updates_clauses_W cls cls' W init m W' : - Clauses.Subset cls cls' -> - LevelSet.Equal W W' -> - strictly_updates cls W init m -> - strictly_updates cls' W' init m. - Proof. intros hsub ->. now apply strictly_updates_weaken. Qed. - - Lemma strictly_updates_is_update_of cls W init m cls' W' m' : - strictly_updates cls W init m -> - is_update_of cls' W' m m' -> - strictly_updates (Clauses.union cls cls') (LevelSet.union W W') init m'. - Proof. - move=> su /is_update_of_case; intros [[empw eq]|su']. - subst m'. eapply (strictly_updates_weaken cls). clsets. - eapply strictly_updates_W_eq; tea. lsets. - eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. - Qed. - - Definition restrict_model W (m : model) := - LevelMapFact.filter (fun l k => LevelSet.mem l W) m. - - Lemma restrict_model_spec W m : - forall l k, LevelMap.MapsTo l k (restrict_model W m) <-> LevelMap.MapsTo l k m /\ LevelSet.In l W. - Proof. - intros l k; rewrite /restrict_model. - now rewrite LevelMapFact.filter_iff LevelSet.mem_spec. - Qed. - - (* Updates the entries in m with the values in m' if any *) - Definition model_update (m m' : model) : model := - LevelMap.mapi (fun l k => - match LevelMap.find l m' with - | Some k' => k' - | None => k - end) m. - - Inductive findSpec l m : option (option Z) -> Prop := - | inm k : LevelMap.MapsTo l k m -> findSpec l m (Some k) - | ninm : ~ LevelMap.In l m -> findSpec l m None. - - Lemma find_spec l m : findSpec l m (LevelMap.find l m). - Proof. - destruct (LevelMap.find l m) eqn:heq; constructor. - now apply LevelMap.find_2. - now apply LevelMapFact.F.not_find_in_iff in heq. - Qed. - - Lemma model_update_spec m m' : - forall l k, LevelMap.MapsTo l k (model_update m m') <-> - (~ LevelMap.In l m' /\ LevelMap.MapsTo l k m) \/ - (LevelMap.MapsTo l k m' /\ LevelMap.In l m). - Proof. - intros l k; split. - - unfold model_update => hl. - eapply LevelMapFact.F.mapi_inv in hl as [a [k' [-> [eqk mt]]]]. - move: eqk; elim: (find_spec l m'). - + intros ? hm <-. right; split => //. now exists a. - + intros nin ->. left. split => //. - - intros [[nin hm]|[inm' inm]]. - * eapply LevelMapFact.F.mapi_mapsto_iff. now intros x y e ->. - elim: (find_spec l m'). - + intros k0 hm'. elim nin. now exists k0. - + intros _. exists k. split => //. - * eapply LevelMapFact.F.mapi_mapsto_iff. now intros x y e ->. - elim: (find_spec l m'). - + intros k0 hm'. destruct inm as [a inm]. exists a. split => //. - now eapply LevelMapFact.F.MapsTo_fun in inm'; tea. - + intros nin; elim nin. now exists k. - Qed. - - Lemma model_update_restrict m W : model_update m (restrict_model W m) =m m. - Proof. - apply LevelMapFact.F.Equal_mapsto_iff. intros l k. - rewrite model_update_spec. - split => //. - - intros [[nin hk]|[hr inm]] => //. - now eapply restrict_model_spec in hr. - - intros hm. - destruct (find_spec l (restrict_model W m)). - + right. apply restrict_model_spec in H as [hm' hw]. - split. eapply LevelMapFact.F.MapsTo_fun in hm; tea. subst. apply restrict_model_spec; split => //. - now exists k. - + left. split => //. - Qed. - - Lemma min_premise_restrict m W prems v : min_premise (restrict_model W m) prems = Some v -> - min_premise m prems = Some v. - Proof. Admitted. - - (* If we can update starting from a restricted model with no values outside [W], - this can be lifted to the unrestricted model, applying the same updates *) - Lemma strictly_updates_restrict_model cls W W' m m' : - strictly_updates cls W' (restrict_model W m) m' -> - strictly_updates cls W' m (model_update m m'). - Proof. - intros H; depind H. - - constructor. auto. - destruct cl as [prems [concl k]]. - destruct H0 as [v [hmin hlt above heq]]. - exists v. split => //. - now eapply min_premise_restrict. - move: above. - rewrite /level_value_above /level_value. - elim: find_spec => //. - + intros kr hkr. destruct kr => //. - apply restrict_model_spec in hkr as [hkr hcl]. - now rewrite (LevelMap.find_1 hkr). - intros _. - elim: find_spec => // km hkm. - destruct km => //. - Admitted. - - Lemma strictly_updates_is_update_of_restrict cls W init m cls' W' m' : - strictly_updates cls W init m -> - is_update_of cls' W' (restrict_model W m) m' -> - strictly_updates (Clauses.union cls cls') (LevelSet.union W W') init (model_update m m'). - Proof. - move=> su /is_update_of_case; intros [[empw eq]|su']. - - subst m'. eapply (strictly_updates_weaken cls). clsets. - rewrite model_update_restrict. - eapply strictly_updates_W_eq; tea. lsets. - - eapply strictly_updates_restrict_model in su'. - eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. - Qed. + (Z.to_nat x < Z.to_nat y)%nat. + Proof. intros. lia. Qed. - Lemma union_with_concl cls W : Clauses.Equal (Clauses.union cls (cls ↓ W)) cls. + Lemma sum_pos W f : + (0 < sum_W W f)%nat -> + exists w, LevelSet.In w W /\ (0 < f w)%nat. Proof. - intros x. rewrite Clauses.union_spec in_clauses_with_concl. firstorder. + unfold sum_W. + eapply LevelSetProp.fold_rec => //. + intros. lia. + intros. + destruct (Nat.ltb_spec 0 a). + - destruct (H2 H4) as [w [hin hlt]]. exists w. split => //. apply H1. now right. + - exists x. split => //. apply H1. now left. lia. Qed. - Instance is_update_of_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> eq ==> eq ==> iff) is_update_of. + Lemma measure_pos {W cls m} : + (0 < measure W cls m)%nat -> + exists l, LevelSet.In l W /\ (0 < measure_w W cls m l)%Z. Proof. - intros ?? H ?? H' ?? H'' ?? H'''. - unfold is_update_of. setoid_rewrite H'. destruct LevelSet.is_empty. firstorder. subst. reflexivity. subst. reflexivity. - subst. now rewrite H H'. + unfold measure. + move/sum_pos => [w [hin hlt]]. + exists w. split => //. lia. Qed. - Lemma empty_union l : LevelSet.Equal (LevelSet.union LevelSet.empty l) l. - Proof. intros ?. lsets. Qed. - - Lemma is_update_of_strictly_updates cls W m m' : - strictly_updates cls W m m' -> - is_update_of cls W m m'. + Lemma model_of_diff cls W m : + model_of W m -> model_of (clauses_conclusions (cls_diff cls W)) m. Proof. - intros su. have ne := strictly_updates_non_empty su. - rewrite /is_update_of. now rewrite (proj2 (levelset_not_Empty_is_empty _) ne). + intros; eapply model_of_subset; tea. + eapply clauses_conclusions_diff_left. Qed. + Hint Resolve model_of_diff : core. - Lemma is_update_of_weaken {cls cls' W m m'} : - Clauses.Subset cls cls' -> - is_update_of cls W m m' -> is_update_of cls' W m m'. + Lemma check_model_spec_diff {cls w m w' m' w''} : + model_of w m -> + model_of w'' m -> + let cls := (cls_diff cls w) in + check_model cls (w'', m) = Some (w', m') -> + [/\ w'' ⊂_lset w', w' ⊂_lset (w'' ∪ w), + exists cl : clause, + let cll := levelexpr_level (concl cl) in + [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' + & (opt_le Nat.lt (level_value m cll) (level_value m' cll))%Z] + & model_extension w' m m']. Proof. - intros hsub. - move/is_update_of_case => []. - - intros []. subst. rewrite /is_update_of. - now rewrite (LevelSetFact.is_empty_1 H). - - intros su. have ne := strictly_updates_non_empty su. - unfold is_update_of. rewrite (proj2 (levelset_not_Empty_is_empty _) ne). - eapply strictly_updates_weaken; tea. + cbn; intros mof tot cm. + pose proof (clauses_conclusions_diff_left cls w (cls ⇂ w)). + apply check_model_has_invariants in cm as []. + split => //. lsets. + eapply model_of_subset. exact mof. tea. exact tot. Qed. - Lemma is_update_of_trans {cls cls' W W' m m' m''} : - is_update_of cls W m m' -> is_update_of cls' W' m' m'' -> - is_update_of (Clauses.union cls cls') (LevelSet.union W W') m m''. + Lemma model_of_extension {W W' m m'} : + model_of W m -> model_extension W' m m' -> model_of W m'. Proof. - move/is_update_of_case => []. - - move=> [he <-]. intro. rewrite (LevelSetProp.empty_is_empty_1 he) empty_union. - move: H. eapply is_update_of_weaken. clsets. - - intros su isu. - eapply strictly_updates_is_update_of in isu; tea. - have ne := strictly_updates_non_empty isu. - rewrite /is_update_of. now rewrite (proj2 (levelset_not_Empty_is_empty _) ne). + intros mof [_ dom _]. + intros k hin. apply dom. now apply mof. Qed. - Lemma is_update_of_trans_eq {cls cls' W W' cltr Wtr m m' m''} : - is_update_of cls W m m' -> is_update_of cls' W' m' m'' -> - Clauses.Subset (Clauses.union cls cls') cltr -> - LevelSet.Equal Wtr (LevelSet.union W W') -> - is_update_of cltr Wtr m m''. + Lemma clauses_partition_spec {cls W allW conclW} : + clauses_conclusions cls ⊂_lset W -> + Clauses.partition (premise_restricted_to W) cls = (allW, conclW) -> + (Clauses.Equal allW (cls ⇂ W)) /\ + (Clauses.Equal conclW (Clauses.diff cls (cls ⇂ W))). Proof. - intros hi hi' hcl hw. rewrite hw. - eapply is_update_of_weaken; tea. - eapply is_update_of_trans; tea. + intros clW. + destruct Clauses.partition eqn:eqp. + intros [= <- <-]. + change t with (t, t0).1. + change t0 with (t, t0).2 at 2. + rewrite -eqp. clear t t0 eqp. + split. + - intros cl. rewrite Clauses.partition_spec1. + rewrite in_restrict_clauses Clauses.filter_spec. + rewrite /premise_restricted_to LevelSet.subset_spec. firstorder eauto. + apply clW, clauses_conclusions_spec. now exists cl. + - intros cl. rewrite Clauses.partition_spec2. + rewrite Clauses.filter_spec Clauses.diff_spec. + rewrite /premise_restricted_to. intuition auto. + move/negbTE: H1. eapply eq_true_false_abs. + eapply LevelSet.subset_spec. + now eapply in_restrict_clauses in H as []. + apply eq_true_not_negb. move/LevelSet.subset_spec => he. + apply H1. apply in_restrict_clauses. split => //. + apply clW, clauses_conclusions_spec. now exists cl. Qed. - Lemma union_idem cls : Clauses.Equal (Clauses.union cls cls) cls. - Proof. intros ?; rewrite Clauses.union_spec. firstorder. Qed. - - Lemma above_max_premise_model_trans {cls V' m m'} : - above_max_premise_model cls m -> - strictly_updates cls V' m m' -> - above_max_premise_model cls m'. + Lemma clauses_conclusions_eq cls W : + clauses_conclusions cls ⊂_lset W -> + Clauses.Equal cls (cls ↓ W). Proof. - move=> [[V'' ab]|eq] su. - * have tr := strictly_updates_trans ab su. - rewrite union_idem in tr. - now left; eexists. - * left; exists V'. now subst. + intros cl x. + rewrite in_clauses_with_concl. intuition auto. + apply cl, clauses_conclusions_spec. now exists x. Qed. - Lemma max_clause_premise_spec2 cls : - (exists cl, Clauses.In cl cls /\ max_clause_premise cls = premise_max (premise cl)) \/ - (Clauses.Empty cls /\ max_clause_premise cls = 0%nat). - Proof. - unfold max_clause_premise. - eapply ClausesProp.fold_rec. - - firstorder. - - intros x a s' s'' incls ins' hadd [ih|ih]. - left. - * destruct ih as [cl [incl ->]]. - destruct (Nat.max_spec (premise_max (premise x)) (premise_max (premise cl))) as [[hlt ->]|[hge ->]]. - { exists cl. split => //. apply hadd. now right. } - { exists x. firstorder. } - * left. exists x. split; firstorder. subst. - lia. - Qed. + (* Inductive inner_result (V U : LevelSet.t) (cls : clauses) (m : model) := + | InLoop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne cls) + | InModel (w : LevelSet.t) (m : valid_model V w m cls). + (* (prf : U ⊂_lset w /\ w ⊂_lset V). *) + Arguments InLoop {V U cls m}. + Arguments InModel {V U cls m}. *) - Lemma max_clause_premise_mon {cls cls'} : - cls ⊂_clset cls' -> - (max_clause_premise cls <= max_clause_premise cls')%nat. - Proof using Type. - intros hincl. - have [[cl [hin hs]]|[he hs]] := max_clause_premise_spec2 cls; - have [[cl' [hin' hs']]|[he' hs']] := max_clause_premise_spec2 cls'. - - apply hincl in hin. - have hm := max_clause_premise_spec _ _ hin. - have hm' := max_clause_premise_spec _ _ hin'. lia. - - rewrite hs'. apply hincl in hin. now eapply he' in hin. - - rewrite hs. lia. - - lia. + Lemma is_update_of_empty cls m : + is_update_of cls LevelSet.empty m m. + Proof. + unfold is_update_of. + rewrite LevelSetFact.is_empty_1 //. lsets. Qed. + Lemma strictly_updates_W_eq cls W init m W' : + LevelSet.Equal W W' -> + strictly_updates cls W init m -> + strictly_updates cls W' init m. + Proof. now intros ->. Qed. - Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) - (loop : forall (V' U' : LevelSet.t) (cls' : clauses) (minit m : model) - (prf : [/\ clauses_levels cls' ⊂_lset V', only_model_of V' minit & - is_update_of cls' U' minit m]), - lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls' minit). - - Section innerloop_partition. - Context (W : LevelSet.t) (cls : clauses). - Context (premconclW conclW : clauses). - Context (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W, - Clauses.Equal premconclW (cls ⇂ W) & Clauses.Equal conclW (Clauses.diff (cls ↓ W) (cls ⇂ W))]). + Lemma strictly_updates_clauses_W cls cls' W init m W' : + Clauses.Subset cls cls' -> + LevelSet.Equal W W' -> + strictly_updates cls W init m -> + strictly_updates cls' W' init m. + Proof. intros hsub ->. now apply strictly_updates_weaken. Qed. - #[tactic="idtac"] - Equations? inner_loop_partition (m : model) (upd : strictly_updates cls W init_model m) : - result W LevelSet.empty cls m - by wf (measure W cls m) lt := - inner_loop_partition m upd with loop W LevelSet.empty premconclW (restrict_model W m) (restrict_model W m) _ _ := { - (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) - | Loop W ne n isl => Loop W ne n (loop_on_subset _ isl) - (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). - By invariant Wr ⊂ W *) - | Model Wr mr empWr with inspect (check_model conclW (Wr, model_update m (model_model mr))) := { - | exist None eqm => Model Wr {| model_model := model_model mr |} _ - | exist (Some (Wconcl, mconcl)) eqm with inner_loop_partition mconcl _ := { - (* Here Wr ⊂ Wconcl by invariant *) - | Loop W ne n isl => Loop W ne n isl - | Model Wr' mr' UWconcl => Model (LevelSet.union Wconcl Wr') {| model_model := model_model mr' |} _ } - (* Here Wr' ⊂ W by invariant *) - (* We check if the new model [mr] for (cls ⇂ W) extends to a model of (cls ↓ W). *) - (* We're entitled to recursively compute a better model starting with mconcl, - as we have made the measure decrease: - some atom in W has been strictly updated in Wconcl. *) - } }. - Proof. - all:try solve [try apply LevelSet.subset_spec; try reflexivity]. - all:cbn [model_model]; clear loop inner_loop_partition. - all:try apply LevelSet.subset_spec in hsub. - all:auto. - all:try destruct prf as [WV neW UW clsW eqprem eqconcl]. - all:try solve [intuition auto]. - all:try rewrite eqconcl in eqm. - - split => //. - * rewrite eqprem. apply clauses_levels_restrict_clauses. - * red. intros. rw restrict_model_spec. split => //. 2:clear; firstorder. - eapply strictly_updates_total_model in upd. move/[dup]/upd. clear; firstorder. - (* * eapply (strictly_updates_total_model upd). *) - (* * rewrite eqprem. transitivity cls => //. apply restrict_clauses_subset. *) - (* * eapply strictly_updates_weaken in upd; tea. eapply above_max_premise_model_trans in maxp; tea. *) - * eapply is_update_of_empty. - - left. now eapply strict_subset_cardinal. - - rewrite eqprem. eapply restrict_clauses_subset. - (* - destruct prf. transitivity (cls ⇂ W) => //. now rewrite H3. eapply restrict_clauses_subset. *) - - have mu := model_updates mr. - eapply strictly_updates_is_update_of in upd; tea. - apply check_model_spec in eqm as [Wconcl' [sumr ->]]. - have tr := strictly_updates_trans upd sumr. - eapply strictly_updates_clauses_W; tea. - { intros ?. rewrite eqprem. rewrite ClausesProp.union_assoc (ClausesProp.union_sym (restrict_clauses _ _)). - now rewrite union_diff union_with_concl. } - { have incl := model_incl mr. apply strictly_updates_incl in sumr. - have hdiff := clauses_conclusions_diff_left cls W (cls ⇂ W). lsets. } - - have tmr : total_model_of W (model_model mr). - { eapply valid_model_total. now eapply strictly_updates_total_model in upd. } - eapply (check_model_spec_diff mr) in eqm as [subwwconcl subwconcl hm hext] => //. - pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). - destruct hm as [cll [hind nvalid inwconcl hl]]. - eapply Nat.lt_le_trans with (measure W cls (model_model mr)). - 2:{ eapply measure_le; eauto; try eapply mr; tea. - - now eapply strictly_updates_total_model in upd. - - eapply valid_model_model_map_outside. - - eapply is_update_of_ext. eapply mr. } - eapply measure_lt; tea. - { eapply model_map_outside_weaken. eapply hext. have incl := model_incl mr. lsets. } - { apply hext. } - eapply invalid_clause_measure in nvalid; tea. - exists (levelexpr_level (concl cll)). - split => //. - eapply clauses_conclusions_diff_left; tea. - eapply clauses_conclusions_spec. exists cll; split => //. exact hind. - have incl := model_incl mr. eapply total_model_of_subset; tea. - - apply mr'. - - eapply check_model_is_update_of in eqm as [eqm incl]. 2:eapply mr. - eapply strictly_updates_is_update_of in eqm. 2:eapply mr'. - eapply is_update_of_strictly_updates in eqm. - eapply is_update_of_weaken; tea. - rewrite (ClausesProp.union_sym premconclW) eqprem union_diff. - intros ?. rewrite Clauses.union_spec in_clauses_with_concl; cbn. clear; firstorder. - - apply mr'. - - lsets. - - apply mr. - - eapply is_update_of_weaken. 2:apply mr. rewrite eqprem. apply restrict_clauses_subset. - - rewrite check_model_is_model in eqm. - have okm := (model_ok mr). - have mu := is_model_union okm eqm. - rewrite {1}eqprem in mu. - rewrite union_diff_eq in mu. - rewrite union_restrict_with_concl in mu. - now rewrite (clauses_conclusions_eq _ _ clsW). - Qed. - End innerloop_partition. + Lemma strictly_updates_is_update_of cls W init m cls' W' m' : + strictly_updates cls W init m -> + is_update_of cls' W' m m' -> + strictly_updates (Clauses.union cls cls') (LevelSet.union W W') init m'. + Proof. + move=> su /is_update_of_case; intros [[empw eq]|su']. + rewrite <- eq. eapply (strictly_updates_weaken cls). clsets. + eapply strictly_updates_W_eq; tea. lsets. + eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. + Qed. - (* We first partition the clauses among those that mention only W and the ones that can mention other atoms. - We then call the loop on these two sets of clauses, which not need to change during the recursive calls. - *) - #[tactic="idtac"] - Equations? inner_loop (W : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & - strictly_updates cls W init_model m]) : result W LevelSet.empty cls m := - inner_loop W cls m prf with inspect (Clauses.partition (premise_restricted_to W) cls) := - | exist (premconclW, conclW) eqp => inner_loop_partition W cls premconclW conclW _ m _. + Definition restrict_model W (m : model) := + LevelMapFact.filter (fun l k => LevelSet.mem l W) m. + + Lemma restrict_model_spec W m : + forall l k, LevelMap.MapsTo l k (restrict_model W m) <-> LevelMap.MapsTo l k m /\ LevelSet.In l W. Proof. - - destruct prf as [subWV neW UW clsW mW]. - eapply (clauses_partition_spec clsW) in eqp as [eqprem eqconcl]. - split => //. now rewrite -(clauses_conclusions_eq _ _ clsW). - - apply prf. + intros l k; rewrite /restrict_model. + now rewrite LevelMapFact.filter_iff LevelSet.mem_spec. Qed. -End InnerLoop. + (* Updates the entries in m with the values in m' if any *) + Definition model_update (m m' : model) : model := + LevelMap.mapi (fun l k => + match LevelMap.find l m' with + | Some k' => k' + | None => k + end) m. -Local Open Scope nat_scope. -Lemma diff_cardinal_inter V W : #|LevelSet.diff V W| = #|V| - #|LevelSet.inter V W|. -Proof. - pose proof (LevelSetProp.diff_inter_cardinal V W). lia. -Qed. + Instance model_update_proper : Proper (LevelMap.Equal ==> LevelMap.Equal ==> LevelMap.Equal) model_update. + Proof. + intros ? ? eq ? ? eq'. + rewrite /model_update. + apply LevelMapFact.F.Equal_mapsto_iff. + intros k e. + rewrite LevelMapFact.F.mapi_mapsto_iff. now intros ? ? ? ->. + rewrite LevelMapFact.F.mapi_mapsto_iff. now intros ? ? ? ->. + firstorder. exists x1. rewrite H. now rewrite -eq eq'. + rewrite H. exists x1. now rewrite eq -eq'. + Qed. -Lemma diff_cardinal V W : W ⊂_lset V -> #|LevelSet.diff V W| = #|V| - #|W|. -Proof. - intros hsub. - rewrite diff_cardinal_inter LevelSetProp.inter_sym LevelSetProp.inter_subset_equal //. -Qed. + Inductive findSpec l m : option nat -> Prop := + | inm k : LevelMap.MapsTo l k m -> findSpec l m (Some k) + | ninm : ~ LevelMap.In l m -> findSpec l m None. -Lemma is_modelP m cls : reflect (Clauses.For_all (valid_clause m) cls) (is_model cls m). -Proof. - case E: is_model; constructor. - - now move: E; rewrite /is_model -ClausesFact.for_all_iff. - - intros hf. apply ClausesFact.for_all_iff in hf; tc. unfold is_model in E; congruence. -Qed. + Lemma find_spec l m : findSpec l m (LevelMap.find l m). + Proof. + destruct (LevelMap.find l m) eqn:heq; constructor. + now apply LevelMap.find_2. + now apply LevelMapFact.F.not_find_in_iff in heq. + Qed. -Lemma is_model_invalid_clause cl cls m : is_model cls m -> ~~ valid_clause m cl -> ~ Clauses.In cl cls. -Proof. - move/is_modelP => ism /negP valid hin. - now specialize (ism _ hin). -Qed. + Lemma model_update_spec m m' : + forall l k, LevelMap.MapsTo l k (model_update m m') <-> + (~ LevelMap.In l m' /\ LevelMap.MapsTo l k m) \/ + (LevelMap.MapsTo l k m' /\ LevelMap.In l m). + Proof. + intros l k; split. + - unfold model_update => hl. + eapply LevelMapFact.F.mapi_inv in hl as [a [k' [-> [eqk mt]]]]. + move: eqk; elim: (find_spec l m'). + + intros ? hm <-. right; split => //. now exists a. + + intros nin ->. left. split => //. + - intros [[nin hm]|[inm' inm]]. + * eapply LevelMapFact.F.mapi_mapsto_iff. now intros x y e ->. + elim: (find_spec l m'). + + intros k0 hm'. elim nin. now exists k0. + + intros _. exists k. split => //. + * eapply LevelMapFact.F.mapi_mapsto_iff. now intros x y e ->. + elim: (find_spec l m'). + + intros k0 hm'. destruct inm as [a inm]. exists a. split => //. + now eapply LevelMapFact.F.MapsTo_fun in inm'; tea. + + intros nin; elim nin. now exists k. + Qed. -Lemma strict_subset_leq_right U V W : - strict_subset U V -> V ⊂_lset W -> strict_subset U W. -Proof. - intros [] le. split. lsets. intros eq. rewrite -eq in le. - apply H0. lsets. -Qed. + Lemma model_update_restrict m W : model_update m (restrict_model W m) =m m. + Proof. + apply LevelMapFact.F.Equal_mapsto_iff. intros l k. + rewrite model_update_spec. + split => //. + - intros [[nin hk]|[hr inm]] => //. + now eapply restrict_model_spec in hr. + - intros hm. + destruct (find_spec l (restrict_model W m)). + + right. apply restrict_model_spec in H as [hm' hw]. + split. eapply LevelMapFact.F.MapsTo_fun in hm; tea. subst. apply restrict_model_spec; split => //. + now exists k. + + left. split => //. + Qed. -Lemma strict_subset_leq_left U V W : - U ⊂_lset V -> strict_subset V W -> strict_subset U W. -Proof. - intros le []. split. lsets. intros eq. rewrite eq in le. - apply H0. lsets. -Qed. -(* Lemma strict_subset_union_right U U' V W : - strict_subset V W -> U ⊂_lset U' -> - strict_subset (LevelSet.union U V) (LevelSet.union U' W). -Proof. - rewrite /strict_subset. - intros [] hu. split. lsets. intros he. - apply H0. - intros x. split. apply H. - specialize (he x). intros inW. - rewrite !LevelSet.union_spec in he. - destruct he as [he he']. - forward he'. now right. destruct he' => //. - forward he. apply he in - red in he. *) + Lemma min_premise_preserved {m m'} {prems : univ} : + (forall x, LevelSet.In x (levels prems) -> level_value m x = level_value m' x) -> + min_premise m prems = min_premise m' prems. + Proof. + intros hcl. + unfold min_premise. + funelim (to_nonempty_list prems). bang. clear H. + rw_in levelexprset_levels_spec hcl. + have -> : min_atom_value m e = min_atom_value m' e. + { destruct e as [k l']. + rewrite /min_atom_value. rewrite -hcl //. + exists l'. + apply LevelExprSet.elements_spec1. rewrite e0. now left. } + have cl' : forall x, (exists k, InA eq (x, k) l) -> level_value m x = level_value m' x. + { intros x [k ina]. apply hcl. exists k. apply LevelExprSet.elements_spec1. rewrite e0. now right. } + clear hcl Heqcall e0. + generalize (min_atom_value m' e). + induction l; cbn; auto. + have -> : min_atom_value m a = min_atom_value m' a. + { destruct a as [k l']. + rewrite /min_atom_value. rewrite cl' //. + exists l'. now left. } + intros o. + apply IHl. + intros x [k l']. apply cl'. exists k. now right. + Qed. -Lemma strict_subset_diff_incl V W W' : - strict_subset W' W -> - W ⊂_lset V -> - W' ⊂_lset V -> - strict_subset (LevelSet.diff V W) (LevelSet.diff V W'). -Proof. - intros [] lew lew'. - split. lsets. - intros eq. - apply H0. lsets. -Qed. -(* To help equations *) -Opaque lexprod_rel_wf. + Lemma levelmap_find_eq x (m m' : model) : + (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> + LevelMap.find x m = LevelMap.find x m'. + Proof. + intros hm. + destruct (LevelMap.find x m) eqn:he; + destruct (LevelMap.find x m') eqn:he'. + all:try apply LevelMap.find_2 in he. all:try apply LevelMap.find_2 in he'. + apply hm in he. eapply LevelMapFact.F.MapsTo_fun in he; tea. congruence. + apply hm in he. apply LevelMapFact.F.not_find_in_iff in he'. firstorder. + apply LevelMapFact.F.not_find_in_iff in he. firstorder. congruence. + Qed. -Lemma check_model_spec_V {V cls w m w' m'} : - model_of V m -> clauses_conclusions cls ⊂_lset V -> - total_model_of w m -> - check_model cls (w, m) = Some (w', m') -> - check_model_invariants cls w m w' m' true. -Proof. - cbn; intros mof incl tot cm. - apply check_model_has_invariants in cm => //. - eapply model_of_subset; tea. -Qed. + Lemma levelmap_find_eq_inv x (m m' : model) : + LevelMap.find x m = LevelMap.find x m' -> + (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m'). + Proof. + intros hfind. + destruct (LevelMap.find x m) eqn:he; + destruct (LevelMap.find x m') eqn:he'. + all:try apply LevelMap.find_2 in he. all:try apply LevelMap.find_2 in he'. all:try congruence. + noconf hfind. intros k; split; intros. + eapply LevelMapFact.F.MapsTo_fun in he; tea. now subst. + eapply LevelMapFact.F.MapsTo_fun in he'; tea. now subst. + intros k; split; intros. + apply LevelMapFact.F.not_find_in_iff in he. firstorder. + apply LevelMapFact.F.not_find_in_iff in he'. firstorder. + Qed. -Section Semantics. + Lemma min_premise_restrict m W (prems : univ) v : + (forall l k, LevelExprSet.In (l, k) prems -> LevelSet.In l W) -> + min_premise (restrict_model W m) prems = Some v -> + min_premise m prems = Some v. + Proof. + intros hin. + rewrite (@min_premise_preserved _ m) //. + move=> x. rewrite levelexprset_levels_spec => [] [k] /hin inW. + apply levelmap_find_eq => k'. + rewrite restrict_model_spec. firstorder. + Qed. - Section Interpretation. - Context (V : LevelMap.t nat). + Lemma model_of_model_update W m m' : + model_of W m -> + model_of W (model_update m m'). + Proof. + intros hm l hin. + move/hm: hin => [k hin]. + red. rw model_update_spec. + destruct (LevelMapFact.F.In_dec m' l). + - destruct i as [k' hin']. exists k'. right; split => //. now exists k. + - exists k; left; split => //. + Qed. - Definition interp_level l := - match LevelMap.find l V with - | Some x => x - | None => 0%nat - end. + Lemma strictly_updates_restrict_only_model {cls W m m'} : strictly_updates cls W m m' -> + only_model_of W (restrict_model W m'). + Proof. + intros su. red. rw restrict_model_spec. + split => //. 2:clear; firstorder. + eapply strictly_updates_total_model in su. move/[dup]/su. clear; firstorder. + Qed. - Definition interp_expr '(l, k) := (interp_level l + k)%nat. - Definition interp_prems prems := - let '(hd, tl) := to_nonempty_list prems in - fold_right (fun lk acc => Nat.max (interp_expr lk) acc) (interp_expr hd) tl. + Lemma only_model_of_restrict W m : + model_of W m -> only_model_of W (restrict_model W m). + Proof. + intros mof x. rw restrict_model_spec. firstorder. + Qed. - Definition clause_sem (cl : clause) : Prop := - let '(prems, concl) := cl in - interp_prems prems >= interp_expr concl. + Lemma strictly_updates_from_restrict {cls W W' m m'} : + clauses_conclusions cls ⊂_lset W -> + model_of W m -> + strictly_updates cls W' (restrict_model W m) m' -> + only_model_of W m'. + Proof. + intros hcls mof su. + have om := strictly_updates_only_model_gen _ _ _ _ su W. + apply strictly_updates_incl in su. + have hu : ((W ∪ W') =_lset W). intros x; lsets. + rewrite hu in om. apply om. + now apply only_model_of_restrict. + Qed. - Definition clauses_sem (cls : clauses) : Prop := - Clauses.For_all clause_sem cls. - End Interpretation. + Lemma restrict_model_update W m m' : + model_of W m' -> + only_model_of W m -> + restrict_model W (model_update m' m) =m m. + Proof. + intros mof om. + intro l. apply levelmap_find_eq => k. + rewrite restrict_model_spec model_update_spec. split. + - move=> [] [[hnin hm] hin|hm hin]. + specialize (proj1 (om l) hin) as [x hm']. elim hnin. now exists x. + apply hm. + - move=> hm. split => //. 2:now apply om; exists k. + right; firstorder. + Qed. - (* There exists a valuation making all clauses true in the natural numbers *) - Definition satisfiable (cls : clauses) := - exists V, clauses_sem V cls. + Lemma model_update_trans m upd upd' : + (forall l, LevelMap.In l upd -> LevelMap.In l upd') -> + model_update (model_update m upd) upd' =m model_update m upd'. + Proof. + intros hl l. apply levelmap_find_eq => k. + rewrite !model_update_spec /LevelMap.In. + rw model_update_spec. firstorder. + right. split => //. + destruct (LevelMapFact.F.In_dec upd l). + - destruct i as [updv hk]. + exists updv. firstorder. + - exists x; left; firstorder. + Qed. - (* Any valuation making all clauses valid in the natural numbers also satisfies the clause cl *) - Definition entails_sem (cls : clauses) (cl : clause) := - forall V, clauses_sem V cls -> clause_sem V cl. -End Semantics. + (* If we can update starting from a restricted model with no values outside [W], + this can be lifted to the unrestricted model, applying the same updates *) + Lemma strictly_updates_restrict_model_gen cls W W' m' : + forall cls' mr, + strictly_updates cls' W' mr m' -> + forall m, model_of W m -> + cls' = (cls ⇂ W) -> + mr =m (restrict_model W m) -> + strictly_updates (cls ⇂ W) W' m (model_update m m'). + Proof. + intros cls' mr. induction 1. + - intros mi mofW -> hm. + constructor. auto. + destruct cl as [prems [concl k]]. + destruct H0 as [v [hmin hlt above heq]]. + rewrite hm in hmin, above. + exists v. split => //. + eapply min_premise_restrict with W => //. + { intros l k' hp. move/in_restrict_clauses: H => [] //= _ hsub _. apply hsub. + rewrite levelexprset_levels_spec. now exists k'. } + move: above. + rewrite /level_value_above /level_value. + elim: find_spec => //. + + intros kr hkr. + apply restrict_model_spec in hkr as [hkr hcl]. + now rewrite (LevelMap.find_1 hkr). + + move=> ncl _. + elim: find_spec => // => k' inm. + apply in_restrict_clauses in H as [inconcl inprems incls]. cbn in *. + elim ncl. exists k'. eapply restrict_model_spec. split => //. + + apply in_restrict_clauses in H as [inconcl inprems incls]. cbn in *. + rewrite heq. intro. apply levelmap_find_eq => k'. + rewrite hm. + rewrite model_update_spec !LevelMapFact.F.add_mapsto_iff restrict_model_spec. + rewrite LevelMapFact.F.add_in_iff /Level.eq. firstorder; subst. + right. split => //. left => //. now apply mofW. + destruct (inLevelSet W y). + * right. split. right => //. now exists k'. + * left. split => //. intros []. congruence. + destruct H2 as [yrest hin]. eapply restrict_model_spec in hin as []. contradiction. + - intros mtot mof -> hm. specialize (IHstrictly_updates1 mtot mof eq_refl hm). + specialize (IHstrictly_updates2 (model_update mtot m')). + have model_of : model_of W (model_update mtot m'). + by apply model_of_model_update. + specialize (IHstrictly_updates2 model_of eq_refl). + forward IHstrictly_updates2. + { rewrite hm in H. eapply strictly_updates_from_restrict in H; tea. + 2:eapply clauses_conclusions_restrict_clauses. + now rewrite restrict_model_update. } + eapply update_trans; tea. + have eqm : (model_update (model_update mtot m') m'') =m model_update mtot m''. + { eapply model_update_trans. eapply strictly_updates_ext in H0. + intros l [k hin]. apply H0 in hin as [k' []]. now exists k'. } + now rewrite eqm in IHstrictly_updates2. + Qed. + Lemma strictly_updates_restrict_model cls W W' m' : + forall m, model_of W m -> + strictly_updates (cls ⇂ W) W' (restrict_model W m) m' -> + strictly_updates (cls ⇂ W) W' m (model_update m m'). + Proof. + intros m mof su. + eapply strictly_updates_restrict_model_gen; tea; reflexivity. + Qed. -Local Open Scope Z_scope. -Lemma max_min max min k : min <= 0 -> max >= 0 -> k <= max -> k >= min -> (max - k - min) >= 0. -Proof. lia. Qed. + Lemma strictly_updates_is_update_of_restrict cls W init m W' m' : + strictly_updates cls W init m -> + is_update_of (cls ⇂ W) W' (restrict_model W m) m' -> + strictly_updates cls (LevelSet.union W W') init (model_update m m'). + Proof. + move=> su /is_update_of_case; intros [[empw eq]|su']. + - rewrite <- eq. eapply (strictly_updates_weaken cls). clsets. + rewrite model_update_restrict. + eapply strictly_updates_W_eq; tea. lsets. + - eapply strictly_updates_restrict_model in su'. + eapply strictly_updates_weaken in su'. 2:eapply restrict_clauses_subset. + eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. + now apply strictly_updates_total_model in su. + Qed. -Definition model_min m := - LevelMap.fold (fun l k acc => - match k with - | Some k => Z.min acc k - | None => acc - end) m 0%Z. + Lemma union_with_concl cls W : Clauses.Equal (Clauses.union cls (cls ↓ W)) cls. + Proof. + intros x. rewrite Clauses.union_spec in_clauses_with_concl. firstorder. + Qed. -Lemma model_min_spec m : forall l k, LevelMap.MapsTo l k m -> (Some (model_min m) ≤ k). -Proof. Admitted. + Instance is_update_of_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) is_update_of. + Proof. + intros ?? H ?? H' ?? H'' ?? H'''. + unfold is_update_of. setoid_rewrite H'. destruct LevelSet.is_empty. + rewrite H'' H'''. reflexivity. + firstorder. now rewrite -H -H' -H'' -H'''. + subst. now rewrite H H' H'' H'''. + Qed. -Definition model_max m := - LevelMap.fold (fun l k acc => - match k with - | Some k => Z.max acc k - | None => acc - end) m 0%Z. + Lemma empty_union l : LevelSet.Equal (LevelSet.union LevelSet.empty l) l. + Proof. intros ?. lsets. Qed. -Lemma model_max_spec m : forall l k, LevelMap.MapsTo l k m -> (k ≤ Some (model_max m))%Z. -Proof. Admitted. + Lemma is_update_of_strictly_updates cls W m m' : + strictly_updates cls W m m' -> + is_update_of cls W m m'. + Proof. + intros su. have ne := strictly_updates_non_empty su. + rewrite /is_update_of. now rewrite (proj2 (levelset_not_Empty_is_empty _) ne). + Qed. + + Lemma is_update_of_weaken {cls cls' W m m'} : + Clauses.Subset cls cls' -> + is_update_of cls W m m' -> is_update_of cls' W m m'. + Proof. + intros hsub. + move/is_update_of_case => []. + - intros []. subst. rewrite /is_update_of. + now rewrite (LevelSetFact.is_empty_1 H). + - intros su. have ne := strictly_updates_non_empty su. + unfold is_update_of. rewrite (proj2 (levelset_not_Empty_is_empty _) ne). + eapply strictly_updates_weaken; tea. + Qed. -Definition valuation_of_model (m : model) : LevelMap.t nat := - let min := model_min m in - let max := model_max m in - LevelMap.fold (fun l k acc => LevelMap.add l (Z.to_nat (max - option_get 0%Z k - min)) acc) m (LevelMap.empty _). -Close Scope Z_scope. + Lemma is_update_of_trans {cls cls' W W' m m' m''} : + is_update_of cls W m m' -> is_update_of cls' W' m' m'' -> + is_update_of (Clauses.union cls cls') (LevelSet.union W W') m m''. + Proof. + move/is_update_of_case => []. + - move=> [he eq]. intro. rewrite eq. rewrite (LevelSetProp.empty_is_empty_1 he) empty_union. + move: H. eapply is_update_of_weaken. clsets. + - intros su isu. + eapply strictly_updates_is_update_of in isu; tea. + have ne := strictly_updates_non_empty isu. + rewrite /is_update_of. now rewrite (proj2 (levelset_not_Empty_is_empty _) ne). + Qed. -Lemma valuation_of_model_spec m : - forall l k, LevelMap.MapsTo l (Some k) m -> - let v := (model_max m - k - model_min m)%Z in - (v >= 0)%Z /\ LevelMap.MapsTo l (Z.to_nat v) (valuation_of_model m). -Proof. Admitted. + Lemma is_update_of_trans_eq {cls cls' W W' cltr Wtr m m' m''} : + is_update_of cls W m m' -> is_update_of cls' W' m' m'' -> + Clauses.Subset (Clauses.union cls cls') cltr -> + LevelSet.Equal Wtr (LevelSet.union W W') -> + is_update_of cltr Wtr m m''. + Proof. + intros hi hi' hcl hw. rewrite hw. + eapply is_update_of_weaken; tea. + eapply is_update_of_trans; tea. + Qed. + Lemma union_idem cls : Clauses.Equal (Clauses.union cls cls) cls. + Proof. intros ?; rewrite Clauses.union_spec. firstorder. Qed. -Definition correct_model (cls : clauses) (m : model) := - enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. + Lemma above_max_premise_model_trans {cls V' m m'} : + above_max_premise_model cls m -> + strictly_updates cls V' m m' -> + above_max_premise_model cls m'. + Proof. + move=> [[V'' ab]|eq] su. + * have tr := strictly_updates_trans ab su. + rewrite union_idem in tr. + now left; eexists. + * left; exists V'. now subst. + Qed. -Lemma strictly_updates_valid_model {W W' m m' cls} : - is_model (cls ↓ W) m -> - strictly_updates cls W' m m' -> - exists l, LevelSet.In l W' /\ ~ LevelSet.In l W. -Proof. - intros vm. induction 1. - - exists (clause_conclusion cl). split => //. lsets. intros hin. - eapply strict_update_invalid in H0. - eapply is_model_invalid_clause in vm; tea. apply vm. - eapply in_clauses_with_concl. split => //. - - destruct (IHstrictly_updates1 vm). exists x. - rewrite LevelSet.union_spec. firstorder. -Qed. + Lemma max_clause_premise_spec2 cls : + (exists cl, Clauses.In cl cls /\ max_clause_premise cls = premise_max (premise cl)) \/ + (Clauses.Empty cls /\ max_clause_premise cls = 0%nat). + Proof. + unfold max_clause_premise. + eapply ClausesProp.fold_rec. + - firstorder. + - intros x a s' s'' incls ins' hadd [ih|ih]. + left. + * destruct ih as [cl [incl ->]]. + destruct (Nat.max_spec (premise_max (premise x)) (premise_max (premise cl))) as [[hlt ->]|[hge ->]]. + { exists cl. split => //. apply hadd. now right. } + { exists x. firstorder. } + * left. exists x. split; firstorder. subst. + lia. + Qed. -Lemma model_of_strictly_updates cls W V m m' : - clauses_conclusions cls ⊂_lset V -> - strictly_updates cls W m m' -> model_of V m -> model_of V m'. -Proof. - intros hcls su. - induction su. - - intros mv l hin. apply mv in hin. - red in hcls. setoid_rewrite clauses_conclusions_spec in hcls. - destruct cl as [prems [concl k]]. - destruct H0 as [minv [eqmin hlt nabove eqm]]. rewrite eqm. - specialize (hcls concl). forward hcls. exists (prems, (concl, k)). split => //. - rewrite LevelMapFact.F.add_in_iff. now right. - - eauto. -Qed. + Lemma max_clause_premise_mon {cls cls'} : + cls ⊂_clset cls' -> + (max_clause_premise cls <= max_clause_premise cls')%nat. + Proof using Type. + intros hincl. + have [[cl [hin hs]]|[he hs]] := max_clause_premise_spec2 cls; + have [[cl' [hin' hs']]|[he' hs']] := max_clause_premise_spec2 cls'. + - apply hincl in hin. + have hm := max_clause_premise_spec _ _ hin. + have hm' := max_clause_premise_spec _ _ hin'. lia. + - rewrite hs'. apply hincl in hin. now eapply he' in hin. + - rewrite hs. lia. + - lia. + Qed. -Lemma total_model_of_strictly_updates cls W m m' : - strictly_updates cls W m m' -> - forall W', total_model_of W' m -> total_model_of W' m'. -Proof. - intros su. - induction su. - - intros W' mv l hin. apply mv in hin. - destruct cl as [prems [concl k]]. - destruct H0 as [minv [eqmin hlt nabove eqm]]. setoid_rewrite eqm. - setoid_rewrite LevelMapFact.F.add_mapsto_iff. - red in mv. - destruct (eq_dec concl l). - * subst. eexists. left. split => //. - * destruct hin as [? lH]. eexists; right. split => //. exact lH. - - eauto. -Qed. -Lemma check_model_ne {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> ~ LevelSet.Empty W. -Proof. - move/check_model_spec => [w'' [su ->]]. - apply strictly_updates_non_empty in su. - intros he. apply su. lsets. -Qed. + Lemma update_total_model W m m' : + model_of W m -> + model_of W (model_update m m'). + Proof. + intros mof k inW. + apply mof in inW as [v inW]. + destruct (LevelMapFact.F.In_dec m' k). + - destruct i as [v' inm']. exists v'. + rewrite model_update_spec. right; firstorder. + - exists v. rewrite model_update_spec. left. split => //. + Qed. -Lemma check_model_update_of {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> - exists W', is_update_of cls W' m m' /\ W = LevelSet.union U W'. -Proof. - move/check_model_spec => [w'' [su ->]]. exists w''. split => //. - now eapply is_update_of_strictly_updates. -Qed. + Lemma model_map_outside_update W m m' : + only_model_of W m' -> + model_map_outside W m (model_update m m'). + Proof. + intros om l nin k. + rewrite model_update_spec. + firstorder. + Qed. -Axiom todo : forall {A}, A. + Lemma valid_model_only_model W W' m cls : + forall vm : valid_model W W' m cls, + only_model_of W m -> only_model_of W (model_model vm). + Proof. + intros vm. + have incl := model_incl vm. + destruct vm as [m' mof isupd clsincl ism]. cbn. + move: isupd; rewrite /is_update_of. + destruct LevelSet.is_empty eqn:heq. now intros ->. + intros su om. + eapply strictly_updates_only_model_gen in su; tea. + eapply only_model_of_eq; tea. intro. lsets. + Qed. -Lemma opt_le_lt_trans {x y z} : opt_le Z.le x y -> opt_le Z.lt y z -> opt_le Z.lt x z. -Proof. - destruct 1; intros H'; depelim H'; constructor. lia. -Qed. + Lemma valid_model_is_update_of W W' m cls : + model_of W m -> + forall vm : valid_model W W' (restrict_model W m) (cls ⇂ W), + is_update_of (cls ⇂ W) W' m (model_update m (model_model vm)). + Proof. + intros mofW vm. + have incl := model_incl vm. + destruct vm as [m' mof isupd clsincl ism]. cbn. + move: isupd. rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros <-. now rewrite model_update_restrict. + - intros su. eapply strictly_updates_restrict_model in su; tea. + Qed. -Lemma strictly_updates_all cls V minit m : strictly_updates cls V minit m -> - (forall l k, LevelSet.In l V -> LevelMap.MapsTo l k minit -> exists k', LevelMap.MapsTo l k' m /\ opt_le Z.lt k k'). -Proof. - induction 1. - - intros l k hin hm. - move: H0; rewrite /strict_update. - destruct cl as [prems [concl gain]]. - move=> [] v [] minp hlt. cbn in hin. eapply LevelSet.singleton_spec in hin. red in hin; subst l. - move/negbTE; rewrite /level_value_above. - intros hle eq. setoid_rewrite eq. - eexists. setoid_rewrite LevelMapFact.F.add_mapsto_iff. split; [left;split;eauto|] => //. - destruct level_value eqn:hl => //. - * rewrite (level_value_MapsTo hm) in hl. subst k. constructor. lia. - * rewrite (level_value_MapsTo hm) in hl. subst k. constructor. - - intros l k; rewrite LevelSet.union_spec; move=> [] hin hm. - apply IHstrictly_updates1 in hm as [k' [hle hm']]; tea. - eapply strictly_updates_ext in H0. apply H0 in hle as [k'' [hm'' lek'']]. - exists k''. split => //. eapply opt_lt_le_trans; tea. - eapply strictly_updates_ext in H. eapply H in hm as [k' [hm' lek']]. - eapply IHstrictly_updates2 in hm' as [k'' [hm'' lek'']]; tea. - exists k''. split => //. eapply opt_le_lt_trans; tea. -Qed. + Infix "=_clset" := Clauses.Equal (at level 90). -Lemma strictly_updates_zero_model cls V mzero m : - (forall l, LevelSet.In l V -> LevelMap.MapsTo l (Some 0%Z) mzero) -> - strictly_updates cls V mzero m -> - forall l, LevelSet.In l V -> exists k, LevelMap.MapsTo l (Some k) m /\ (0 < k)%Z. -Proof. - intros ho. - move/strictly_updates_all => ha l hin. - eapply ha in hin; revgoals. now apply ho. - destruct hin as [k' [hm hle]]; depelim hle. - now exists y. -Qed. + Lemma valid_model_is_update_of_eq W W' m cls cls' : + model_of W m -> + forall vm : valid_model W W' (restrict_model W m) cls, + cls =_clset (cls' ⇂ W) -> + is_update_of cls W' m (model_update m (model_model vm)). + Proof. + intros mofW vm. + have incl := model_incl vm. + destruct vm as [m' mof isupd clsincl ism]. cbn. + move: isupd. rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros <-. now rewrite model_update_restrict. + - intros su eq. rewrite eq in su. eapply strictly_updates_restrict_model in su; tea. + now rewrite eq. + Qed. -Lemma In_to_clauses (prems : nonEmptyLevelExprSet) (concl : nonEmptyLevelExprSet) : - forall cl, - Clauses.In cl (to_clauses prems concl) <-> - exists concle, LevelExprSet.In concle concl /\ cl = (prems, concle). -Proof. Admitted. + Lemma valid_clause_preserved {m m' cl} : + (forall x, LevelSet.In x (clause_levels cl) -> level_value m x = level_value m' x) -> + valid_clause m cl -> + valid_clause m' cl. + Proof. + intros hcl. destruct cl as [prems [concl k]]. + rewrite /valid_clause //=. + rewrite (@min_premise_preserved m m' prems). + { intros x inp. apply hcl. rewrite clause_levels_spec. now left. } + destruct (min_premise m' prems) => //. + rewrite /level_value_above. rewrite hcl //. + rewrite clause_levels_spec. now right. + Qed. -Lemma In_add_prems k (prems : nonEmptyLevelExprSet): - forall le, LevelExprSet.In le (add_prems k prems) <-> - exists le', LevelExprSet.In le' prems /\ le = add_expr k le'. -Proof. Admitted. + Lemma is_model_update W m m' cls : + model_of W m -> + only_model_of W m' -> + is_model (cls ⇂ W) m' -> + is_model (cls ⇂ W) (model_update m m'). + Proof. + intros mW om. + rewrite /is_model. + move/Clauses.for_all_spec. intros h. + apply Clauses.for_all_spec. tc. + intros cl hin. + specialize (h cl hin). cbn in h. + eapply valid_clause_preserved; tea. + move=>x; move: hin. rewrite in_restrict_clauses. + intros [incl inprems incls]. + rewrite clause_levels_spec. move=> [] hin. + - apply inprems in hin. + rewrite /level_value. + apply levelmap_find_eq => k. + rewrite model_update_spec. clear -mW om hin. firstorder. + - subst x. apply levelmap_find_eq => k. + rewrite model_update_spec. cbn in *. firstorder. cbn in H. + apply om in incl as [x hm]. now apply H in hm. + Qed. -Derive Signature for entails. + Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) + (loop : forall (V' U' : LevelSet.t) (cls' : clauses) (minit m : model) + (prf : [/\ clauses_levels cls' ⊂_lset V', only_model_of V' minit & + is_update_of cls' U' minit m]), + lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls' minit). -Lemma entails_pred_closure {cls prems concl k} : entails cls (prems, (concl, 1 + k)) -> entails cls (prems, (concl, k)). -Proof. - intros he. - depind he. - - eapply clause_cut. - constructor. - 2:{ intros l hin. rewrite LevelExprSet.singleton_spec in hin. red in hin; subst l. rewrite Nat.add_1_r; exact H. } - constructor. - rewrite LevelExprSet.add_spec. lesets. - - eapply clause_cut; tea. -Qed. + Section innerloop_partition. + Context (W : LevelSet.t) (cls : clauses). + Context (premconclW conclW : clauses). + Context (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W, + Clauses.Equal premconclW (cls ⇂ W) & Clauses.Equal conclW (Clauses.diff (cls ↓ W) (cls ⇂ W))]). -Lemma entails_pred_closure_n {cls prems concl k n} : - entails cls (prems, (concl, k + n)) -> entails cls (prems, (concl, k)). -Proof. - induction n in k |- *. - - rewrite Nat.add_0_r. tauto. - - intros hen. rewrite Nat.add_succ_r in hen. - eapply IHn. now eapply entails_pred_closure in hen. -Qed. + #[tactic="idtac"] + Equations? inner_loop_partition (m : model) (upd : strictly_updates cls W init_model m) : + result W LevelSet.empty cls m + by wf (measure W cls m) lt := + inner_loop_partition m upd with loop W LevelSet.empty premconclW (restrict_model W m) (restrict_model W m) _ _ := { + (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) + | Loop W ne n isl => Loop W ne n (loop_on_subset _ isl) + (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). + By invariant Wr ⊂ W *) + | Model Wr mr empWr with inspect (check_model conclW (Wr, model_update m (model_model mr))) := { + | exist None eqm => Model Wr {| model_model := model_update m (model_model mr) |} _ + | exist (Some (Wconcl, mconcl)) eqm with inner_loop_partition mconcl _ := { + (* Here Wr ⊂ Wconcl by invariant *) + | Loop W ne n isl => Loop W ne n isl + | Model Wr' mr' UWconcl => Model (LevelSet.union Wconcl Wr') {| model_model := model_model mr' |} _ } + (* Here Wr' ⊂ W by invariant *) + (* We check if the new model [mr] for (cls ⇂ W) extends to a model of (cls ↓ W). *) + (* We're entitled to recursively compute a better model starting with mconcl, + as we have made the measure decrease: + some atom in W has been strictly updated in Wconcl. *) + } }. + Proof. + all:try solve [try apply LevelSet.subset_spec; try reflexivity]. + all:cbn [model_model]; clear loop inner_loop_partition. + all:try apply LevelSet.subset_spec in hsub. + all:auto. + all:try destruct prf as [WV neW UW clsW eqprem eqconcl]. + all:try solve [intuition auto]. + all:try rewrite eqconcl in eqm. + - split => //. + * rewrite eqprem. apply clauses_levels_restrict_clauses. + * now eapply strictly_updates_restrict_only_model. + (* * eapply (strictly_updates_total_model upd). *) + (* * rewrite eqprem. transitivity cls => //. apply restrict_clauses_subset. *) + (* * eapply strictly_updates_weaken in upd; tea. eapply above_max_premise_model_trans in maxp; tea. *) + * eapply is_update_of_empty. + - left. now eapply strict_subset_cardinal. + - rewrite eqprem. eapply restrict_clauses_subset. + (* - destruct prf. transitivity (cls ⇂ W) => //. now rewrite H3. eapply restrict_clauses_subset. *) + - have mu := model_updates mr. + setoid_rewrite eqprem at 1 in mu. + eapply strictly_updates_is_update_of_restrict in upd; tea. + apply check_model_spec in eqm as [Wconcl' [sumr ->]]. + have tr := strictly_updates_trans upd sumr. + eapply strictly_updates_clauses_W; tea. + { intros ?. now rewrite ClausesProp.union_sym union_diff_cls. } + { have incl := model_incl mr. apply strictly_updates_incl in sumr. + have hdiff := clauses_conclusions_diff_left cls W (cls ⇂ W). lsets. } + - have tmr : model_of W (model_model mr). + { eapply valid_model_total. eapply strictly_updates_restrict_only_model in upd. + intro. apply upd. } + have tmr' : model_of W (model_update m (model_model mr)). + { eapply update_total_model; tea. now apply strictly_updates_total_model in upd. } + eapply (check_model_spec_diff tmr') in eqm as [subwwconcl subwconcl hm hext] => //. + pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). + destruct hm as [cll [hind nvalid inwconcl hl]]. + eapply Nat.lt_le_trans with (measure W cls (model_update m (model_model mr))). + 2:{ eapply measure_le; eauto; try eapply mr; tea. + - now eapply strictly_updates_total_model in upd. + - apply model_map_outside_update. eapply valid_model_only_model. + now eapply strictly_updates_restrict_only_model. + - eapply is_update_of_ext. + have mof := strictly_updates_model_of upd. + apply: valid_model_is_update_of_eq _ _ _ _ cls mof mr eqprem. } + eapply measure_lt; tea. + { eapply model_map_outside_weaken. eapply hext. have incl := model_incl mr. lsets. } + { apply hext. } + eapply invalid_clause_measure in nvalid; tea. + exists (levelexpr_level (concl cll)). + split => //. + eapply clauses_conclusions_diff_left; tea. + eapply clauses_conclusions_spec. exists cll; split => //. exact hind. + have incl := model_incl mr. eapply model_of_subset; tea. + - apply mr'. + - have updm : is_update_of premconclW Wr m (model_update m (model_model mr)). + { exact: valid_model_is_update_of_eq _ _ _ _ cls (strictly_updates_model_of upd) mr eqprem. } + eapply check_model_is_update_of in eqm as [eqm incl]. 2:eapply updm. + eapply strictly_updates_is_update_of in eqm. 2:eapply mr'. + eapply is_update_of_strictly_updates in eqm. + eapply is_update_of_weaken; tea. + now rewrite eqprem (ClausesProp.union_sym (cls ⇂ W)) union_diff ClausesProp.union_sym union_with_concl. + - apply mr'. + - lsets. + - have updm : is_update_of premconclW Wr m (model_update m (model_model mr)). + { exact: valid_model_is_update_of_eq _ _ _ _ cls (strictly_updates_model_of upd) mr eqprem. } + eapply update_total_model. now apply strictly_updates_model_of in upd. + - have updm : is_update_of premconclW Wr m (model_update m (model_model mr)). + { exact: valid_model_is_update_of_eq _ _ _ _ cls (strictly_updates_model_of upd) mr eqprem. } + eapply is_update_of_weaken. 2:apply updm. rewrite eqprem. apply restrict_clauses_subset. + - rewrite check_model_is_model in eqm. + have okm := (model_ok mr). + have okupdm : is_model premconclW (model_update m (model_model mr)). + { setoid_rewrite eqprem at 1. apply is_model_update. apply strictly_updates_model_of in upd; tea. + eapply valid_model_only_model. now eapply strictly_updates_restrict_only_model. + now setoid_rewrite <- eqprem at 1. } + have mu := is_model_union okupdm eqm. + rewrite {1}eqprem in mu. + rewrite union_diff_eq in mu. + rewrite union_restrict_with_concl in mu. + now rewrite (clauses_conclusions_eq _ _ clsW). + Qed. + End innerloop_partition. -Lemma add_clause_0 cl : add_clause 0 cl = cl. -Proof. - destruct cl as [prems [concl k]]; cbn. - f_equal. 2:now rewrite Nat.add_0_r. - unfold add_prems. - eapply eq_univ'. intros [l k']. - rewrite NonEmptySetFacts.map_spec. - unfold add_expr. firstorder. destruct x. noconf H0. - now rewrite Nat.add_0_r. -Qed. + (* We first partition the clauses among those that mention only W and the ones that can mention other atoms. + We then call the loop on these two sets of clauses, which not need to change during the recursive calls. + *) + #[tactic="idtac"] + Equations? inner_loop (W : LevelSet.t) (cls : clauses) (m : model) + (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & + strictly_updates cls W init_model m]) : result W LevelSet.empty cls m := + inner_loop W cls m prf with inspect (Clauses.partition (premise_restricted_to W) cls) := + | exist (premconclW, conclW) eqp => inner_loop_partition W cls premconclW conclW _ m _. + Proof. + - destruct prf as [subWV neW UW clsW mW]. + eapply (clauses_partition_spec clsW) in eqp as [eqprem eqconcl]. + split => //. now rewrite -(clauses_conclusions_eq _ _ clsW). + - apply prf. + Qed. -Lemma incls0 {cls cl} : Clauses.In cl cls -> in_pred_closure cls cl. -Proof. - intros hin. - have hcl := incls _ _ 0 hin. - now rewrite add_clause_0 in hcl. -Qed. +End InnerLoop. -Lemma entails_in {cls cl} : Clauses.In cl cls -> entails cls cl. +Local Open Scope nat_scope. +Lemma diff_cardinal_inter V W : #|LevelSet.diff V W| = #|V| - #|LevelSet.inter V W|. Proof. - intros hin. - destruct cl as [prems concl]. - eapply clause_cut. - - now eapply incls0. - - constructor. eapply LevelExprSet.add_spec. now left. - - reflexivity. + pose proof (LevelSetProp.diff_inter_cardinal V W). lia. Qed. - - -Lemma in_pred_closure_shift {cls cl} n : in_pred_closure cls cl -> in_pred_closure cls (add_clause n cl). +Lemma diff_cardinal V W : W ⊂_lset V -> #|LevelSet.diff V W| = #|V| - #|W|. Proof. - destruct 1. - - rewrite add_clause_add_clause. now constructor. - - cbn. eapply in_pred_closure_equal with (singleton (x, k + 1 + n)). - { intros le. rewrite In_add_prems; rewrite_strat (topdown LevelExprSet.singleton_spec). - intuition auto. exists (x, k + 1). split => //. - now destruct H as [le' [-> ->]]. } - rewrite -Nat.add_assoc. rewrite -[1 + _](Nat.add_1_r n) Nat.add_assoc. constructor. + intros hsub. + rewrite diff_cardinal_inter LevelSetProp.inter_sym LevelSetProp.inter_subset_equal //. Qed. -Lemma add_clause_singleton n le concl k : add_clause n (singleton le, (concl, k)) = (singleton (add_expr n le), (concl, k + n)). +Lemma is_modelP m cls : reflect (Clauses.For_all (valid_clause m) cls) (is_model cls m). Proof. - rewrite /add_clause //=. f_equal. - apply eq_univ'. intros le'. rewrite In_add_prems. - rewrite_strat (topdown LevelExprSet.singleton_spec). - unfold LevelExprSet.E.eq. firstorder. subst. reflexivity. + case E: is_model; constructor. + - now move: E; rewrite /is_model -ClausesFact.for_all_iff. + - intros hf. apply ClausesFact.for_all_iff in hf; tc. unfold is_model in E; congruence. Qed. -Lemma entails_shift {cls cl} n : entails cls cl -> entails cls (add_clause n cl). +Lemma is_model_invalid_clause cl cls m : is_model cls m -> ~~ valid_clause m cl -> ~ Clauses.In cl cls. Proof. - induction 1. - - unfold add_clause. constructor. - rewrite In_add_prems. exists concl0. split => //. - - eapply (clause_cut _ (add_prems n prems') (add_expr n concl')). - 2:{ unfold add_clause in *. eapply entails_equal; tea. - intros le. setoid_rewrite In_add_prems. setoid_rewrite LevelExprSet.add_spec. - setoid_rewrite In_add_prems. - unfold LevelExprSet.E.eq. firstorder. subst. now left. } - 2:{ intros x. rewrite !In_add_prems. firstorder. } - eapply (in_pred_closure_shift _ H). + move/is_modelP => ism /negP valid hin. + now specialize (ism _ hin). Qed. -Lemma of_level_set_singleton l k hne : of_level_set (LevelSet.singleton l) k hne = singleton (l, k). +Lemma strict_subset_leq_right U V W : + strict_subset U V -> V ⊂_lset W -> strict_subset U W. Proof. - apply: eq_univ'. move=> [l' k']. - rewrite /of_level_set //= levelexprset_of_levels_spec !LevelExprSet.singleton_spec LevelSet.singleton_spec /LevelSet.E.eq /LevelExprSet.E.eq. - firstorder subst => //. now noconf H. now noconf H. + intros [] le. split. lsets. intros eq. rewrite -eq in le. + apply H0. lsets. Qed. -Lemma entails_subset cls (prems prems' : nonEmptyLevelExprSet) concl : LevelExprSet.Subset prems prems' -> - entails cls (prems, concl) -> - entails cls (prems', concl). +Lemma strict_subset_leq_left U V W : + U ⊂_lset V -> strict_subset V W -> strict_subset U W. Proof. - intros hsubt. - intros H; revert prems' hsubt; depind H. - - constructor. eapply hsubt, H. - - intros prems'' hsub. - eapply clause_cut. 2:eapply IHentails. tea. - 2:lesets. intros x; rewrite !LevelExprSet.add_spec. firstorder. + intros le []. split. lsets. intros eq. rewrite eq in le. + apply H0. lsets. Qed. -Lemma entails_trans {cls prems concl concl'} : - entails cls (prems, concl) -> - entails cls (singleton concl, concl') -> - entails cls (prems, concl'). +(* Lemma strict_subset_union_right U U' V W : + strict_subset V W -> U ⊂_lset U' -> + strict_subset (LevelSet.union U V) (LevelSet.union U' W). Proof. - intros H; depind H. - - intros he. - depelim he. - * rewrite LevelExprSet.singleton_spec in H0. red in H0; subst concl0. - now constructor. - * eapply (clause_cut _ prems'). tea. - eapply entails_subset; tea. - intros ?; rewrite !LevelExprSet.add_spec LevelExprSet.singleton_spec; firstorder. - red in H2; subst a. now right. intros x. firstorder. apply H1 in H2. - rewrite LevelExprSet.singleton_spec in H2. now red in H2; subst x. - - intros he. - specialize (IHentails concl'0 he). - eapply clause_cut; tea. -Qed. + rewrite /strict_subset. + intros [] hu. split. lsets. intros he. + apply H0. + intros x. split. apply H. + specialize (he x). intros inW. + rewrite !LevelSet.union_spec in he. + destruct he as [he he']. + forward he'. now right. destruct he' => //. + forward he. apply he in + red in he. *) -Lemma add_comm {le le' e} : add le (add le' e) = add le' (add le e). +Lemma strict_subset_diff_incl V W W' : + strict_subset W' W -> + W ⊂_lset V -> + W' ⊂_lset V -> + strict_subset (LevelSet.diff V W) (LevelSet.diff V W'). Proof. - apply eq_univ'. intros x. - rewrite !LevelExprSet.add_spec. firstorder. + intros [] lew lew'. + split. lsets. + intros eq. + apply H0. lsets. Qed. -#[program] -Definition univ_union (prems prems' : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := - {| t_set := LevelExprSet.union prems prems' |}. -Next Obligation. - destruct prems, prems'; cbn. - destruct (LevelExprSet.is_empty (LevelExprSet.union _ _)) eqn:ise => //. - eapply LevelExprSetFact.is_empty_2 in ise. - eapply not_Empty_is_empty in t_ne0, t_ne1. - destruct t_ne0. lesets. -Qed. +(* To help equations *) +Opaque lexprod_rel_wf. -Lemma univ_union_spec u u' l : - LevelExprSet.In l (univ_union u u') <-> - LevelExprSet.In l u \/ LevelExprSet.In l u'. +Lemma check_model_spec_V {V cls w m w' m'} : + model_of V m -> clauses_conclusions cls ⊂_lset V -> + model_of w m -> + check_model cls (w, m) = Some (w', m') -> + check_model_invariants cls w m w' m' true. Proof. - destruct u, u'; unfold univ_union; cbn. - apply LevelExprSet.union_spec. + cbn; intros mof incl tot cm. + apply check_model_has_invariants in cm => //. + eapply model_of_subset. exact mof. tea. Qed. -Lemma entails_weak {cls prem concl concl'} : - entails cls (prem, concl) -> - entails cls (add concl' prem, concl). -Proof. - intros H. depind H. - - constructor. apply LevelExprSet.add_spec. now right. - - eapply (clause_cut _ _ concl'); tea. - rewrite add_comm. apply IHentails. - intros x; rewrite LevelExprSet.add_spec. firstorder. -Qed. +Section Semantics. -Lemma univ_union_add_singleton u le : univ_union u (singleton le) = add le u. -Proof. - apply eq_univ'. - intros x. rewrite univ_union_spec LevelExprSet.singleton_spec add_spec. - intuition auto. -Qed. + Section Interpretation. + Context (V : LevelMap.t nat). -Lemma univ_union_comm {u u'} : univ_union u u' = univ_union u' u. -Proof. - apply eq_univ'. - intros x. rewrite !univ_union_spec. - intuition auto. -Qed. + Definition interp_level l := + match LevelMap.find l V with + | Some x => x + | None => 0%nat + end. -Lemma univ_union_add_distr {le u u'} : univ_union (add le u) u' = add le (univ_union u u'). -Proof. - apply eq_univ'. - intros x. rewrite !univ_union_spec !add_spec !univ_union_spec. - intuition auto. -Qed. + Definition interp_expr '(l, k) := (interp_level l + k)%nat. + Definition interp_prems prems := + let '(hd, tl) := to_nonempty_list prems in + fold_right (fun lk acc => Nat.max (interp_expr lk) acc) (interp_expr hd) tl. -Lemma entails_weak_union {cls prem concl concl'} : - entails cls (prem, concl) -> - entails cls (univ_union concl' prem, concl). -Proof. - intros hyp. - move: concl'. - apply: nonEmptyLevelExprSet_elim. - - intros le. rewrite univ_union_comm univ_union_add_singleton. - now apply entails_weak. - - intros le prems ih. - rewrite univ_union_add_distr. - now eapply entails_weak. -Qed. + Definition clause_sem (cl : clause) : Prop := + let '(prems, concl) := cl in + interp_prems prems >= interp_expr concl. -Lemma entails_all_weak {cls prem concl concl'} : - entails_all cls prem concl -> - entails_all cls (add concl' prem) concl. -Proof. - intros hcl x hin. - specialize (hcl _ hin). cbn in hcl. - now apply entails_weak. -Qed. + Definition clauses_sem (cls : clauses) : Prop := + Clauses.For_all clause_sem cls. + End Interpretation. -Lemma entails_all_weak_union {cls prem concl concl'} : - entails_all cls prem concl -> - entails_all cls (univ_union concl' prem) concl. -Proof. - intros hcl x hin. - specialize (hcl _ hin). cbn in hcl. - now apply entails_weak_union. -Qed. + (* There exists a valuation making all clauses true in the natural numbers *) + Definition satisfiable (cls : clauses) := + exists V, clauses_sem V cls. -Lemma entails_all_weak' {cls prem concl concl'} : - entails_all cls prem concl -> - entails_all cls (add concl' prem) (add concl' concl). -Proof. - intros hcl x hin. - eapply LevelExprSet.add_spec in hin as []. red in H; subst. - - constructor. eapply LevelExprSet.add_spec. now left. - - specialize (hcl _ H). cbn in hcl. - now apply entails_weak. -Qed. + (* Any valuation making all clauses valid in the natural numbers also satisfies the clause cl *) + Definition entails_sem (cls : clauses) (cl : clause) := + forall V, clauses_sem V cls -> clause_sem V cl. +End Semantics. -Lemma entails_cut_all {cls prems' concl' prems concls} : - in_pred_closure cls (prems', concl') -> - cls ⊢a add concl' prems → concls -> - prems' ⊂_leset prems -> - cls ⊢a prems → concls. -Proof. - intros inp he hp x hin. - eapply clause_cut; tea. - now apply he in hin. -Qed. -Lemma entails_all_subset {cls} {prems prems' prems'' : nonEmptyLevelExprSet} : - prems'' ⊂_leset prems' -> - cls ⊢a prems → prems' -> - cls ⊢a prems → prems''. -Proof. - intros incl ha x hin. - eapply incl in hin. now apply ha in hin. -Qed. +Local Open Scope Z_scope. +Lemma max_min max min k : min <= 0 -> max >= 0 -> k <= max -> k >= min -> (max - k - min) >= 0. +Proof. lia. Qed. + +Definition model_min m := + LevelMap.fold (fun l k acc => Nat.min acc k) m 0%nat. -(* Lemma entails_all_one {cls prems concl concl'} : - entails_all cls prems concl -> - entails cls (univ_union concl prems, concl') -> - entails cls (prems, concl'). -Proof. - intros hall he; depind he. - - eapply LevelExprSet.union_spec in H as []. - 2:now constructor. - now eapply hall in H. - - eapply clause_cut in he; tea. 3:reflexivity. specialize (IHhe _ _ concl0 hall). *) +(* Lemma model_min_spec m : forall l k, LevelMap.MapsTo l k m -> (Some (model_min m) ≤ k). *) +(* Proof. Admitted. *) -Lemma entails_all_add cls prem l prems' : - cls ⊢a prem → add l prems' <-> - cls ⊢ prem → l /\ cls ⊢a prem → prems'. -Proof. - rewrite /entails_all /LevelExprSet.For_all. - setoid_rewrite LevelExprSet.add_spec; rewrite /LevelExprSet.E.eq. - firstorder. now subst. -Qed. +Definition model_max m := + LevelMap.fold (fun l k acc => Nat.max acc k) m 0%nat. -Lemma entails_add {cls prems cl concl} : - entails cls (prems, cl) -> - entails cls (add cl prems, concl) -> - entails cls (prems, concl). -Proof. - intros H; depind H. - - intros he. - depelim he. - * rewrite LevelExprSet.add_spec in H0. destruct H0 as []. - { red in H0; subst concl0. now constructor. } - { now constructor. } - * have eq : prems = add concl0 prems. - { eapply eq_univ'. intros x; rewrite LevelExprSet.add_spec. firstorder. now red in H2; subst. } - rewrite -eq in H1. - eapply (clause_cut _ prems' _ prems). tea. 2:tea. - now rewrite -eq in he. - - intros he. - eapply clause_cut. tea. eapply IHentails. - rewrite add_comm. now eapply entails_weak. - exact H1. -Qed. +(* Lemma model_max_spec m : forall l k, LevelMap.MapsTo l k m -> (k ≤ Some (model_max m))%Z. *) +(* Proof. Admitted. *) -Lemma entails_cumul_one {cls prems prems' concl} : - entails_all cls prems prems' -> - entails cls (univ_union prems prems', concl) -> - entails cls (prems, concl). -Proof. - revert prems' prems concl. - apply: nonEmptyLevelExprSet_elim. - - intros. specialize (H le). forward H by now apply LevelExprSet.singleton_spec. - cbn in H. - eapply entails_add; tea. - now rewrite -univ_union_add_singleton. - - intros le prems ih prem concl' hadd hadd'. - rewrite univ_union_comm univ_union_add_distr -univ_union_comm -univ_union_add_distr in hadd'. - eapply ih in hadd'. 2:{ apply entails_all_weak. apply entails_all_add in hadd as []. exact H0. } - apply entails_all_add in hadd as []. - eapply entails_add; tea. -Qed. +Definition valuation_of_model (m : model) : LevelMap.t nat := + let min := model_min m in + let max := model_max m in + LevelMap.fold (fun l k acc => LevelMap.add l (max - k - min)%nat acc) m (LevelMap.empty _). +Close Scope Z_scope. -Lemma entails_all_cumul {cls prems prems' concl} : - entails_all cls prems prems' -> - entails_all cls (univ_union prems prems') concl -> - entails_all cls prems concl. +Lemma valuation_of_model_spec m : + forall l k, LevelMap.MapsTo l k m -> + let v := (model_max m - k - model_min m)%nat in + LevelMap.MapsTo l v (valuation_of_model m). +Proof. Admitted. + + +Definition correct_model (cls : clauses) (m : model) := + enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. + +Lemma strictly_updates_valid_model {W W' m m' cls} : + is_model (cls ↓ W) m -> + strictly_updates cls W' m m' -> + exists l, LevelSet.In l W' /\ ~ LevelSet.In l W. Proof. - intros hp hc. - intros x hin. apply hc in hin. - eapply entails_cumul_one; tea. + intros vm. induction 1. + - exists (clause_conclusion cl). split => //. lsets. intros hin. + eapply strict_update_invalid in H0. + eapply is_model_invalid_clause in vm; tea. apply vm. + eapply in_clauses_with_concl. split => //. + - destruct (IHstrictly_updates1 vm). exists x. + rewrite LevelSet.union_spec. firstorder. Qed. -Lemma entails_all_one {cls prem concl concl'} : - entails_all cls prem concl -> - entails cls (concl, concl') -> - entails cls (prem, concl'). +Lemma model_of_strictly_updates cls W V m m' : + strictly_updates cls W m m' -> model_of V m -> model_of V m'. Proof. - intros ha he. - eapply entails_cumul_one; tea. - now eapply entails_weak_union. + intros su. + induction su. + - intros mv l hin. apply mv in hin. + destruct cl as [prems [concl k]]. + destruct H0 as [minv [eqmin hlt nabove eqm]]. rewrite eqm. + rewrite LevelMapFact.F.add_in_iff. now right. + - eauto. Qed. -Lemma entails_all_trans {cls prem concl concl'} : - entails_all cls prem concl -> - entails_all cls concl concl' -> - entails_all cls prem concl'. +Lemma check_model_ne {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> ~ LevelSet.Empty W. Proof. - intros ha he cl hin. - apply he in hin. - eapply entails_all_one; tea. + move/check_model_spec => [w'' [su ->]]. + apply strictly_updates_non_empty in su. + intros he. apply su. lsets. Qed. -Lemma entails_incr_shift cls concl k n : entails cls (singleton (concl, k), (concl, k + 1)) -> - entails cls (singleton (concl, k), (concl, k + 1 + n)). +Lemma check_model_update_of {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> + exists W', is_update_of cls W' m m' /\ W = LevelSet.union U W'. Proof. - induction n in k |- *; auto. - - now rewrite Nat.add_0_r. - - intros en. - have hs := entails_shift 1 en. rewrite add_clause_singleton /= in hs. - apply IHn in hs. - rewrite -Nat.add_assoc Nat.add_1_l in hs. - now eapply entails_trans. + move/check_model_spec => [w'' [su ->]]. exists w''. split => //. + now eapply is_update_of_strictly_updates. Qed. -Lemma entails_incr_all cls concl k : entails cls (singleton (concl, k), (concl, k + 1)) -> - forall k', entails cls (singleton (concl, k), (concl, k')). +Axiom todo : forall {A}, A. + +Lemma opt_le_lt_trans {x y z} : opt_le Z.le x y -> opt_le Z.lt y z -> opt_le Z.lt x z. Proof. - intros en k'. - destruct (Nat.lt_trichotomy k k') as [|[]]; subst; auto. - - eapply (entails_incr_shift _ _ _ (k' - k - 1)) in en. - assert (k + 1 + (k' - k - 1) = k') by lia. now rewrite H0 in en. - - constructor. now rewrite LevelExprSet.singleton_spec. - - have [k0 ->] : (exists kd, k = k' + kd). { exists (k - k'). lia. } - eapply (entails_pred_closure_n (n:=k0)). constructor. now apply LevelExprSet.singleton_spec. + destruct 1; intros H'; depelim H'; constructor. lia. Qed. -Lemma entails_all_concl_union {cls prems concl concl'} : - cls ⊢a prems → concl -> - cls ⊢a prems → concl' -> - cls ⊢a prems → univ_union concl concl'. +Lemma strictly_updates_all cls V minit m : strictly_updates cls V minit m -> + (forall l k, LevelSet.In l V -> LevelMap.MapsTo l k minit -> exists k', LevelMap.MapsTo l k' m /\ Nat.lt k k'). Proof. - intros l r. - rewrite /entails_all. - intros x. rewrite univ_union_spec. intros []. now apply l. now apply r. + induction 1. + - intros l k hin hm. + move: H0; rewrite /strict_update. + destruct cl as [prems [concl gain]]. + move=> [] v [] minp hlt. cbn in hin. eapply LevelSet.singleton_spec in hin. red in hin; subst l. + move/negbTE; rewrite /level_value_above. + intros hle eq. setoid_rewrite eq. + eexists. setoid_rewrite LevelMapFact.F.add_mapsto_iff. split; [left;split;eauto|] => //. + destruct level_value eqn:hl => //. + * rewrite (level_value_MapsTo hm) in hl. noconf hl. lia. + * rewrite (level_value_MapsTo hm) in hl. noconf hl. + - intros l k; rewrite LevelSet.union_spec; move=> [] hin hm. + apply IHstrictly_updates1 in hm as [k' [hle hm']]; tea. + eapply strictly_updates_ext in H0. apply H0 in hle as [k'' [hm'' lek'']]. + exists k''. split => //. lia. + eapply strictly_updates_ext in H. eapply H in hm as [k' [hm' lek']]. + eapply IHstrictly_updates2 in hm' as [k'' [hm'' lek'']]; tea. + exists k''. split => //. lia. Qed. -Lemma entails_all_union {cls prems concl prems' concl'} : - cls ⊢a prems → concl -> - cls ⊢a prems' → concl' -> - cls ⊢a univ_union prems prems' → univ_union concl concl'. +Lemma strictly_updates_zero_model cls V mzero m : + (forall l, LevelSet.In l V -> LevelMap.MapsTo l 0%nat mzero) -> + strictly_updates cls V mzero m -> + forall l, LevelSet.In l V -> exists k, LevelMap.MapsTo l k m /\ (0 < k). Proof. - intros l r. - apply entails_all_concl_union. - rewrite univ_union_comm. - now eapply entails_all_weak_union. - now eapply entails_all_weak_union. + intros ho. + move/strictly_updates_all => ha l hin. + eapply ha in hin; revgoals. now apply ho. + destruct hin as [k' [hm hle]]. + now exists k'. Qed. Lemma of_level_set_union_spec {ls ls' n hne} hne' hne'' : @@ -4635,21 +4930,21 @@ Definition model_domain (m : model) V := Definition model_rel_partial R V (m m' : model) := forall l, - (LevelSet.In l V -> forall k, LevelMap.MapsTo l (Some k) m -> - exists k', LevelMap.MapsTo l (Some k') m' /\ R k k') /\ + (LevelSet.In l V -> forall k, LevelMap.MapsTo l k m -> + exists k', LevelMap.MapsTo l k' m' /\ R k k') /\ (~ LevelSet.In l V -> forall k, LevelMap.MapsTo l k m <-> LevelMap.MapsTo l k m'). -Lemma total_model_of_sext {R W W' m m'} : - total_model_of W m -> - total_model_of W' m -> - model_rel_partial R W m m' -> total_model_of W' m'. +Lemma model_of_sext {R W W' m m'} : + model_of W m -> + model_of W' m -> + model_rel_partial R W m m' -> model_of W' m'. Proof. intros mof mof' ext. intros l hin. destruct (mof' l hin). specialize (ext l) as [lin lout]. destruct (inLevelSet W l) as [hin'|hout]. - specialize (lin hin' _ H). firstorder. - - specialize (lout hout (Some x)). + - specialize (lout hout x). exists x. now apply lout. Qed. @@ -4674,12 +4969,12 @@ Proof. destruct (inLevelSet W' l). + specialize (inWmr' H k' hk') as [k'' [hk'' rk'']]. exists k''. split => //. now transitivity k'. - + specialize (outWmr' H (Some k')). exists k'. split => //. now apply outWmr'. + + specialize (outWmr' H k'). exists k'. split => //. now apply outWmr'. - destruct (inLevelSet W l). + specialize (inWmr H k hm) as [k'' [hk'' rk'']]. specialize (inWmr' hin k'' hk'') as [km' [hkm' rkm']]. exists km'. split => //. now transitivity k''. - + specialize (outWmr H (Some k)) as eq. + + specialize (outWmr H k) as eq. apply eq in hm. specialize (inWmr' hin k hm) as [m''k [hm'' rm'']]. exists m''k. split => //. } @@ -4690,8 +4985,8 @@ Qed. Lemma strictly_updates_model_lt {cls V} {m m'} : strictly_updates cls V m m' -> - total_model_of V m -> - model_rel_partial Z.lt V m m'. + model_of V m -> + model_rel_partial Nat.lt V m m'. Proof. intros su; induction su. - intros htot l. split; revgoals. @@ -4708,15 +5003,15 @@ Proof. destruct H0 as [minp [hmin hlt nabove hm']]. eapply LevelSet.singleton_spec in inv; red in inv; subst l. eapply LevelMapFact.F.MapsTo_fun in hin; tea. noconf hin. - exists (Z.of_nat conclk + minp)%Z. split => //. + exists (conclk + Z.to_nat minp)%nat. split => //. rewrite hm'. rewrite LevelMapFact.F.add_mapsto_iff. left. split => //. move/negbTE: nabove; move/level_value_not_above_spec. rewrite (level_value_MapsTo mt). now intros x; depelim x. - - move/total_model_of_union_inv => [] totls totls'. + - move/model_of_union_inv => [] totls totls'. forward IHsu1 by auto. forward IHsu2. - { eapply total_model_of_sext. exact totls. assumption. eassumption. } + { eapply model_of_sext. exact totls. assumption. eassumption. } now eapply model_rel_partial_trans. Qed. @@ -4732,22 +5027,47 @@ Proof. Qed. #[program] -Definition of_level_map (m : LevelMap.t (option Z)) (hne : ~ LevelMap.Empty m) : nonEmptyLevelExprSet := - {| t_set := LevelMap.fold (fun l k acc => LevelExprSet.add (l, option_default Z.to_nat k 0%nat) acc) m LevelExprSet.empty |}. -Next Obligation. Admitted. +Definition of_level_map (m : LevelMap.t nat) (hne : ~ LevelMap.Empty m) : nonEmptyLevelExprSet := + {| t_set := LevelMap.fold (fun l k acc => LevelExprSet.add (l, k) acc) m LevelExprSet.empty |}. +Next Obligation. apply not_Empty_is_empty. + move: hne. eapply LevelMapFact.fold_rec. firstorder. + intros. rewrite /LevelExprSet.Empty. + rw LevelExprSet.add_spec. intros ha. apply (ha (k, e)). now left. +Qed. Lemma of_level_map_spec m hne : - forall l k, LevelExprSet.In (l, k) (of_level_map m hne) <-> LevelMap.MapsTo l (Some (Z.of_nat k)) m. -Proof. Admitted. - -Notation univ := nonEmptyLevelExprSet. + forall l k, LevelExprSet.In (l, k) (of_level_map m hne) <-> LevelMap.MapsTo l k m. +Proof. + intros l k; rewrite /of_level_map //=. + clear hne. + have : forall acc, + LevelExprSet.In (l, k) + (LevelMap.fold (fun (l0 : LevelMap.key) (k0 : nat) (acc : LevelExprSet.t) => LevelExprSet.add (l0, k0) acc) m acc) <-> + LevelMap.MapsTo l k m \/ LevelExprSet.In (l, k) acc. + move=> acc; eapply LevelMapFact.fold_rec. + - firstorder. + - intros. rewrite LevelExprSet.add_spec H2. + split. + * intros [eq|hm]. + + noconf eq. specialize (H1 l). eapply levelmap_find_eq_inv in H1. + erewrite H1. left. apply LevelMapFact.F.add_mapsto_iff. left => //. + + specialize (H1 l). eapply levelmap_find_eq_inv in H1; erewrite H1. + rewrite LevelMapFact.F.add_mapsto_iff. + destruct (eq_dec l k0); subst; firstorder. + * intros hm'. destruct hm'. + + specialize (H1 l). eapply levelmap_find_eq_inv in H1. eapply H1 in H3. + apply LevelMapFact.F.add_mapsto_iff in H3. destruct H3. firstorder; subst. left. red. red in H3. subst. reflexivity. + unfold LevelExprSet.E.eq. destruct H3. now right; left. + + unfold LevelExprSet.E.eq. now right. + - intros. rewrite H. firstorder. lesets. +Qed. Definition premise_values (prems : univ) m := - NonEmptySetFacts.map (fun '(l, k) => (l, option_default Z.to_nat (level_value m l) 0%nat)) prems. + NonEmptySetFacts.map (fun '(l, k) => (l, option_get 0 (level_value m l))) prems. Lemma premise_values_spec prems m : forall l k, LevelExprSet.In (l, k) (premise_values prems m) <-> - (exists k', LevelExprSet.In (l, k') prems /\ k = option_default Z.to_nat (level_value m l) 0%nat). + (exists k', LevelExprSet.In (l, k') prems /\ k = option_get 0 (level_value m l)). Proof. rewrite /premise_values. intros l k. rewrite NonEmptySetFacts.map_spec. @@ -4756,11 +5076,11 @@ Proof. Qed. Definition hyps_map (hyps : univ) m := - (forall (l : Level.t) (k : nat), LevelExprSet.In (l, k) hyps <-> LevelMap.MapsTo l (Some (Z.of_nat k)) m). + (forall (l : Level.t) (k : nat), LevelExprSet.In (l, k) hyps <-> LevelMap.MapsTo l k m). Lemma model_hyps_entails cls m hyps (prems : univ) concl : Clauses.In (prems, concl) cls -> - (forall l k, LevelExprSet.In (l,k) prems -> Some (Z.of_nat 0) ≤ level_value m l) -> + (forall l k, LevelExprSet.In (l,k) prems -> Some 0 ≤ level_value m l) -> hyps_map hyps m -> cls ⊢a hyps → premise_values prems m. Proof. @@ -4771,7 +5091,7 @@ Proof. constructor. rewrite hm. specialize (hmx l _ inp). depelim hmx. rewrite H0 //=. - rewrite Z2Nat.id. lia. now eapply level_value_MapsTo'. + now eapply level_value_MapsTo'. Qed. Lemma entails_succ cls (u v : univ) : @@ -4786,7 +5106,7 @@ Proof. Qed. Lemma hyps_entails (hyps : univ) m cls : - (forall (l : Level.t) (k : nat), LevelExprSet.In (l, k) hyps <-> LevelMap.MapsTo l (Some (Z.of_nat k)) m) -> + hyps_map hyps m -> forall prems conclk, Clauses.In (prems, conclk) cls -> forall v, min_premise m prems = Some (Z.of_nat v) -> cls ⊢a hyps → add_prems v prems. @@ -4794,7 +5114,7 @@ Proof. intros H prems conclk H0 v H1. have [minsleq mineq] := min_premise_spec m prems. destruct mineq as [[minprem minpremk] [inprems eqminp]]. cbn. - have hmz' : forall l k, LevelExprSet.In (l, k) prems -> Some (Z.of_nat 0) ≤ level_value m l. + have hmz' : forall l k, LevelExprSet.In (l, k) prems -> Some 0 ≤ level_value m l. { intros l k hin. specialize (minsleq _ hin). rewrite H1 in minsleq. cbn in minsleq. destruct level_value => //. depelim minsleq. constructor. lia. depelim minsleq. } move: eqminp. rewrite /min_atom_value. @@ -4811,18 +5131,18 @@ Proof. split. exists premk. split => //. have hmz'' := hmz' prem _ inprem. depelim hmz''. rewrite H4 //=. clear H3. - assert (v = Z.to_nat z - minpremk). lia. subst v. + assert (v = n - minpremk)%nat. lia. subst v. specialize (minsleq _ inprem). cbn in minsleq. rewrite H4 in minsleq. rewrite H1 in minsleq. depelim minsleq. lia. Qed. Definition model_above cls m := forall l, LevelSet.In l (clauses_levels cls) -> - exists k', LevelMap.MapsTo l k' m /\ Some (Z.of_nat (max_clause_premise cls)) ≤ k'. + exists k', LevelMap.MapsTo l k' m /\ max_clause_premise cls <= k'. Lemma model_above_infers {cls m} : model_above cls m -> - (forall l, LevelSet.In l (clauses_levels cls) -> infers_atom m l (Z.of_nat (max_clause_premise cls))). + (forall l, LevelSet.In l (clauses_levels cls) -> infers_atom m l (max_clause_premise cls)). Proof. Admitted. @@ -4856,20 +5176,17 @@ Proof. intros [l k'] hin. eapply of_level_map_spec in hin. rewrite eqm' in hin. rewrite LevelMapFact.F.add_mapsto_iff in hin. - destruct hin as [[eq heq]|[neq hm]]. red in eq. subst l. - noconf heq. - assert (k + (Z.to_nat z - mink) = k'). lia. subst k'. clear H0. + destruct hin as [[eq heq]|[neq hm]]. subst k'. have hypss := of_level_map_spec m hne. set (hyps := of_level_map m hne) in *. clearbody hyps. have entailscl : entails cls (prems, (concl, k)) by exact: entails_in H. - move/(entails_shift (Z.to_nat z - mink)): entailscl. cbn. move => entailscl. - eapply (entails_all_one (concl := add_prems (Z.to_nat z - mink) prems)) => //. + move/(entails_shift (n - mink)%nat): entailscl. cbn. move => entailscl. + eapply (entails_all_one (concl := add_prems (n - mink) prems)) => //. eapply level_value_MapsTo' in hminprem. - assert (exists z', z = Z.of_nat z'). exists (Z.to_nat z). lia. - destruct H0 as [z2 ->]. rename z2 into z. - rewrite -hypss in hminprem. rewrite -> Nat2Z.id in *. + rewrite -hypss in hminprem. eapply hyps_entails; tea. rewrite hmin. lia_f_equal. + have -> : k + Z.to_nat (Z.of_nat n - Z.of_nat mink) = k + (n - mink) by lia. now red in eq; subst concl. constructor. now rewrite of_level_map_spec. - have hnemid : ~ LevelMap.Empty m'. by exact: strictly_updates_non_empty_map su1. specialize (IHsu1 hne hnemid). @@ -4899,11 +5216,11 @@ Proof. Qed. Lemma infers_atom_of_level_map {cls m hne l k} : - infers_atom m l (Z.of_nat k) -> + infers_atom m l k -> cls ⊢ of_level_map m hne → (l, k). Proof. rewrite /infers_atom. intros hle. depelim hle. - have [y' eq] : exists y', y = Z.of_nat (k + y'). exists (Z.to_nat y - k). lia. + have [y' eq] : exists y', y = (k + y'). exists (y - k). lia. eapply (entails_trans (concl := (l, k + y'))). - constructor. rewrite of_level_map_spec. eapply level_value_MapsTo'. rewrite H0. f_equal. lia. @@ -4955,7 +5272,7 @@ Admitted. Lemma strictly_updates_entails_loop cls V (hne : ~ LevelSet.Empty V) mzero m : max_premise_model cls clauses_levels mzero -> V =_lset clauses_levels cls -> - total_model_of V mzero -> + model_of V mzero -> strictly_updates cls V mzero m -> entails_all cls (of_level_set V (max_clause_premise cls) hne) (of_level_set V (max_clause_premise cls + 1) hne). @@ -4976,20 +5293,18 @@ Proof. move: (tot _ hin) => [x hm]. move/(_ _ hm) => [k' [hm' lt]]. intros _. - exists (Z.to_nat k'). + exists k'. unfold max_premise_model in maxp. move: (proj1 maxp l) => hl. forward hl. apply vincl, hin. eapply LevelMapFact.F.MapsTo_fun in hm; tea. noconf hm. - rewrite Z2Nat.id. lia. split => //. lia. Qed. - Lemma strictly_updates_entails_loop_above_max cls V (hne : ~ LevelSet.Empty V) mzero m : above_max_premise_model cls mzero -> V =_lset clauses_levels cls -> - total_model_of V mzero -> + model_of V mzero -> strictly_updates cls V mzero m -> entails_all cls (of_level_set V (max_clause_premise cls) hne) (of_level_set V (max_clause_premise cls + 1) hne). @@ -5011,47 +5326,6 @@ Proof. apply max_premise_model_exists. Qed. -Lemma entails_all_shift {cls : clauses} {prems concl : univ} (n : nat) : - cls ⊢a prems → concl -> - cls ⊢a add_prems n prems → add_prems n concl. -Proof. - intros cla cl. - rewrite In_add_prems => [[le' [hin ->]]]. - eapply (entails_shift (cl := (prems, le'))). - now apply cla in hin. -Qed. - -Lemma in_pred_closure_subset {cls cls' prems concl} : - in_pred_closure cls (prems, concl) -> - cls ⊂_clset cls' -> - in_pred_closure cls' (prems, concl). -Proof. - induction 1. - - move/(_ _ H). now constructor. - - constructor. -Qed. - -Lemma entails_clauses_subset cls cls' prems concl : - cls ⊢ prems → concl -> - cls ⊂_clset cls' -> - cls' ⊢ prems → concl. -Proof. - induction 1 in cls' |- * => incl. - - now constructor. - - eapply clause_cut. - + eapply in_pred_closure_subset; tea. - + now apply IHentails. - + assumption. -Qed. - -Lemma entails_all_clauses_subset cls cls' prems concl : - cls ⊢a prems → concl -> - cls ⊂_clset cls' -> - cls' ⊢a prems → concl. -Proof. - intros d incl [l k]. - now move/d/entails_clauses_subset. -Qed. (* Lemma strictly_updates_restrict cls V m m' : strictly_updates cls V m m' -> @@ -5097,18 +5371,18 @@ Proof. Admitted. Definition domain (l : LevelMap.t (option Z)) : LevelSet.t := LevelSetProp.of_list (List.map fst (LevelMap.elements l)). -Lemma level_value_new_model {m V newk l} : - total_model_of V m -> +(* Lemma level_value_new_model {m V newk l} : + model_of V m -> level_value (new_model m V newk) l = if LevelSet.mem l V then newk else level_value m l. -Admitted. +Admitted. *) -Lemma strictly_updates_entails_loop2 cls V (hne : ~ LevelSet.Empty V) mzero m : +(* Lemma strictly_updates_entails_loop2 cls V (hne : ~ LevelSet.Empty V) mzero m : let bound := v_minus_w_bound V m in let maxgain := max_gain cls in let n := Z.to_nat bound + maxgain in (* V =_lset clauses_levels cls -> *) - total_model_of V mzero -> + model_of V mzero -> strictly_updates cls V mzero m -> entails_all cls (of_level_set V n hne) (of_level_set V (n + 1) hne). Proof. @@ -5154,18 +5428,18 @@ Proof. (* have sue := strictly_updates_entails nem' nem'' _ su'. *) (* forward sue. admit. apply sue in su'. (cls ⇂ V). in su'; tea *) -Admitted. +Admitted. *) -Lemma model_max_max_premise_map cls : Z.to_nat (model_max (max_premise_map cls)) = max_clause_premise cls. +Lemma model_max_max_premise_map cls : (model_max (max_premise_map cls)) = max_clause_premise cls. Proof. Admitted. Lemma strictly_updates_entails_loop_max cls V (hne : ~ LevelSet.Empty V) m : V =_lset clauses_levels cls -> strictly_updates cls V (max_premise_map cls) m -> - entails_all cls (of_level_set V (Z.to_nat (model_max (max_premise_map cls))) hne) - (of_level_set V (Z.to_nat (model_max (max_premise_map cls)) + 1) hne). + entails_all cls (of_level_set V ((model_max (max_premise_map cls))) hne) + (of_level_set V ((model_max (max_premise_map cls)) + 1) hne). Proof. intros. rewrite !model_max_max_premise_map. @@ -5175,15 +5449,15 @@ Proof. Qed. #[program] -Definition of_level_map_n (m : LevelMap.t (option Z)) V n (hne : ~ LevelMap.Empty m) : nonEmptyLevelExprSet := +Definition of_level_map_n (m : LevelMap.t nat) V n (hne : ~ LevelMap.Empty m) : nonEmptyLevelExprSet := {| t_set := LevelMap.fold (fun l k acc => - if LevelSet.mem l V then LevelExprSet.add (l, n + option_default Z.to_nat k 0%nat) acc else - LevelExprSet.add (l, option_default Z.to_nat k 0%nat) acc) m LevelExprSet.empty |}. + if LevelSet.mem l V then LevelExprSet.add (l, n + k) acc else + LevelExprSet.add (l, k) acc) m LevelExprSet.empty |}. Next Obligation. Admitted. Lemma of_level_map_n_spec m V hne : forall l n k, LevelExprSet.In (l, k) (of_level_map_n m V n hne) -> - (exists k', LevelMap.MapsTo l (Some (Z.of_nat k')) m /\ + (exists k', LevelMap.MapsTo l k' m /\ (LevelSet.In l V -> k = n + k') /\ (~ LevelSet.In l V -> k = k')). Proof. @@ -5192,17 +5466,17 @@ Admitted. Lemma of_level_map_n_spec_inv m V hne : forall l n k, LevelMap.MapsTo l k m -> exists k', LevelExprSet.In (l, k') (of_level_map_n m V n hne) /\ - (LevelSet.In l V -> k' = n + option_default Z.to_nat k 0%nat) /\ - (~ LevelSet.In l V -> k' = option_default Z.to_nat k 0%nat). + (LevelSet.In l V -> k' = n + k) /\ + (~ LevelSet.In l V -> k' = k). Proof. Admitted. Lemma entails_any_one V cls m nem m' nem' : - total_model_of V m -> + model_of V m -> cls ⊢a of_level_map m nem → of_level_map m' nem' -> - model_rel_partial Z.lt V m m' -> + model_rel_partial Nat.lt V m m' -> forall l k, LevelSet.In l V -> - LevelMap.MapsTo l (Some (Z.of_nat k)) m -> cls ⊢ of_level_map m nem → (l, k + 1). + LevelMap.MapsTo l k m -> cls ⊢ of_level_map m nem → (l, k + 1). Proof. intros tot cla mp l k hin hm. eapply entails_all_one; tea. @@ -5222,19 +5496,40 @@ Proof. - unshelve eapply (of_level_map_n_spec_inv _ V ne _ 0) in H. destruct H as [k' [hin [inv ninv]]]. destruct (inLevelSet V l) as [hvin|hnin]. - specialize (inv hvin). cbn in inv. subst k'. - now rewrite Nat2Z.id in hin. - specialize (ninv hnin). cbn in ninv. rewrite Nat2Z.id in ninv. now subst. + specialize (inv hvin). cbn in inv. now subst k'. + specialize (ninv hnin). cbn in ninv. now subst. - eapply of_level_map_n_spec in H as [k' [hm [hin hnin]]]. destruct (inLevelSet V l) as [hvin|hvnin]. now rewrite (hin hvin). now rewrite (hnin hvnin). Qed. +Lemma of_level_map_n_only_model m V n ne : + only_model_of V m -> + of_level_map_n m V n ne = add_prems n (of_level_map m ne). +Proof. + intros om. + apply eq_univ'. + intros [l k]. + rewrite In_add_prems. + split. + - move/of_level_map_n_spec => [k' [hm [hin hnin]]]. + destruct (inLevelSet V l) as [hvin|hvnin]. + * rewrite (hin hvin). exists (l, k'). + rewrite of_level_map_spec. split => //. rewrite /add_expr. lia_f_equal. + * elim hvnin. apply om. now exists k'. + - intros [[? ?] [hin heq]]. unfold add_expr in heq; noconf heq. + unshelve eapply of_level_map_spec in hin. + have inv : LevelSet.In l V. + { apply om. now exists n0. } + eapply (of_level_map_n_spec_inv _ V ne _ n) in hin as [k' [hin [hinv hninv]]]. + specialize (hinv inv). subst k'. now rewrite Nat.add_comm. +Qed. + Lemma entails_any V cls m nem m' nem' : - total_model_of V m -> + model_of V m -> cls ⊢a of_level_map m nem → of_level_map m' nem' -> - model_rel_partial Z.lt V m m' -> + model_rel_partial Nat.lt V m m' -> cls ⊢a of_level_map m nem → of_level_map_n m V 1 nem. Proof. intros tot cla mp [l k]. @@ -5249,13 +5544,13 @@ Proof. Qed. (* Lemma entails_any V cls m nem m' nem' : - total_model_of V m -> + model_of V m -> model_rel_partial Z.lt V m m' -> cls ⊢a of_level_map_n m V 1 nem → of_level_map_n m V 2 nem. Proof. *) Lemma strictly_updates_entails_on_V cls V mzero hne m : - total_model_of V mzero -> + model_of V mzero -> strictly_updates cls V mzero m -> entails_all (cls ↓ V) (of_level_map mzero hne) (of_level_map_n mzero V 1 hne). Proof. @@ -5268,7 +5563,7 @@ Proof. Qed. (* Lemma entails_concls cls V n m hne hne' : - total_model_of V m -> + model_of V m -> entails_all cls (of_level_map_n m V n hne) (of_level_set V n hne'). Proof. move=> tot [l k]. @@ -5293,7 +5588,7 @@ Lemma strictly_updates_entails_loop_relax cls V mzero hne m : let bound := v_minus_w_bound V m in let maxgain := max_gain cls in let n := Z.to_nat bound + maxgain in - total_model_of V mzero -> + model_of V mzero -> strictly_updates cls V mzero m -> entails_all cls (of_level_map_n mzero V n hne) (of_level_map_n mzero V (n + 1) hne). Proof. @@ -5313,7 +5608,7 @@ Lemma strictly_updates_entails_loop_relax' ocls cls V (hne : ~ LevelSet.Empty V) above_max_premise_model ocls mzero -> cls ⊂_clset ocls -> V =_lset clauses_levels cls -> - total_model_of V mzero -> + model_of V mzero -> strictly_updates cls V mzero m -> entails_all cls (of_level_set V (max_clause_premise cls) hne) (of_level_set V (max_clause_premise cls + 1) hne). @@ -5356,6 +5651,13 @@ Proof. split => //. cbn. f_equal; lia. Qed. +Lemma of_level_set_singleton l k hne : of_level_set (LevelSet.singleton l) k hne = singleton (l, k). +Proof. + apply: eq_univ'. move=> [l' k']. + rewrite /of_level_set //= levelexprset_of_levels_spec !LevelExprSet.singleton_spec LevelSet.singleton_spec /LevelSet.E.eq /LevelExprSet.E.eq. + firstorder subst => //. now noconf H. now noconf H. +Qed. + Lemma entails_of_level_set_strenghten cls W k' k prf : k' <= k -> cls ⊢a of_level_set W k' prf → of_level_set W (k' + 1) prf -> @@ -5370,7 +5672,7 @@ Qed. #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) - (prf : [/\ clauses_levels cls ⊂_lset V, total_model_of V minit & is_update_of cls U minit m]) : result V U cls minit + (prf : [/\ clauses_levels cls ⊂_lset V, only_model_of V minit & is_update_of cls U minit m]) : result V U cls minit by wf (loop_measure V U) lexprod_rel := loop V U cls minit m prf with inspect (check_model cls (U, m)) := | exist None eqm => Model U {| model_model := m |} _ @@ -5410,6 +5712,8 @@ Proof. { intros he. apply prf. rewrite eq. red in mof. intros a hin. apply mof in hin as [x hm]. now apply he in hm. } unshelve eapply strictly_updates_entails_on_V in eqm; tea. + rewrite of_level_map_n_only_model in eqm => //. + (* eapply entails_all_clauses_subset; tea. eapply entails_of_level_set_strenghten with (max_clause_premise cls). admit. *) eapply strictly_updates_entails_loop_above_max; tea. @@ -5467,7 +5771,7 @@ Proof. 2:{ eapply check_model_is_update_of in eqm as [eqm incl]; tea. eapply strictly_updates_is_update_of in eqm; tea. 2:apply mwc. - eapply strictly_updates_model_of_gen in eqm; tea. 2:eapply total_model_of_sub; tea. + eapply strictly_updates_model_of_gen in eqm; tea. 2:eapply model_of_sub; tea. eapply model_of_subset; tea. lsets. } 2:{ eapply is_update_of_total_model. apply mwc. } destruct eqm'' as [Hwc Hwcls H1 mext tot]. @@ -5506,7 +5810,7 @@ Proof. eapply strictly_updates_is_update_of in suinit; tea. rewrite union_idem in suinit. eapply model_of_strictly_updates; tea. * etransitivity; [eapply clauses_conclusions_levels|tea]. - * now eapply total_model_of_sub. + * now eapply model_of_sub. - eapply check_model_is_update_of in eqm as [suinit incl]; tea. rewrite union_idem in suinit. have hupd := model_updates mwc. eapply (is_update_of_weaken (cls' := cls)) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. @@ -5516,11 +5820,11 @@ Proof. - eapply check_model_is_update_of in eqm as [suinit incl]; tea. lsets. - move: isupd. rewrite /is_update_of. destruct LevelSet.is_empty. - * now intros ->; apply total_model_of_sub. + * now intros ->; apply model_of_sub. * intros su. eapply model_of_strictly_updates; tea. now apply clauses_levels_conclusions. - now apply total_model_of_sub. + now apply model_of_sub. - exact isupd. - apply clauses_levels_conclusions. assumption. - now eapply check_model_None in eqm. @@ -6177,7 +6481,7 @@ Proof. funelim (infer_model cls) => //. intros [= <-]. clear Heq Heqcall. destruct vm as [model ofV isupd clsconcl ism]; cbn in *. set (V := clauses_levels cls) in *. - assert (total_model_of V model). + assert (model_of V model). { intros l inl. eapply is_update_of_ext in isupd as mext. red in mext. (* eapply clauses_levels_spec in inl as [cl [hcl hin]]. *) unfold init_model in mext. From 02f130792b21daaf07966fb08718e2e28e83b412 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 28 Aug 2025 01:11:11 +0200 Subject: [PATCH 022/164] Completely readapted to nat model --- template-rocq/theories/PartialLoopChecking.v | 429 ++++++++----------- 1 file changed, 180 insertions(+), 249 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index f1829032e..03a70b861 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -2347,49 +2347,6 @@ Proof. eapply level_value_above_MapsTo'; tea. lia. Qed. -(* Lemma strict_update_ext_right m cl m' m'' : strict_update m cl m' -> m' ⩽ m'' -> strict_update m cl m''. -Proof. - destruct cl as [prems [concl k]]. unfold strict_update. - intros [minp [eqminp [ha hna]]] leq. - exists minp. split => //. split => //. - eapply level_value_above_mon; tea. -Qed. *) - -Definition enabled_clause (m : model) (cl : clause) := - isSome (min_premise m (premise cl)). - -Definition enabled_clauses (m : model) (cls : clauses) := - Clauses.for_all (enabled_clause m) cls. - -(* Lemma strict_update_ext_left m cl m' m'' : strict_update m cl m ⩽ m' -> strict_update m' cl m'' -> strict_update m cl m''. -Proof. - destruct cl as [prems [concl k]]. unfold strict_update. - intros leq [minp [eqminp [ha hna]]]. - exists minp. split => //. split => //. - eapply level_value_above_mon; tea. -Qed. - *) - -(* Lemma strict_update_outside w m m' m'' cl : - m ⩽ m' -> m' ⩽ m'' -> - model_map_outside w m m' -> - enabled_clause m cl -> - ~ LevelSet.In (clause_conclusion cl) w -> strict_update m' cl m'' -> strict_update m cl m''. -Proof. - intros mext mext' wout enabled nout. - apply wout in nout. - destruct cl as [prems [concl k]]. - unfold strict_update. - intros [v [minv ]]. - cbn in nout. - unfold enabled_clause in enabled. cbn in enabled. destruct min_premise eqn:hmin => //. - - exists z; split=> //. - split => //. - have hp := (min_premise_pres prems mext). rewrite hmin minv in hp. depelim hp. - (* 2:{ eapply level_value_above_mon; tea. eapply level_value_above_MapsTo'; tea. rewrite -nout. } *) - Abort. *) - Lemma model_of_subset V V' m : model_of V m -> V' ⊂_lset V -> model_of V' m. Proof. @@ -3193,8 +3150,9 @@ Qed. *) Lemma loop_on_subset {cls cls' u} : Clauses.Subset cls cls' -> loop_on_univ cls u -> loop_on_univ cls' u. Proof. - -Admitted. + intros sub; rewrite /loop_on_univ => hyp. + now eapply entails_all_clauses_subset. +Qed. Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := | Loop (v : univ) (islooping : loop_on_univ cls v) @@ -3206,7 +3164,7 @@ Arguments lexprod {A B}. Definition option_of_result {V U m cls} (r : result V U m cls) : option model := match r with | Model w m _ => Some m.(model_model) - | Loop w hne _ isloop => None + | Loop v _ => None end. Notation "#| V |" := (LevelSet.cardinal V). @@ -4566,14 +4524,14 @@ Section InnerLoop. by wf (measure W cls m) lt := inner_loop_partition m upd with loop W LevelSet.empty premconclW (restrict_model W m) (restrict_model W m) _ _ := { (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) - | Loop W ne n isl => Loop W ne n (loop_on_subset _ isl) + | Loop u isl => Loop u (loop_on_subset _ isl) (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). By invariant Wr ⊂ W *) | Model Wr mr empWr with inspect (check_model conclW (Wr, model_update m (model_model mr))) := { | exist None eqm => Model Wr {| model_model := model_update m (model_model mr) |} _ | exist (Some (Wconcl, mconcl)) eqm with inner_loop_partition mconcl _ := { (* Here Wr ⊂ Wconcl by invariant *) - | Loop W ne n isl => Loop W ne n isl + | Loop u isl => Loop u isl | Model Wr' mr' UWconcl => Model (LevelSet.union Wconcl Wr') {| model_model := model_model mr' |} _ } (* Here Wr' ⊂ W by invariant *) (* We check if the new model [mr] for (cls ⇂ W) extends to a model of (cls ↓ W). *) @@ -4808,25 +4766,20 @@ Definition model_min m := Definition model_max m := LevelMap.fold (fun l k acc => Nat.max acc k) m 0%nat. -(* Lemma model_max_spec m : forall l k, LevelMap.MapsTo l k m -> (k ≤ Some (model_max m))%Z. *) -(* Proof. Admitted. *) +Lemma model_max_spec m : forall l k, LevelMap.MapsTo l k m -> (k <= model_max m)%nat. +Proof. Admitted. Definition valuation_of_model (m : model) : LevelMap.t nat := - let min := model_min m in let max := model_max m in - LevelMap.fold (fun l k acc => LevelMap.add l (max - k - min)%nat acc) m (LevelMap.empty _). + LevelMap.fold (fun l k acc => LevelMap.add l (max - k)%nat acc) m (LevelMap.empty _). Close Scope Z_scope. Lemma valuation_of_model_spec m : forall l k, LevelMap.MapsTo l k m -> - let v := (model_max m - k - model_min m)%nat in + let v := (model_max m - k )%nat in LevelMap.MapsTo l v (valuation_of_model m). Proof. Admitted. - -Definition correct_model (cls : clauses) (m : model) := - enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. - Lemma strictly_updates_valid_model {W W' m m' cls} : is_model (cls ↓ W) m -> strictly_updates cls W' m m' -> @@ -5670,6 +5623,46 @@ Proof. now have -> : k - k' + (k' + 1) = k + 1 by lia. Qed. +Lemma strictly_updates_non_empty_init_map {cls W m m'} : + strictly_updates cls W m m' -> ~ LevelMap.Empty m. +Proof. + induction 1. + - destruct cl as [prems [concl k]]. + destruct H0 as [? [? ? ? heq]]. + eapply min_premise_spec_aux in H0 as [_ [[] [inprems heq']]]. + unfold min_atom_value in heq'. + destruct level_value eqn:hl => //. apply level_value_MapsTo' in hl. + now intros e; apply e in hl. + - auto. +Qed. + +Lemma check_model_ne_init_map {cls V U minit m W m'} : + [/\ clauses_levels cls ⊂_lset V, only_model_of V minit & is_update_of cls U minit m] -> + check_model cls (U, m) = Some (W, m') -> + ~ LevelMap.Empty minit. +Proof. + intros [_ _ isupd] check. + eapply check_model_is_update_of in check as [su incl]; tea. + rewrite union_idem in su. + now eapply strictly_updates_non_empty_init_map in su. +Qed. + +Lemma check_model_ne_map {cls U m W m'} : + check_model cls (U, m) = Some (W, m') -> + ~ LevelMap.Empty m'. +Proof. + intros check. + eapply check_model_spec in check as [W' [su incl]]; tea. + now eapply strictly_updates_non_empty_map in su. +Qed. + +Lemma only_model_of_model_of {V m} : only_model_of V m -> model_of V m. +Proof. + intros om l. move/om. intros [k hm]; now exists k. +Qed. + +Coercion only_model_of_model_of : only_model_of >-> model_of. + #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) (prf : [/\ clauses_levels cls ⊂_lset V, only_model_of V minit & is_update_of cls U minit m]) : result V U cls minit @@ -5677,23 +5670,23 @@ Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : mod loop V U cls minit m prf with inspect (check_model cls (U, m)) := | exist None eqm => Model U {| model_model := m |} _ | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { - | exist true eq := Loop W (check_model_ne eqm) (max_clause_premise cls) _ + | exist true eq := Loop (of_level_map minit (check_model_ne_init_map prf eqm)) _ (* Loop on cls ↓ W, with |W| < |V| *) | exist false neq with inner_loop V U minit loop W (cls ↓ W) m' _ := - { | Loop W' ne n isloop := Loop W' ne n (loop_on_subset _ isloop) + { | Loop u isloop := Loop u (loop_on_subset _ isloop) | Model Wc mwc _ (* We get a model for (cls ↓ W), we check if it extends to all clauses. By invariant |Wc| cannot be larger than |W|. *) with inspect (check_model cls (Wc, mwc.(model_model))) := { | exist None eqm' => Model (LevelSet.union W Wc) {| model_model := mwc.(model_model) |} _ | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { - | exist true _ := Loop Wcls (check_model_ne eqm') (max_clause_premise cls) _ + | exist true _ := Loop (of_level_map m' (check_model_ne_map eqm)) _ | exist false neq' with loop V (LevelSet.union W Wcls) cls minit mcls _ := { (* Here Wcls < V, we've found a model for all of the clauses with conclusion in W, which can now be fixed. We concentrate on the clauses whose conclusion is different. Clearly |W| < |V|, but |Wcls| is not necessarily < |V| *) - | Loop W' ne n isloop := Loop W' ne n isloop + | Loop u isloop := Loop u isloop | Model Wvw mcls' hsub := Model Wvw {| model_model := model_model mcls' |} _ } } } } } @@ -5705,59 +5698,38 @@ Proof. all:have cls_sub := clauses_conclusions_levels cls. all:destruct prf as [clsV mof isupd]. - red. eapply LevelSet.equal_spec in eq. - set (prf := check_model_ne eqm); clearbody prf. + set (prf := check_model_ne_init_map _ _); clearbody prf. eapply check_model_is_update_of in eqm; tea. rewrite eq in eqm. destruct eqm as [eqm incl]. rewrite union_idem in eqm. - have nem : ~ LevelMap.Empty minit. - { intros he. apply prf. rewrite eq. red in mof. intros a hin. apply mof in hin as [x hm]. - now apply he in hm. } unshelve eapply strictly_updates_entails_on_V in eqm; tea. rewrite of_level_map_n_only_model in eqm => //. - - (* eapply entails_all_clauses_subset; tea. - eapply entails_of_level_set_strenghten with (max_clause_premise cls). admit. *) - eapply strictly_updates_entails_loop_above_max; tea. - apply LevelSet.eq_leibniz in eq. subst W. - rewrite eq. - eapply strictly_updates_entails_loop2. - + rewrite eq. intros x. eapply strictly_updates_incl in eqm. - split. 2:apply clsV. - now move/eqm/clauses_conclusions_levels. - + now rewrite eq. - + now rewrite eq. + eapply entails_all_clauses_subset; tea. apply clauses_with_concl_subset. exact mof. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hi := strictly_updates_incl eqm. rewrite union_idem in hi, eqm. - (* apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. *) split => //. * split => //. lsets. * now eapply strictly_updates_non_empty. - (* * transitivity cls => //. apply clauses_with_concl_subset. *) * apply clauses_conclusions_clauses_with_concl. * eapply strictly_updates_strenghten. exact eqm. - (* * eapply above_max_premise_model_strengthen; tea. 2: eapply clauses_with_concl_subset. - eapply clauses_levels_mon. - * now eapply strictly_updates_strenghten. *) - now intros ?; rewrite in_clauses_with_concl. - - set (ne := check_model_ne eqm'). clearbody ne. + - set (ne := check_model_ne_map _). clearbody ne. have hu := model_updates mwc. + eapply check_model_is_update_of in eqm as [eqm incl]; tea. + have om : only_model_of V m'. + { rewrite union_idem in eqm. + have incl' := strictly_updates_incl eqm. + have hcl := clauses_conclusions_levels cls. + eapply strictly_updates_only_model_gen in eqm; tea. eapply only_model_of_eq; tea. intro; lsets. } + eapply strictly_updates_is_update_of in eqm; tea. + rewrite union_idem union_with_concl in eqm. eapply check_model_is_update_of in eqm' as [eqm' incl']; tea. rewrite ClausesProp.union_sym union_with_concl in eqm'. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. - rewrite union_idem in eqm. - have tr := update_trans _ eqm eqm'. eapply LevelSet.equal_spec in e. rewrite e in tr. - assert (hun : LevelSet.union W V =_lset V). eapply strictly_updates_incl in eqm. lsets. - rewrite hun in tr. symmetry in e. - set (n := Z.to_nat _ + _). - have [neV hl] := loop_on_proper _ _ n ne cls e. apply hl. - have vm := model_ok mwc. - apply todo. - (* eapply strictly_updates_entails_loop with minit mcls; tea. - + apply todo. (* minit is a max premise model *) - + split. 2:apply clsV. intros hinV. - eapply strictly_updates_incl in tr. apply tr in hinV. - now apply clauses_conclusions_levels. *) + eapply (strictly_updates_entails_on_V _ _ _ ne) in eqm'. red. + rewrite of_level_map_n_only_model in eqm'. eapply LevelSet.equal_spec in e. now rewrite e. + eapply entails_all_clauses_subset; tea. + eapply clauses_with_concl_subset. apply LevelSet.equal_spec in e. rewrite e. exact om. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hu := model_updates mwc. eapply strictly_updates_is_update_of in hu; tea. @@ -5769,9 +5741,9 @@ Proof. - right. eapply check_model_spec_V in eqm' as eqm''. 3:etransitivity; [apply clauses_conclusions_levels|exact clsV]. cbn in eqm''. 2:{ - eapply check_model_is_update_of in eqm as [eqm incl]; tea. + eapply check_model_is_update_of in eqm as [eqm incl]; tea. rewrite union_idem in eqm. eapply strictly_updates_is_update_of in eqm; tea. 2:apply mwc. - eapply strictly_updates_model_of_gen in eqm; tea. 2:eapply model_of_sub; tea. + eapply strictly_updates_model_of_gen in eqm; tea. 2:exact mof. eapply model_of_subset; tea. lsets. } 2:{ eapply is_update_of_total_model. apply mwc. } destruct eqm'' as [Hwc Hwcls H1 mext tot]. @@ -5808,9 +5780,7 @@ Proof. have hupd := model_updates mwc. eapply (is_update_of_weaken (cls' := cls)) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. eapply strictly_updates_is_update_of in suinit; tea. rewrite union_idem in suinit. - eapply model_of_strictly_updates; tea. - * etransitivity; [eapply clauses_conclusions_levels|tea]. - * now eapply model_of_sub. + eapply model_of_strictly_updates; tea. exact mof. - eapply check_model_is_update_of in eqm as [suinit incl]; tea. rewrite union_idem in suinit. have hupd := model_updates mwc. eapply (is_update_of_weaken (cls' := cls)) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. @@ -5820,11 +5790,9 @@ Proof. - eapply check_model_is_update_of in eqm as [suinit incl]; tea. lsets. - move: isupd. rewrite /is_update_of. destruct LevelSet.is_empty. - * now intros ->; apply model_of_sub. + * intros <-. exact mof. * intros su. - eapply model_of_strictly_updates; tea. - now apply clauses_levels_conclusions. - now apply model_of_sub. + eapply model_of_strictly_updates; tea. exact mof. - exact isupd. - apply clauses_levels_conclusions. assumption. - now eapply check_model_None in eqm. @@ -5833,9 +5801,6 @@ Qed. Transparent lexprod_rel_wf. -Definition zero_model levels := - LevelSet.fold (fun l acc => LevelMap.add l (Some 0%Z) acc) levels (LevelMap.empty _). - (* To handle the constraint inference problem, we must start with a model where all atoms [l + k] appearing in premises are true. Otherwise the @@ -5847,48 +5812,45 @@ Definition zero_model levels := Definition add_max l k m := match LevelMap.find l m with - | Some (Some k') => - if (k' + if (k' LevelMap.add l (Some k) m + | _ => LevelMap.add l k m end. -Definition min_model_map (m : LevelMap.t (option Z)) cls : LevelMap.t (option Z) := +Definition min_model_map (m : model) cls : model := Clauses.fold (fun '(cl, concl) acc => LevelExprSet.fold (fun '(l, k) acc => - add_max l (Z.of_nat k) acc) cl (add_max (levelexpr_level concl) 0%Z acc)) cls m. + add_max l k acc) cl (add_max (levelexpr_level concl) 0 acc)) cls m. Lemma In_add_max l l' k acc : - LevelMap.In (elt:=option Z) l (add_max l' k acc) <-> + LevelMap.In (elt:=nat) l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). Proof. unfold add_max. destruct LevelMap.find eqn:hl. - destruct o. - { case: Z.ltb_spec. - - rewrite LevelMapFact.F.add_in_iff /Level.eq. - firstorder eauto. - - intros. intuition auto. subst. - now rewrite LevelMapFact.F.in_find_iff hl. } - { LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. } - { LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. } + - case: Nat.ltb_spec. + + rewrite LevelMapFact.F.add_in_iff /Level.eq. + firstorder eauto. + + intros. intuition auto. subst. + now rewrite LevelMapFact.F.in_find_iff hl. + - LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. Qed. Definition is_max k' k l acc := match LevelMap.find l acc with - | Some (Some k'') => k' = Some (Z.max k k'') - | _ => k' = Some k + | Some k'' => k' = Nat.max k k'' + | _ => k' = k end. Lemma MapsTo_add_max l l' k k' acc : - LevelMap.MapsTo (elt:=option Z) l k' (add_max l' k acc) <-> + LevelMap.MapsTo (elt:=nat) l k' (add_max l' k acc) <-> if eqb l l' then is_max k' k l acc else LevelMap.MapsTo l k' acc. Proof. unfold add_max. destruct LevelMap.find eqn:hl. - destruct o. - { case: Z.ltb_spec. + { case: Nat.ltb_spec. - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. destruct (eqb_spec l l'). { unfold is_max. @@ -5905,12 +5867,6 @@ Proof. destruct (eqb_spec l l'); subst. unfold is_max. now rewrite hl. congruence. destruct (eqb_spec l l'); subst. unfold is_max in H; rewrite hl in H. subst k'. left; intuition eauto. reflexivity. right. intuition eauto. - - rewrite LevelMapFact.F.add_mapsto_iff. intuition auto; subst. - destruct (eqb_spec l l'); subst. unfold is_max. now rewrite hl. congruence. - destruct (eqb_spec l l'); subst. unfold is_max. now rewrite hl. congruence. - destruct (eqb_spec l l'); subst. unfold is_max in H. rewrite hl in H; subst. - left; intuition auto. reflexivity. - right. intuition auto. Qed. Definition opt_max (x y : option nat) : option nat := @@ -5958,56 +5914,20 @@ Proof. Qed. Definition update_max acc l k0 := - option_map2 Z.max (level_value acc l) (Some (Z.of_nat k0)). + option_map2 Nat.max (level_value acc l) (Some k0). (* Lemma update_max_spec acc l k : update_max acc l k0 = *) -Definition add_max_list l acc := - List.fold_right (fun '(l, k0) acc => - LevelMap.add l (update_max acc l k0) acc) acc l. - Definition maximal_pre (l : Level.t) (n : nat) les := forall n', In (l, n') les -> n' <= n. Definition maximal_map (l : Level.t) (n : nat) m := forall n', LevelMap.MapsTo l (Some n') m -> (n' <= Z.of_nat n)%Z. -(* -Lemma In_fold_add_max l k les a : - let map := add_max_list les a in - LevelMap.MapsTo (elt:=option Z) l k map <-> - ((exists kl, In (l, kl) les /\ Some (Z.of_nat kl) = k - /\ maximal_pre l kl les /\ maximal_map l kl a) \/ - (LevelMap.MapsTo l k a /\ (match k with Some k' => maximal_pre l (Z.to_nat k') les | None => True end))). -Proof. - cbn; intros. - unfold add_max_list. - induction les in a |- *. - - cbn. admit. - - cbn. destruct a0. - rewrite LevelMapFact.F.add_mapsto_iff. intuition auto. - { red in H; subst k0. } - - -Lemma In_fold_add_max l k les a : - let map := add_max_list les a in - LevelMap.MapsTo (elt:=option Z) l k map <-> - ((exists kl, In (l, kl) les /\ Some (Z.of_nat kl) = k - /\ maximal_pre l kl les /\ maximal_map l kl a) \/ - (LevelMap.MapsTo l k a /\ (match k with Some k' => maximal_pre l (Z.to_nat k') les | None => True end))). -Proof. - cbn. unfold add_max_list. - induction les in a |- *; cbn. admit. - cbn. destruct a0. - rewrite MapsTo_add_max. - destruct (eqb_spec l k0). subst. - - -*) Lemma In_fold_add_max k n a : - LevelMap.In (elt:=option Z) k + LevelMap.In (elt:=nat) k (LevelExprSet.fold - (fun '(l, k0) acc => add_max l (Z.of_nat k0) acc) n a) <-> + (fun '(l, k0) acc => add_max l k0 acc) n a) <-> (LevelSet.In k (levels n)) \/ LevelMap.In k a. Proof. eapply LevelExprSetProp.fold_rec. @@ -6030,12 +5950,12 @@ Qed. Lemma MapsTo_fold_add_max l n a : - let map := LevelExprSet.fold (fun '(l, k0) acc => add_max l (Z.of_nat k0) acc) n a in - (forall k, LevelMap.MapsTo (elt:=option Z) l k map -> - ((exists kl, LevelExprSet.In (l, kl) n /\ Some (Z.of_nat kl) = k /\ + let map := LevelExprSet.fold (fun '(l, k0) acc => add_max l k0 acc) n a in + (forall k, LevelMap.MapsTo (elt:=nat) l k map -> + ((exists kl, LevelExprSet.In (l, kl) n /\ kl = k /\ (forall kl', LevelExprSet.In (l, kl') n -> kl' <= kl) /\ - (forall kl', LevelMap.MapsTo l kl' a -> kl' ≤ Some (Z.of_nat kl))) \/ - (LevelMap.MapsTo l k a /\ (forall kl', LevelExprSet.In (l, kl') n -> Some (Z.of_nat kl') ≤ k)))) + (forall kl', LevelMap.MapsTo l kl' a -> kl' <= kl)) \/ + (LevelMap.MapsTo l k a /\ (forall kl', LevelExprSet.In (l, kl') n -> kl' <= k)))) /\ (forall l, ~ LevelMap.In l map -> ~ (exists k, LevelExprSet.In (l, k) n) /\ ~ (LevelMap.In l a)). Proof. eapply LevelExprSetProp.fold_rec. @@ -6058,40 +5978,33 @@ Proof. destruct (eqb_spec l xl); subst. * unfold is_max in H3 at 1. destruct LevelMap.find eqn:hfind. - { destruct o. - - subst k. pose proof (LevelMap.find_2 hfind). destruct H2 as [H2 Hnotin]. destruct (H2 _ H3). - left. destruct H4 as [kl [hkl hleq]]. destruct hleq as [hleq hmax]. - noconf hleq. destruct (Z.max_spec (Z.of_nat k') (Z.of_nat kl)) as [[]|[]]. + { subst k. pose proof (LevelMap.find_2 hfind). destruct H2 as [H2 Hnotin]. destruct (H2 _ H3). + left. destruct H4 as [kl [hkl hleq]]. destruct hleq as [hleq hmax]. subst n0. + destruct (Nat.max_spec k' kl) as [[]|[]]. { exists kl. split. apply H1. now right. split. f_equal. lia. split. intros. - apply H1 in H6 as []. noconf H6. lia. now apply hmax. destruct hmax as [_ hmax]. + apply H1 in H6 as []. noconf H6. lia. now apply (proj1 hmax). destruct hmax as [_ hmax]. intros. now apply hmax. } { exists k'. split. apply H1. now left. split. f_equal; lia. destruct hmax as [hmax hmax']; split. intros kl' hin. apply H1 in hin as []; subst. noconf H6. lia. specialize (hmax _ H6). lia. - intros. transitivity (Some (Z.of_nat kl)). now apply hmax'. constructor; lia. } + intros. transitivity kl. now apply hmax'. lia. } destruct (H2 _ H3) as [[kl [hkl hleq]]|]. noconf hleq. - destruct hleq as [hleq hmax]. noconf hleq. - destruct (Z.max_spec (Z.of_nat k') (Z.of_nat kl)) as [[]|[]]. + destruct hleq as [hleq hmax]. subst n0. + destruct (Nat.max_spec k' kl) as [[]|[]]. { left. exists kl. split. apply H1. now right. destruct hmax as [hmax hmax']. split. f_equal. lia. split. intros. apply H1 in H7 as []. noconf H7. lia. now apply hmax. apply hmax'. } { left. exists k'. split. apply H1. now left. destruct hmax as [hmax hmax']. split. f_equal. lia. split. intros kl' hin. apply H1 in hin as []. noconf H7. lia. specialize (hmax _ H7). lia. - intros. transitivity (Some (Z.of_nat kl)) => //. 2:constructor; lia. now eapply hmax'. } + intros. transitivity kl => //. now eapply hmax'. } destruct H4. clear H5. - destruct (Z.max_spec (Z.of_nat k') z) as [[]|[]]. + destruct (Nat.max_spec k' n0) as [[]|[]]. { right. split. now rewrite H7. - intros kl' hin. apply H1 in hin as [hin|hin]; noconf hin. constructor; lia. - specialize (H6 _ hin). depelim H6; constructor; lia. } + intros kl' hin. apply H1 in hin as [hin|hin]; noconf hin. lia. + specialize (H6 _ hin). depelim H6; lia. } { left. exists k'. split. apply H1. now left. split. f_equal. lia. split. intros kl' hin. apply H1 in hin as []. noconf H8. lia. - specialize (H6 _ H8). depelim H6. lia. - intros. transitivity (Some z). 2:constructor; lia. eapply (LevelMapFact.F.MapsTo_fun H4) in H8. subst kl'. reflexivity. } - - eapply LevelMap.find_2 in hfind. destruct H2 as [H2 hnotin]. specialize (H2 _ hfind) as []. - subst k. destruct H2 as [kl [? []]]. congruence. - destruct H2. subst k. - left. exists k'. split; eauto. firstorder. split; eauto. split. - { intros. eapply H1 in H3 as [hin|hin]; noconf hin. lia. - specialize (H4 _ hin). depelim H4. } - { intros kl' hin. apply (LevelMapFact.F.MapsTo_fun H2) in hin. subst; constructor. } } + specialize (H6 _ H8). lia. + intros. transitivity n0. 2: lia. eapply (LevelMapFact.F.MapsTo_fun H4) in H8. subst kl'. reflexivity. } + } subst k. left. exists k'. split; eauto. firstorder. split. reflexivity. destruct H2 as [hl hnotin]. eapply LevelMapFact.F.not_find_in_iff in hfind. apply hnotin in hfind as hfind'. @@ -6142,11 +6055,11 @@ Definition maximal_prem l n cls := Lemma min_model_mapsto_gen m cls : forall l, LevelSet.In l (clauses_levels cls) -> - exists k, LevelMap.MapsTo l (Some k) (min_model_map m cls) /\ + exists k, LevelMap.MapsTo l k (min_model_map m cls) /\ (exists cl, Clauses.In cl cls /\ - exists n, k = Z.of_nat n /\ LevelExprSet.In (l,n) (premise cl) /\ + exists n, k = n /\ LevelExprSet.In (l,n) (premise cl) /\ (* (forall cl', Clauses.In cl cls -> forall l k, LevelExprSet.In (l, k) (premise cl') -> k <= n) *) - maximal_prem l n cls) \/ LevelMap.MapsTo l (Some k) m. + maximal_prem l n cls) \/ LevelMap.MapsTo l k m. Proof. rewrite /min_model_map. eapply ClausesProp.fold_rec. @@ -6185,9 +6098,9 @@ Qed. *) Lemma min_model_mapsto cls : forall l, LevelSet.In l (clauses_levels cls) -> - exists k, LevelMap.MapsTo l (Some k) (min_model_map (LevelMap.empty _) cls) /\ + exists k, LevelMap.MapsTo l k (min_model_map (LevelMap.empty _) cls) /\ (exists cl, Clauses.In cl cls /\ - exists n, k = Z.of_nat n /\ LevelExprSet.In (l,n) (premise cl) /\ + exists n, k = n /\ LevelExprSet.In (l,n) (premise cl) /\ (* (forall cl', Clauses.In cl cls -> forall l k, LevelExprSet.In (l, k) (premise cl') -> k <= n) *) maximal_prem l n cls). Proof. @@ -6220,8 +6133,8 @@ Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). Equations? infer (cls : clauses) : infer_result (clauses_levels cls) cls := infer cls := loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (init_model cls) (And3 _ _ _). Proof. - - now eapply clauses_conclusions_levels. - - red. now eapply init_model_levels. + - reflexivity. + - intros k. now rewrite -init_model_levels. - apply is_update_of_empty. Qed. @@ -6252,15 +6165,15 @@ Definition print_level_Z_map (m : LevelMap.t (option Z)) := Definition print_result {V cls} (m : infer_result V cls) := match m return string with - | Loop _ _ _ => "looping" - | Model w m _ => "satisfiable with model: " ^ print_level_Z_map m.(model_model) ^ nl ^ " W = " ^ + | Loop _ _ => "looping on " + | Model w m _ => "satisfiable with model: " ^ print_level_nat_map m.(model_model) ^ nl ^ " W = " ^ print_lset w ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model m.(model_model)) end. Definition valuation_of_result {V cls} (m : infer_result V cls) := match m with - | Loop _ _ _ => "looping" + | Loop _ _ => "looping" | Model w m _ => print_level_nat_map (valuation_of_model m.(model_model)) end. @@ -6281,15 +6194,14 @@ Definition print_clauses (cls : clauses) := print_premise l ^ " → " ^ to_string_expr r) nl list. Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) - (prf : clauses_conclusions cls ⊂_lset V /\ clauses_conclusions cls' ⊂_lset V /\ model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := + (prf : clauses_levels cls ⊂_lset V /\ clauses_levels cls' ⊂_lset V /\ only_model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m m _. Proof. split. - intros x. rewrite clauses_conclusions_spec. - intros [cl [hcl hl]]. - rewrite Clauses.union_spec in hcl. destruct hcl. - - apply H, clauses_conclusions_spec. exists cl => //. - - apply H0, clauses_conclusions_spec. exists cl => //. + - intros x. rewrite clauses_levels_spec. + move=> [] cl. rewrite Clauses.union_spec. + intros [[] incls]. apply H. apply clauses_levels_spec. exists cl. split => //. + apply H0. apply clauses_levels_spec. exists cl; split => //. - exact H1. - eapply is_update_of_empty. Qed. @@ -6298,13 +6210,13 @@ Qed. setting a minimal value for the new atoms in [clauses_levels cls \ V] such that the new clauses [cls] do not hold vacuously. *) -Equations? infer_extension {V W init cls} (m : valid_model V W init cls) (cls' : clauses) : +(* Equations? infer_extension {V W init cls} (m : valid_model V W init cls) (cls' : clauses) : result (LevelSet.union (clauses_levels cls') V) LevelSet.empty (Clauses.union cls cls') (min_model m.(model_model) cls') := infer_extension m cls' := infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model m.(model_model) cls') cls cls' _. Proof. repeat split. - - pose proof (model_clauses_conclusions m). lsets. + - pose proof (model_clauses_conclusions m). intros x. lsets. - pose proof (clauses_conclusions_levels cls'). lsets. - red. intros. unfold min_model. rewrite min_model_map_levels. @@ -6317,9 +6229,9 @@ Definition enforce_clauses {V W init cls} (m : valid_model V W init cls) cls' : | Loop _ _ _ => None | Model w m _ => Some m.(model_model) end. - -Definition enforce_clause {V W init cls} (m : valid_model V W init cls) cl : option model := - enforce_clauses m (Clauses.singleton cl). +*) +(* Definition enforce_clause {V W init cls} (m : valid_model V W init cls) cl : option model := + enforce_clauses m (Clauses.singleton cl). *) Inductive constraint_type := UnivEq | UnivLe. @@ -6343,10 +6255,10 @@ Definition clauses_of_list := ClausesProp.of_list. Definition list_of_clauses := Clauses.elements. Definition valuation := LevelMap.t nat. -Definition premises_model_map (m : LevelMap.t (option Z)) cls : LevelMap.t (option Z) := +Definition premises_model_map (m : model) cls : model := Clauses.fold (fun '(cl, concl) acc => LevelExprSet.fold (fun '(l, k) acc => - add_max l (Z.of_nat k) acc) cl acc) cls m. + add_max l k acc) cl acc) cls m. Lemma premises_model_map_levels m cls k : @@ -6377,45 +6289,53 @@ Variant checking_result (cls : clauses) (cl : clause) : Type := | DoesNotHold : ~ entails cls cl -> checking_result cls cl | Entails : entails cls cl -> checking_result cls cl. -Definition undefined_model levels : LevelMap.t (option Z) := - LevelSet.fold (fun elt acc => LevelMap.add elt None acc) levels (LevelMap.empty _). +Definition zero_model levels : model := + LevelSet.fold (fun l acc => LevelMap.add l 0 acc) levels (LevelMap.empty _). Definition premises_model V cl : LevelSet.t * model := let levels := LevelSet.union (clause_levels cl) V in - (levels, premises_model_map (undefined_model levels) (Clauses.singleton cl)). + (levels, premises_model_map (zero_model levels) (Clauses.singleton cl)). Program Definition loop_check {V init cls} (m : valid_model V V init cls) (cl : clause) : result (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 := loop (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 (premises_model V cl).2 _. Next Obligation. destruct m. split => //. - - lsets. + - apply todo. - apply todo. - apply is_update_of_empty. Qed. Equations check {V init cls} (m : valid_model V V init cls) (cl : clause) : bool := check m cl with loop_check m cl := - | Loop _ _ _ => false (* Actually impossible *) + | Loop _ _ => false (* Actually impossible *) | Model W v _ => let '(concl, k) := concl cl in match LevelMap.find concl v.(model_model) with - | Some None => false - | Some (Some v) => (Z.of_nat k <=? v)%Z + | Some v => (k <=? v) | None => false end. Equations? infer_model (cls : clauses) : option model := infer_model cls with loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (init_model cls) _ := - | Loop _ _ _ => None + | Loop _ _ => None | Model w vm heq => Some vm.(model_model). Proof. split. - - apply clauses_conclusions_levels. + - reflexivity. - apply infer_obligation_2. - apply is_update_of_empty. Qed. +Definition enabled_clause (m : model) (cl : clause) := + exists z, min_premise m (premise cl) = Some z /\ (0 <= z)%Z. + +Definition enabled_clauses (m : model) (cls : clauses) := + Clauses.For_all (enabled_clause m) cls. + +Definition correct_model (cls : clauses) (m : model) := + enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. + Definition infer_correctness cls := forall m, infer_model cls = Some m -> correct_model cls m. Lemma enabled_clauses_ext m m' cls : m ⩽ m' -> enabled_clauses m cls -> enabled_clauses m' cls. @@ -6447,17 +6367,18 @@ Lemma valid_clause_model model cl : clause_sem (valuation_of_model model) cl. Proof. unfold enabled_clause, valid_clause. - destruct min_premise eqn:hmin => //= _. + destruct min_premise eqn:hmin => //= => //. + 2:{ intros [k' []]. congruence. } + intros [k' [eq ge0]]. noconf eq. destruct cl as [prems [concl k]]; cbn. unfold level_value_above. + elim: Z.ltb_spec => //= hz hrel. lia. cbn. destruct level_value eqn:hl => //. - move/Z.leb_le. - intros hrel. - unfold interp_level. unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. subst o. + unfold interp_level. unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. eapply LevelMap.find_2 in hfind. have conclm := valuation_of_model_spec _ _ _ hfind. - set (v := (model_max _ - _ - _)%Z) in *. - cbn in conclm. destruct conclm as [vpos conclm]. + set (v := (model_max _ - _)) in *. + cbn in conclm. eapply LevelMap.find_1 in conclm. rewrite conclm. subst v. pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. @@ -6467,12 +6388,18 @@ Proof. symmetry in premeq. move: premeq. unfold min_atom_value. unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. - destruct o => //. intros [= <-]. + intros [= <-]. eapply LevelMap.find_2 in findp. have premm := valuation_of_model_spec _ _ _ findp. unfold interp_level. - destruct premm as [vppos vpmap]. - eapply LevelMap.find_1 in vpmap. rewrite vpmap. lia. + (* destruct premm as [vppos vpmap]. *) + eapply LevelMap.find_1 in premm. rewrite premm. + apply Nat.leb_le in hrel. + assert (Z.to_nat (Z.of_nat n0 - Z.of_nat k') = n0 - k'). lia. rewrite H in hrel. + assert (n0 - k' <= n - k). lia. + have hm : n <= model_max model. eapply model_max_spec; tea. + have hm' : n0 <= model_max model. eapply model_max_spec; tea. + lia. Qed. Lemma infer_correct cls : infer_correctness cls. @@ -6487,11 +6414,11 @@ Proof. unfold init_model in mext. have [kmin [hm incl]] := min_model_mapsto cls l inl. eapply mext in hm as [kmodel [mapmodel hmodel]]. - depelim hmodel. now exists y. } + now exists kmodel. } unfold correct_model. have encl : enabled_clauses model cls. { eapply enabled_clauses_ext. apply is_update_of_ext in isupd. exact isupd. - unfold enabled_clauses. eapply Clauses.for_all_spec. tc. + unfold enabled_clauses. intros x hin. unfold enabled_clause. pose proof (@min_premise_spec (init_model cls) (premise x)) as [premmin [prem [premin premeq]]]. have inV : LevelSet.In prem (clauses_levels cls). @@ -6501,11 +6428,13 @@ Proof. have [kmin [hm incl]] := min_model_mapsto cls prem inV. unfold init_model. rewrite premeq. unfold min_atom_value. destruct prem as [l k]. - eapply LevelMap.find_1 in hm. unfold level_value. now rewrite hm. } + eapply LevelMap.find_1 in hm. unfold level_value. rewrite hm. eexists; split; eauto. + destruct incl as [cl [hin' [n [heq' [hin'' maxp]]]]]. subst n. red in maxp. + eapply maxp in hin. eapply hin in premin. lia. } split => //. unfold clauses_sem. intros cl hin. - eapply valid_clause_model. eapply Clauses.for_all_spec in encl; tc. now eapply encl in hin. + eapply valid_clause_model. now eapply encl in hin. eapply Clauses.for_all_spec in ism; tc. now specialize (ism _ hin). Qed. @@ -6515,10 +6444,10 @@ Lemma check_entails {V init cls} (m : valid_model V V init cls) (cl : clause) : Proof. funelim (check m cl) => //. destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *. - destruct LevelMap.find as [[conclval_v|]|] eqn:hfind => //. + destruct LevelMap.find as [conclval_v|] eqn:hfind => //. (* Found a value *) unfold valid_clause, level_value_above. cbn. - move/Z.leb_le => hgt. + move/Nat.leb_le => hgt. intros m' ext. destruct min_premise eqn:hmin => //. pose proof (min_premise_spec m' prems) as [minle mineq]. @@ -6530,8 +6459,10 @@ Proof. assert (model_model v ⩽ model_model m). admit. assert (model_model v ⩽ m'). etransitivity; tea. eapply LevelMap.find_2 in hfind. - apply H0 in hfind as [k' [hmk' neq]]. depelim neq. rename y into conclval_m'. - eapply LevelMap.find_1 in hmk'. rewrite hmk'. eapply Z.leb_le. transitivity conclval_v => //. + apply H0 in hfind as [k' [hmk' neq]]. red in neq. rename k' into conclval_m'. + eapply LevelMap.find_1 in hmk'. rewrite hmk'. +Abort. + (*eapply Z.leb_le. transitivity conclval_v => //. destruct (Z.leb_spec z 0). (* If min_premise m' z > 0 in the final model, it means prems -> prems + 1, i.e. there is a loop, which is impossible. @@ -6555,6 +6486,6 @@ Proof. destruct minelt as [min k']. cbn. Abort. - +*) End LoopChecking. From e2002787705e0050f66ddb8829f53af13adeb268 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 28 Aug 2025 01:46:19 +0200 Subject: [PATCH 023/164] We can go back to a "normalized loop W + n -> W + n + 1" if we whish to --- template-rocq/theories/PartialLoopChecking.v | 77 ++++++++++++++++++++ 1 file changed, 77 insertions(+) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 03a70b861..e280352f4 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -5801,6 +5801,83 @@ Qed. Transparent lexprod_rel_wf. +Lemma add_prems_0 u : add_prems 0 u = u. +Proof. + rewrite /add_prems. + apply eq_univ'. + intros x. rewrite map_spec. + split. + - intros[e [hin ->]]. unfold add_expr. now destruct e; rewrite Nat.add_0_r. + - intros inu; exists x. split => //. destruct x. now rewrite /add_expr Nat.add_0_r. +Qed. + +Lemma entails_all_tauto cls u : cls ⊢a u → u. +Proof. + intros x hin. now constructor. +Qed. + +Lemma loop_any_successor cls u n : + cls ⊢a u → succ_prems u -> + cls ⊢a u → add_prems (S n) u. +Proof. + induction n. + - auto. + - intros ass. + specialize (IHn ass). + have sh := entails_all_shift 1 IHn. + eapply entails_all_trans. tea. + now rewrite add_prems_add_prems in sh. +Qed. + +Lemma loop_any cls u n : + cls ⊢a u → succ_prems u -> + cls ⊢a u → add_prems n u. +Proof. + destruct n. + - rewrite add_prems_0. intros _. apply entails_all_tauto. + - apply loop_any_successor. +Qed. + +Lemma univ_non_empty (u : univ) : ~ LevelSet.Empty (levels u). +Proof. intros he. have := t_ne u. move/not_Empty_is_empty. + intros he'. apply he'. intros [l k] hin. red in he. specialize (he l). apply he. + rewrite levelexprset_levels_spec. now exists k. +Qed. + +Lemma loop_max cls (u : univ) : + cls ⊢a of_level_set (levels u) (premise_max u) (univ_non_empty u) → u. +Proof. + intros [l k] hin. + apply (entails_pred_closure_n (n := premise_max u - k)). + constructor. + rewrite levelexprset_of_levels_spec. split. + - apply levelexprset_levels_spec. now exists k. + - have [min _] := premise_max_spec u. + apply min in hin. cbn in hin. lia. +Qed. + +Lemma loop_any_max cls u n : + cls ⊢a u → add_prems n u -> + cls ⊢a of_level_set (levels u) (premise_max u) (univ_non_empty u) → add_prems n u. +Proof. + intros hl. eapply entails_all_trans; tea. now eapply loop_max. +Qed. + +Lemma loop_any_max_all cls u : + cls ⊢a u → succ_prems u -> + cls ⊢a of_level_set (levels u) (premise_max u) (univ_non_empty u) → + of_level_set (levels u) (premise_max u + 1) (univ_non_empty u). +Proof. + intros hl. eapply entails_all_trans; tea. + eapply (loop_any_max _ _ (premise_max u + 1)). now eapply loop_any. + intros [l k]. + rewrite levelexprset_of_levels_spec => [] []. + rewrite levelexprset_levels_spec => [] [k' hin] ->. + eapply (entails_pred_closure_n (n := k')). + constructor. rewrite In_add_prems. + exists (l, k'). split => //. rewrite /add_expr. lia_f_equal. +Qed. + (* To handle the constraint inference problem, we must start with a model where all atoms [l + k] appearing in premises are true. Otherwise the From 4dd40301344b69d6588c97672e61e567bc969f09 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 28 Aug 2025 14:14:54 +0200 Subject: [PATCH 024/164] Cleanup the PartialLoopChecking file --- template-rocq/theories/Junk.v | 322 ++++++++++ template-rocq/theories/PartialLoopChecking.v | 636 +++++-------------- 2 files changed, 475 insertions(+), 483 deletions(-) create mode 100644 template-rocq/theories/Junk.v diff --git a/template-rocq/theories/Junk.v b/template-rocq/theories/Junk.v new file mode 100644 index 000000000..b0350f7a4 --- /dev/null +++ b/template-rocq/theories/Junk.v @@ -0,0 +1,322 @@ +#[program] +Definition of_level_map_n (m : LevelMap.t nat) V n (hne : ~ LevelMap.Empty m) : nonEmptyLevelExprSet := + {| t_set := LevelMap.fold (fun l k acc => + if LevelSet.mem l V then LevelExprSet.add (l, n + k) acc else + LevelExprSet.add (l, k) acc) m LevelExprSet.empty |}. +Next Obligation. Admitted. + +Lemma of_level_map_n_spec m V hne : + forall l n k, LevelExprSet.In (l, k) (of_level_map_n m V n hne) -> + (exists k', LevelMap.MapsTo l k' m /\ + (LevelSet.In l V -> k = n + k') /\ + (~ LevelSet.In l V -> k = k')). +Proof. +Admitted. + +Lemma of_level_map_n_spec_inv m V hne : + forall l n k, LevelMap.MapsTo l k m -> + exists k', LevelExprSet.In (l, k') (of_level_map_n m V n hne) /\ + (LevelSet.In l V -> k' = n + k) /\ + (~ LevelSet.In l V -> k' = k). +Proof. +Admitted. + + +Lemma of_level_map_of_level_map_n m V ne : + of_level_map m ne = of_level_map_n m V 0 ne. +Proof. + apply eq_univ'. + intros [l k]. + rewrite of_level_map_spec. + firstorder. + - unshelve eapply (of_level_map_n_spec_inv _ V ne _ 0) in H. + destruct H as [k' [hin [inv ninv]]]. + destruct (inLevelSet V l) as [hvin|hnin]. + specialize (inv hvin). cbn in inv. now subst k'. + specialize (ninv hnin). cbn in ninv. now subst. + - eapply of_level_map_n_spec in H as [k' [hm [hin hnin]]]. + destruct (inLevelSet V l) as [hvin|hvnin]. + now rewrite (hin hvin). + now rewrite (hnin hvnin). +Qed. + +Lemma of_level_map_n_only_model m V n ne : + + only_model_of V m -> + of_level_map_n m V n ne = add_prems n (of_level_map m ne). +Proof. + intros om. + apply eq_univ'. + intros [l k]. + rewrite In_add_prems. + split. + - move/of_level_map_n_spec => [k' [hm [hin hnin]]]. + destruct (inLevelSet V l) as [hvin|hvnin]. + * rewrite (hin hvin). exists (l, k'). + rewrite of_level_map_spec. split => //. rewrite /add_expr. lia_f_equal. + * elim hvnin. apply om. now exists k'. + - intros [[? ?] [hin heq]]. unfold add_expr in heq; noconf heq. + unshelve eapply of_level_map_spec in hin. + have inv : LevelSet.In l V. + { apply om. now exists n0. } + eapply (of_level_map_n_spec_inv _ V ne _ n) in hin as [k' [hin [hinv hninv]]]. + specialize (hinv inv). subst k'. now rewrite Nat.add_comm. +Qed. + + +(* Lemma entails_any V cls m nem m' nem' : + only_model_of V m -> + cls ⊢a of_level_map m nem → of_level_map m' nem' -> + model_rel_partial Nat.lt V m m' -> + cls ⊢a of_level_map m nem → of_level_map_n m V 1 nem. +Proof. + intros tot cla mp [l k]. + move/of_level_map_n_spec. + intros [k' [hm [hin hnin]]]. + destruct (LevelSetDecide.MSetDecideAuxiliary.dec_In l V). + rewrite (hin H). + rewrite -[1 + _]Nat.add_1_r. + eapply entails_any_one; tea. + rewrite (hnin H). + constructor. now rewrite of_level_map_spec. +Qed. *) + +(* Lemma entails_any V cls m nem m' nem' : + model_of V m -> + model_rel_partial Z.lt V m m' -> + cls ⊢a of_level_map_n m V 1 nem → of_level_map_n m V 2 nem. +Proof. *) + + +(* Lemma entails_concls cls V n m hne hne' : + model_of V m -> + entails_all cls (of_level_map_n m V n hne) (of_level_set V n hne'). +Proof. + move=> tot [l k]. + rewrite levelexprset_of_levels_spec => [] [] hin ->. + specialize (tot _ hin) as [k' hm]. + move/of_level_map_n_spec_inv in hm. + specialize (hm V hne n) as [k'' [hm [hin' hnin]]]. + specialize (hin' hin). subst k''. cbn in *. + exists + depind ent. + - move: H. + rewrite of_level_map_n_spec => [] [k' [mt [hin hnin]]]. + destruct (inLevelSet V l) as [H|H]. + * now left. + * right. apply hnin in H. now subst k'. + - specialize (IHent _ _ _ en l). + + intros [] *) + +(* +Lemma strictly_updates_restrict cls V m m' : + strictly_updates cls V m m' -> + (forall cl, Clauses.In cl (cls_diff cls V) -> valid_clause m cl) -> + strictly_updates (cls ⇂ V) V m m'. +Proof. + induction 1. + - intros hcl. constructor; auto. + move: {hcl} (hcl cl). + rewrite Clauses.diff_spec in_clauses_with_concl in_restrict_clauses. + destruct cl as [prems [concl k]]; cbn. + move=> h. split => //. eapply in_singleton. + forward h. + { split. split => //. apply in_singleton. + intros [insing hle incl']. + assert (~ LevelSet.Empty (levels prems)). admit. + have eqc : (forall l, LevelSet.In l (levels prems) -> l = concl). + { move=> l /hle. now rewrite LevelSet.singleton_spec. } + move: H0; rewrite /valid_clause //=. + intros [v [hmin hlt la eqm]]. + destruct min_premise eqn:hm => //. + have [minple [minprem [inprems eqm]]] := min_premise_spec m prems. + + + assert (LevelSet.Equal (levels prems) (LevelSet.singleton concl)). split => //. lsets. + rewrite LevelSet.singleton_spec => ->. destruct (LevelSet.choose (levels prems)) eqn:hc. + apply LevelSet.choose_spec1 in hc. apply hle in hc. apply LevelSet.singleton_spec in hc; red in hc; subst. + +*) + +(* +Lemma strictly_updates_entails_loop_relax cls V mzero hne m : + let bound := v_minus_w_bound V m in + let maxgain := max_gain cls in + let n := Z.to_nat bound + maxgain in + model_of V mzero -> + strictly_updates cls V mzero m -> + entails_all cls (of_level_map_n mzero V n hne) (of_level_map_n mzero V (n + 1) hne). +Proof. + move=> bound maxgain n tot su. + have mp := strictly_updates_model_lt su tot. + have nem := strictly_updates_non_empty_map su. + eapply (strictly_updates_entails hne nem) in su; tea. + eapply entails_any in su; tea. + eapply (entails_all_shift n) in su. + rewrite -of_level_map_of_level_map_n. +Qed. +*) +(* Lemma of_level_map_n_split m V n hne : of_level_map_n m V n hne = of_level_set V n hne' *) +Lemma max_premise_model_unique cls m : max_premise_model cls clauses_levels m -> m = max_premise_map cls. +Proof. +Admitted. + + +(* +Lemma strictly_updates_entails_loop_relax' ocls cls V (hne : ~ LevelSet.Empty V) mzero m : + above_max_premise_model ocls mzero -> + cls ⊂_clset ocls -> + V =_lset clauses_levels cls -> + model_of V mzero -> + strictly_updates cls V mzero m -> + entails_all cls (of_level_set V (max_clause_premise cls) hne) + (of_level_set V (max_clause_premise cls + 1) hne). +Proof. + move=> habove hincl hv tot su. + eapply strictly_updates_entails_loop_relax; tea. *) + + + +(* +Lemma above_max_premise_model_strengthen {cls cls' m} : + cls ⊂_clset cls' -> + above_max_premise_model cls m -> + above_max_premise_model cls' m. +Proof. + intros hincl [[V' su]|eq]. + left. 2:{ subst. red. } exists V'. + eapply strictly_updates_weaken; tea. red in ha. + move/(hmon _ _ hincl)/(ha l) => ha'. + eapply infer_atom_downward; tea. + apply max_clause_premise_mon in hincl. lia. +Qed. *) +Lemma model_max_max_premise_map cls : (model_max (max_premise_map cls)) = max_clause_premise cls. +Proof. +Admitted. + + + +Definition new_model m V newk : model := + LevelMap.fold (fun l k acc => + let k' := if LevelSet.mem l V then newk else k in + LevelMap.add l k' acc) m (LevelMap.empty _). + +Lemma new_model_spec m V newk l k : + LevelMap.MapsTo l k (new_model m V newk) -> + (exists k', LevelMap.MapsTo l k' m /\ + if LevelSet.mem l V then k = newk else k = k'). +Proof. Admitted. + +Definition domain (l : LevelMap.t (option Z)) : LevelSet.t := + LevelSetProp.of_list (List.map fst (LevelMap.elements l)). + + +(* (forall cl', Clauses.In cl cls -> forall l k, LevelExprSet.In (l, k) (premise cl') -> k <= n) *) +Lemma strictly_updates_entails_loop_max cls V (hne : ~ LevelSet.Empty V) m : + V =_lset clauses_levels cls -> + strictly_updates cls V (max_premise_map cls) m -> + entails_all cls (of_level_set V ((model_max (max_premise_map cls))) hne) + (of_level_set V ((model_max (max_premise_map cls)) + 1) hne). +Proof. + intros. + rewrite !model_max_max_premise_map. + eapply strictly_updates_entails_loop; tea. + eapply max_premise_model_exists. + apply todo. +Qed. + + +Definition find_max (ls : LevelExprSet.t) (l : Level.t) := + LevelExprSet.fold (fun '(l', k) acc => if eqb l l' then opt_max (Some k) acc else acc) ls None. + +Inductive find_max_spec ls l : option nat -> Prop := +| find_max_ex m : LevelExprSet.In (l, m) ls -> (forall k, LevelExprSet.In (l, k) ls -> k <= m) -> find_max_spec ls l (Some m) +| find_max_absent : ~ (exists k, LevelExprSet.In (l, k) ls) -> find_max_spec ls l None. + +Lemma find_max_correct ls l : find_max_spec ls l (find_max ls l). +Proof. + unfold find_max. + apply: (LevelExprSetProp.fold_rec (P := fun ls a => find_max_spec ls l a)). + - intros s' ise; constructor. intros [k hin]. now apply ise in hin. + - intros x a s' s'' hin hnotin hadd hspec. + destruct x as [l' k]. + destruct (eqb_spec l l'); subst. + * depelim hspec. + { constructor. destruct (Nat.max_spec k m) as [[hle hm]|[hle hm]]. + + rewrite hm. apply hadd; right; apply H. + + rewrite hm. apply hadd; left; reflexivity. + + intros k' hin'. apply hadd in hin' as []. + { noconf H1. lia. } + { specialize (H0 _ H1). lia. } } + { constructor. apply hadd; now left. + intros k0 hin'. apply hadd in hin' as []. + { noconf H0; reflexivity. } + { elim H. now exists k0. } } + * depelim hspec; constructor; eauto. + + apply hadd; now right. + + intros k' hin'. apply hadd in hin' as []. + { noconf H2. congruence. } + now apply H0 in H2. + + intros [k0 hk0]. apply hadd in hk0 as []. + { noconf H1; congruence. } + apply H. now exists k0. +Qed. + + +(* Lemma valuation_of_model_pos l k model : LevelMap.MapsTo l (Z.to_nat k) (valuation_of_model model) -> (k >= 0)%Z. +Proof. + unfold valuation_of_model. + revert l k. + eapply LevelMapFact.fold_rec. + - intros. now rewrite LevelMapFact.F.empty_mapsto_iff in H0. + - intros l0 k0 e m' m'' me nk hadd hind l k. + rewrite LevelMapFact.F.add_mapsto_iff. + intros []. + * destruct H. red in H; subst. + destruct k0. + { have hmax := (model_max_spec model l (Some z) me). depelim hmax. + have hmin := (model_min_spec model l (Some z) me). depelim hmin. + assert (0 <= model_max model)%Z. admit. + assert (model_min model <= 0)%Z. admit. + assert (model_max model - option_get 0%Z (Some z) - model_min model = k)%Z. admit. + cbn in H4. + lia. *) + + + + +Definition model_above cls m := forall l, + LevelSet.In l (clauses_levels cls) -> + exists k', LevelMap.MapsTo l k' m /\ max_clause_premise cls <= k'. + +Lemma model_above_infers {cls m} : + model_above cls m -> + (forall l, LevelSet.In l (clauses_levels cls) -> infers_atom m l (max_clause_premise cls)). +Proof. +Admitted. + +Lemma model_above_update {cls V' m m'} : + model_above cls m -> + strictly_updates cls V' m m' -> + model_above cls m'. +Proof. + move=> above /strictly_updates_ext. + move=> le l /above => [] [] k' [] hm hle. + apply le in hm as [k'' [hin' le']]. + exists k''. split => //. now transitivity k'. +Qed. + +Lemma max_premise_model_above cls m : max_premise_model cls clauses_levels m -> model_above cls m. +Admitted. + + +(* Lemma max_premise_model_above cls sel sel' m : + (sel' cls ⊂_lset sel cls) -> + max_premise_model cls sel m -> + above_max_premise_model cls m. +Proof. + move=> incl mp l hl; move: (proj1 mp l (incl _ hl)); rewrite /infers_atom. + move/level_value_MapsTo => ->. reflexivity. +Qed. *) + diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index e280352f4..fc1a3e0b5 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -375,13 +375,15 @@ Module NonEmptySetFacts. now rewrite (uip_bool _ _ u2 v2). Qed. - Lemma eq_univ' (u v : nonEmptyLevelExprSet) : - LevelExprSet.Equal u v -> u = v. + Lemma eq_univ_equal (u v : nonEmptyLevelExprSet) : + LevelExprSet.Equal u v <-> u = v. Proof. - intro H. now apply eq_univ, LevelExprSet.eq_leibniz. + split. + - intro H. now apply eq_univ, LevelExprSet.eq_leibniz. + - intros ->; reflexivity. Qed. - Lemma eq_univ'' (u v : nonEmptyLevelExprSet) : + Lemma eq_univ_elements (u v : nonEmptyLevelExprSet) : LevelExprSet.elements u = LevelExprSet.elements v -> u = v. Proof. intro H. apply eq_univ. @@ -395,7 +397,7 @@ Module NonEmptySetFacts. Proof. split. - intros. - apply eq_univ'. now apply LevelExprSet.equal_spec. + apply eq_univ_equal. now apply LevelExprSet.equal_spec. - intros ->. now apply LevelExprSet.equal_spec. Qed. @@ -437,7 +439,7 @@ Module NonEmptySetFacts. Lemma add_comm {le le' e} : add le (add le' e) = add le' (add le e). Proof. - apply eq_univ'. intros x. + apply eq_univ_equal. intros x. rewrite !LevelExprSet.add_spec. firstorder. Qed. @@ -462,21 +464,21 @@ Module NonEmptySetFacts. Lemma univ_union_add_singleton u le : univ_union u (singleton le) = add le u. Proof. - apply eq_univ'. + apply eq_univ_equal. intros x. rewrite univ_union_spec LevelExprSet.singleton_spec add_spec. intuition auto. Qed. Lemma univ_union_comm {u u'} : univ_union u u' = univ_union u' u. Proof. - apply eq_univ'. + apply eq_univ_equal. intros x. rewrite !univ_union_spec. intuition auto. Qed. Lemma univ_union_add_distr {le u u'} : univ_union (add le u) u' = add le (univ_union u u'). Proof. - apply eq_univ'. + apply eq_univ_equal. intros x. rewrite !univ_union_spec !add_spec !univ_union_spec. intuition auto. Qed. @@ -916,9 +918,36 @@ Proof. now rewrite hm. Qed. +Lemma eqlistA_eq {A} (l l' : list A) : eqlistA Logic.eq l l' -> l = l'. +Proof. + induction 1. + - reflexivity. + - now f_equal. +Qed. + +Instance clauses_elements_proper : Proper (Clauses.Equal ==> eq) Clauses.elements. +Proof. + intros cl cl' eq. + have sl := Clauses.elements_spec2 cl. + (* have nl := Clauses.elements_spec2w cl. *) + have sl' := Clauses.elements_spec2 cl'. + (* have nl' := Clauses.elements_spec2w cl'. *) + have heq := @SortA_equivlistA_eqlistA _ Logic.eq _ Clause.lt_. + do 3 forward heq by tc. + specialize (heq _ _ sl sl'). + forward heq. + red. intros x. + rewrite -! ClausesProp.Dec.F.elements_iff. apply eq. + now apply eqlistA_eq. +Qed. + #[local] Instance check_model_aux_proper : Proper (Clauses.Equal ==> eq ==> eq) check_model_aux. Proof. -Admitted. + intros ? ? eq ? ? ->. + rewrite /check_model_aux. + rewrite !ClausesProp.fold_spec_right. + now rewrite eq. +Qed. #[local] Instance check_model_proper : Proper (Clauses.Equal ==> eq ==> eq) check_model. Proof. @@ -2001,13 +2030,6 @@ Proof. - depelim amin. rewrite H in hprem. depelim hprem. Qed. -Lemma min_premise_pos_spec_inv {m} {prem: nonEmptyLevelExprSet} : - (forall x, LevelExprSet.In x prem -> exists k, levelexpr_value m x = Some k) -> - exists k, min_premise m prem = Some k. -Proof. - intros hprem. -Admitted. - Lemma v_minus_w_bound_spec W m : forall x, ~ LevelSet.In x W -> level_value m x ≤ Some (v_minus_w_bound W m). Proof. @@ -2273,19 +2295,6 @@ Proof. firstorder eauto. Qed. -(* Lemma min_premise_some_pres {m m' prems k} : m ⩽ m' -> min_premise m prems = Some k -> exists k', min_premise m' prems = Some k'. -Proof. - intros ext minp. - apply (@min_premise_pos_spec_inv m' prems). - intros x hin. - pose proof (min_premise_spec m prems) as [le eq]. specialize (le x hin). - rewrite minp in le. depelim le. - move: H0; rewrite /min_atom_value /levelexpr_value /level_value. destruct x as [l k']. - destruct LevelMap.find eqn:hfind => //. intros [= <-]. - eapply LevelMap.find_2 in hfind. eapply ext in hfind as [? [map2 hsome]]. - eapply LevelMap.find_1 in map2. rewrite map2. depelim hsome. now exists n. -Qed. *) - Lemma min_premise_spec' {m prems z} : min_premise m prems = Some z -> (forall l k, LevelExprSet.In (l, k) prems -> exists v, level_value m l = Some v /\ z <= (Z.of_nat v - Z.of_nat k))%Z. @@ -2310,13 +2319,13 @@ Proof. destruct (LevelExprSet.is_empty s) eqn:hem in |- . eapply LevelExprSetFact.is_empty_2 in hem. assert (singleton x = {| t_set := s'; t_ne := hne |}) as <- => //. - unfold singleton. apply eq_univ'. cbn. + unfold singleton. apply eq_univ_equal. cbn. intros a. specialize (hadd a). rewrite hadd. rewrite LevelExprSet.singleton_spec. firstorder. subst. reflexivity. specialize (IH hem). specialize (ha x _ IH). assert (LevelExprSet.Equal (add x {| t_set := s; t_ne := hem|}) {| t_set := s'; t_ne := hne |}). - 2:{ apply eq_univ' in H. now rewrite -H. } + 2:{ apply eq_univ_equal in H. now rewrite -H. } intros x'. specialize (hadd x'). rewrite LevelExprSet.add_spec. cbn. firstorder. subst x'. now left. Qed. @@ -2611,15 +2620,37 @@ Qed. Lemma map_map f g x : map f (map g x) = map (f ∘ g) x. Proof. - apply eq_univ'. + apply eq_univ_equal. intros lk. rewrite !map_spec. setoid_rewrite map_spec. firstorder eauto. subst. firstorder. Qed. +Lemma add_expr_inj {n e e'} : add_expr n e = add_expr n e' -> e = e'. +Proof. + destruct e, e'; cbn; intros [=]. + have eq: n0 = n1 by lia. + now subst n0. +Qed. + +Lemma add_prems_inj n prems prems' : add_prems n prems = add_prems n prems' -> prems = prems'. +Proof. + rewrite /add_prems => /eq_univ_equal hm. + apply eq_univ_equal. + intros [l k]. specialize (hm (l, k + n)%nat). + rewrite !map_spec in hm. destruct hm as [hl hr]. + split; intros hin. + - forward hl. exists (l, k); split => //. + destruct hl as [[] [hin' eq]]. + apply (@add_expr_inj n (l, k)) in eq. now noconf eq. + - forward hr. exists (l, k); split => //. + destruct hr as [[] [hin' eq]]. + apply (@add_expr_inj n (l, k)) in eq. now noconf eq. +Qed. + Lemma add_prems_add_prems n n' lk : add_prems n (add_prems n' lk) = add_prems (n + n') lk. Proof. destruct lk; unfold add_prems. - rewrite map_map. apply eq_univ'. + rewrite map_map. apply eq_univ_equal. intros x; rewrite /= !map_spec. cbn in *. firstorder eauto. subst. exists x0. firstorder eauto. now rewrite add_expr_add_expr. @@ -2640,8 +2671,11 @@ Notation succ_expr := (add_expr 1). Notation succ_prems := (add_prems 1). Notation succ_clause := (add_clause 1). -Lemma succ_clause_inj x y : succ_clause x = succ_clause y -> x = y. -Proof. Admitted. +Lemma add_clause_inj {n x y} : add_clause n x = add_clause n y -> x = y. +Proof. + destruct x as [prems concl], y as [prems' concl']. + now move=> [=] /add_prems_inj -> /add_expr_inj ->. +Qed. Definition add_clauses n cls := ClausesProp.of_list (List.map (fun cl => add_clause n cl) (ClausesProp.to_list cls)). Notation succ_clauses := (add_clauses 1). Import SetoidList. @@ -2651,7 +2685,7 @@ Proof. rewrite ClausesProp.of_list_1 InA_In_eq in_map_iff. firstorder eauto. - exists cl; split => //. unfold ClausesProp.to_list. now eapply Clauses_In_elements. - - eapply Clauses_In_elements in H0. apply succ_clause_inj in H. now subst. + - eapply Clauses_In_elements in H0. apply add_clause_inj in H. now subst. Qed. Variant in_pred_closure cls : clause -> Prop := @@ -2677,7 +2711,7 @@ Lemma in_pred_closure_equal cls (prems prems' : nonEmptyLevelExprSet) concl : LevelExprSet.Equal prems prems' -> in_pred_closure cls (prems, concl) -> in_pred_closure cls (prems', concl). Proof. - intros eq. apply NonEmptySetFacts.eq_univ' in eq. now subst prems. + intros eq. apply NonEmptySetFacts.eq_univ_equal in eq. now subst prems. Qed. Lemma entails_equal cls (prems prems' : nonEmptyLevelExprSet) concl : @@ -2686,7 +2720,7 @@ Lemma entails_equal cls (prems prems' : nonEmptyLevelExprSet) concl : Proof. intros he en. replace prems' with prems => //. - now apply eq_univ'. + now apply eq_univ_equal. Qed. Lemma entails_plus cls c : entails cls c -> entails (succ_clauses cls) (succ_clause c). @@ -2701,7 +2735,7 @@ Proof. now rewrite Nat.add_1_r. } constructor. now rewrite -succ_clauses_spec. * have eq : (succ_prems (singleton (x, (k + 1)%nat))) = (singleton (x, k + 1 + 1)%nat). - { apply eq_univ'. unfold succ_prems. + { apply eq_univ_equal. unfold succ_prems. intros le. rewrite map_spec LevelExprSet.singleton_spec. split. { intros [? [hin ->]]. @@ -2751,7 +2785,7 @@ Proof. destruct cl as [prems [concl k]]; cbn. f_equal. 2:now rewrite Nat.add_0_r. unfold add_prems. - eapply eq_univ'. intros [l k']. + eapply eq_univ_equal. intros [l k']. rewrite NonEmptySetFacts.map_spec. unfold add_expr. firstorder. destruct x. noconf H0. now rewrite Nat.add_0_r. @@ -2790,7 +2824,7 @@ Qed. Lemma add_clause_singleton n le concl k : add_clause n (singleton le, (concl, k)) = (singleton (add_expr n le), (concl, k + n)). Proof. rewrite /add_clause //=. f_equal. - apply eq_univ'. intros le'. rewrite In_add_prems. + apply eq_univ_equal. intros le'. rewrite In_add_prems. rewrite_strat (topdown LevelExprSet.singleton_spec). unfold LevelExprSet.E.eq. firstorder. subst. reflexivity. Qed. @@ -2947,7 +2981,7 @@ Proof. { red in H0; subst concl0. now constructor. } { now constructor. } * have eq : prems = add concl0 prems. - { eapply eq_univ'. intros x; rewrite LevelExprSet.add_spec. firstorder. now red in H2; subst. } + { eapply eq_univ_equal. intros x; rewrite LevelExprSet.add_spec. firstorder. now red in H2; subst. } rewrite -eq in H1. eapply (clause_cut _ prems' _ prems). tea. 2:tea. now rewrite -eq in he. @@ -3142,9 +3176,9 @@ Proof. assert (hne : ~ LevelSet.Empty W). now rewrite eq. exists hne. assert (of_level_set W n hne = of_level_set W' n hne') as ->. - apply eq_univ'. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. + apply eq_univ_equal. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. assert (of_level_set W (n + 1) hne = of_level_set W' (n + 1) hne') as ->. - apply eq_univ'. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. + apply eq_univ_equal. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. by []. Qed. *) @@ -3528,7 +3562,6 @@ Definition max_premise_model cls sel m := LevelMap.MapsTo l (max_clause_premise cls) m) /\ (forall l k, LevelMap.MapsTo l k m -> LevelSet.In l (sel cls) /\ k = max_clause_premise cls). - Definition max_premise_map cls : model := let max := max_clause_premise cls in let ls := clauses_levels cls in @@ -3604,16 +3637,6 @@ Proof. specialize (H l hl). eexists; split. exact H. lia. Qed. -(* Lemma max_premise_model_above cls sel sel' m : - (sel' cls ⊂_lset sel cls) -> - max_premise_model cls sel m -> - above_max_premise_model cls m. -Proof. - move=> incl mp l hl; move: (proj1 mp l (incl _ hl)); rewrite /infers_atom. - move/level_value_MapsTo => ->. reflexivity. -Qed. *) - - Lemma clauses_with_concl_union cls W W' : Clauses.Equal (clauses_with_concl cls (LevelSet.union W W')) (Clauses.union (clauses_with_concl cls W) (clauses_with_concl cls W')). @@ -4760,14 +4783,23 @@ Proof. lia. Qed. Definition model_min m := LevelMap.fold (fun l k acc => Nat.min acc k) m 0%nat. -(* Lemma model_min_spec m : forall l k, LevelMap.MapsTo l k m -> (Some (model_min m) ≤ k). *) -(* Proof. Admitted. *) - Definition model_max m := LevelMap.fold (fun l k acc => Nat.max acc k) m 0%nat. Lemma model_max_spec m : forall l k, LevelMap.MapsTo l k m -> (k <= model_max m)%nat. -Proof. Admitted. +Proof. + intros l k hm. + rewrite /model_max. + move: hm; eapply LevelMapFact.fold_rec. + - move=> m0 he hm. now apply he in hm. + - intros k' e a m' m'' hm nin hadd hle hm''. + specialize (hadd l). + eapply levelmap_find_eq_inv in hadd. eapply hadd in hm''. + rewrite LevelMapFact.F.add_mapsto_iff in hm''. + move: hm''=> [] [h h']. + * subst k. lia. + * move/hle: h'. lia. +Qed. Definition valuation_of_model (m : model) : LevelMap.t nat := let max := model_max m in @@ -4776,9 +4808,21 @@ Close Scope Z_scope. Lemma valuation_of_model_spec m : forall l k, LevelMap.MapsTo l k m -> - let v := (model_max m - k )%nat in + let v := (model_max m - k)%nat in LevelMap.MapsTo l v (valuation_of_model m). -Proof. Admitted. +Proof. + intros l k hm v. + unfold valuation_of_model. subst v. + move: hm. generalize (model_max m) => n. + eapply LevelMapFact.fold_rec. + - intros v he hm. + now eapply he in hm. + - intros. + specialize (H1 l). eapply levelmap_find_eq_inv in H1. eapply H1 in hm. + rewrite LevelMapFact.F.add_mapsto_iff in hm. destruct hm as [[-> ->]|[neq hm]]. + * eapply LevelMapFact.F.add_mapsto_iff. now left. + * eapply LevelMapFact.F.add_mapsto_iff. right. split => //. now apply H2. +Qed. Lemma strictly_updates_valid_model {W W' m m' cls} : is_model (cls ↓ W) m -> @@ -4866,7 +4910,7 @@ Lemma of_level_set_union_spec {ls ls' n hne} hne' hne'' : of_level_set (ls ∪ ls') n hne = univ_union (of_level_set ls n hne') (of_level_set ls' n hne''). Proof. - apply eq_univ'. + apply eq_univ_equal. intros [l k]. rewrite /of_level_set //= !levelexprset_of_levels_spec LevelExprSet.union_spec. rewrite !levelexprset_of_levels_spec LevelSet.union_spec. clear. firstorder. Qed. @@ -5089,30 +5133,6 @@ Proof. rewrite H1 in minsleq. depelim minsleq. lia. Qed. -Definition model_above cls m := forall l, - LevelSet.In l (clauses_levels cls) -> - exists k', LevelMap.MapsTo l k' m /\ max_clause_premise cls <= k'. - -Lemma model_above_infers {cls m} : - model_above cls m -> - (forall l, LevelSet.In l (clauses_levels cls) -> infers_atom m l (max_clause_premise cls)). -Proof. -Admitted. - -Lemma model_above_update {cls V' m m'} : - model_above cls m -> - strictly_updates cls V' m m' -> - model_above cls m'. -Proof. - move=> above /strictly_updates_ext. - move=> le l /above => [] [] k' [] hm hle. - apply le in hm as [k'' [hin' le']]. - exists k''. split => //. now transitivity k'. -Qed. - -Lemma max_premise_model_above cls m : max_premise_model cls clauses_levels m -> model_above cls m. -Admitted. - Lemma strictly_updates_entails {cls V mzero m} (hne : ~ LevelMap.Empty mzero) (hne' : ~ LevelMap.Empty m) : strictly_updates cls V mzero m -> entails_all cls (of_level_map mzero hne) (of_level_map m hne'). @@ -5160,7 +5180,7 @@ Lemma of_level_map_of_level_set cls sel V m hne hne' : V =_lset sel cls -> of_level_map m hne = of_level_set V (max_clause_premise cls) hne'. Proof. - move=> mp hv. apply: eq_univ' => [[l k]]. + move=> mp hv. apply: eq_univ_equal => [[l k]]. rewrite of_level_map_spec levelexprset_of_levels_spec. split. red in mp. move/(proj2 mp l) => [hin eq]. split. 2:lia. lsets. @@ -5195,20 +5215,6 @@ Proof. eapply infers_atom_of_level_map. Qed. -(* -Lemma of_level_set_entails_of_level_map cls sel V m hne hne' : - above_max_premise_model cls sel m -> - V ⊂_lset sel cls -> - cls ⊢a of_level_set V (max_clause_premise cls) hne' → of_level_map m hne. -Proof. - move=> mp hv. - intros [l k]. - rewrite of_level_map_spec. levelexprset_of_levels_spec. - intros [hin ->]. - move: (mp l (hv _ hin)). - eapply infers_atom_of_level_map. -Qed. *) - (* The criterion for loops: when a set of updates manages to strictly update all the levels it started with, then we can deduce a looping constraint `x, ..., z -> x + 1, ... z + 1`. @@ -5218,10 +5224,6 @@ Qed. *) *) -Lemma max_premise_model_unique cls m : max_premise_model cls clauses_levels m -> m = max_premise_map cls. -Proof. -Admitted. - Lemma strictly_updates_entails_loop cls V (hne : ~ LevelSet.Empty V) mzero m : max_premise_model cls clauses_levels mzero -> V =_lset clauses_levels cls -> @@ -5279,151 +5281,6 @@ Proof. apply max_premise_model_exists. Qed. -(* -Lemma strictly_updates_restrict cls V m m' : - strictly_updates cls V m m' -> - (forall cl, Clauses.In cl (cls_diff cls V) -> valid_clause m cl) -> - strictly_updates (cls ⇂ V) V m m'. -Proof. - induction 1. - - intros hcl. constructor; auto. - move: {hcl} (hcl cl). - rewrite Clauses.diff_spec in_clauses_with_concl in_restrict_clauses. - destruct cl as [prems [concl k]]; cbn. - move=> h. split => //. eapply in_singleton. - forward h. - { split. split => //. apply in_singleton. - intros [insing hle incl']. - assert (~ LevelSet.Empty (levels prems)). admit. - have eqc : (forall l, LevelSet.In l (levels prems) -> l = concl). - { move=> l /hle. now rewrite LevelSet.singleton_spec. } - move: H0; rewrite /valid_clause //=. - intros [v [hmin hlt la eqm]]. - destruct min_premise eqn:hm => //. - have [minple [minprem [inprems eqm]]] := min_premise_spec m prems. - - - assert (LevelSet.Equal (levels prems) (LevelSet.singleton concl)). split => //. lsets. - rewrite LevelSet.singleton_spec => ->. destruct (LevelSet.choose (levels prems)) eqn:hc. - apply LevelSet.choose_spec1 in hc. apply hle in hc. apply LevelSet.singleton_spec in hc; red in hc; subst. - -*) - - -Definition new_model m V newk : model := - LevelMap.fold (fun l k acc => - let k' := if LevelSet.mem l V then newk else k in - LevelMap.add l k' acc) m (LevelMap.empty _). - -Lemma new_model_spec m V newk l k : - LevelMap.MapsTo l k (new_model m V newk) -> - (exists k', LevelMap.MapsTo l k' m /\ - if LevelSet.mem l V then k = newk else k = k'). -Proof. Admitted. - -Definition domain (l : LevelMap.t (option Z)) : LevelSet.t := - LevelSetProp.of_list (List.map fst (LevelMap.elements l)). - -(* Lemma level_value_new_model {m V newk l} : - model_of V m -> - level_value (new_model m V newk) l = - if LevelSet.mem l V then newk else level_value m l. -Admitted. *) - -(* Lemma strictly_updates_entails_loop2 cls V (hne : ~ LevelSet.Empty V) mzero m : - let bound := v_minus_w_bound V m in - let maxgain := max_gain cls in - let n := Z.to_nat bound + maxgain in - (* V =_lset clauses_levels cls -> *) - model_of V mzero -> - strictly_updates cls V mzero m -> - entails_all cls (of_level_set V n hne) (of_level_set V (n + 1) hne). -Proof. - intros bound maxgain n tot su. - have nemzero : ~ LevelMap.Empty mzero. - { have := not_empty_exists V hne => [[l]]. - now move/tot => [v hm] /(_ _ _ hm). } - have nem := strictly_updates_non_empty_map su. - (* eapply strictly_updates_strenghten in su. *) - (* unshelve eapply strictly_updates_entails in su; tea. *) - set (m' := new_model m V (Some (Z.of_nat n))). - set (d := LevelSet.diff (domain mzero) V). - have vm : is_model (cls ↓ d) m'. - { eapply Clauses.for_all_spec. tc. intros cl hin. - unfold valid_clause. destruct min_premise eqn:hmin => //. - destruct cl as [prems [concl k]]. cbn in *. - elim: Z.ltb_spec => // ge //=. unfold level_value_above. - destruct level_value eqn:hl => //. eapply level_value_MapsTo' in hl. - apply new_model_spec in hl as [k' [hm cond]]. - destruct LevelSet.mem eqn:hmem. noconf cond. admit. subst k'. - have [minple minpeq] := min_premise_spec m' prems. - destruct minpeq as [[minpl minpk] [inminp mineq]]. - destruct (inLevelSet V minpl). - 3:{ admit. } - (* clause has its minimal premise in V which might have been updated in m. - In m' its value is hence n *) - unfold min_atom_value in mineq. - rewrite level_value_new_model in mineq => //. now eapply strictly_updates_total_model. - rewrite (LevelSetFact.mem_1 H) in mineq. - rewrite hmin in mineq. noconf mineq. - - - } - - - have [m'' su'] : exists m'', strictly_updates (cls ⇂ V) V m' m''. - admit. - have mp := strictly_updates_model_lt su'. - forward mp. admit. - eapply entails_all_clauses_subset. - have nem' : ~ LevelMap.Empty m'. admit. - have nem'' : ~ LevelMap.Empty m''. admit. - - (* have sue := strictly_updates_entails nem' nem'' _ su'. *) - (* forward sue. admit. apply sue in su'. (cls ⇂ V). in su'; tea *) -Admitted. *) - - -Lemma model_max_max_premise_map cls : (model_max (max_premise_map cls)) = max_clause_premise cls. -Proof. -Admitted. - -Lemma strictly_updates_entails_loop_max cls V (hne : ~ LevelSet.Empty V) m : - V =_lset clauses_levels cls -> - strictly_updates cls V (max_premise_map cls) m -> - entails_all cls (of_level_set V ((model_max (max_premise_map cls))) hne) - (of_level_set V ((model_max (max_premise_map cls)) + 1) hne). -Proof. - intros. - rewrite !model_max_max_premise_map. - eapply strictly_updates_entails_loop; tea. - eapply max_premise_model_exists. - apply todo. -Qed. - -#[program] -Definition of_level_map_n (m : LevelMap.t nat) V n (hne : ~ LevelMap.Empty m) : nonEmptyLevelExprSet := - {| t_set := LevelMap.fold (fun l k acc => - if LevelSet.mem l V then LevelExprSet.add (l, n + k) acc else - LevelExprSet.add (l, k) acc) m LevelExprSet.empty |}. -Next Obligation. Admitted. - -Lemma of_level_map_n_spec m V hne : - forall l n k, LevelExprSet.In (l, k) (of_level_map_n m V n hne) -> - (exists k', LevelMap.MapsTo l k' m /\ - (LevelSet.In l V -> k = n + k') /\ - (~ LevelSet.In l V -> k = k')). -Proof. -Admitted. - -Lemma of_level_map_n_spec_inv m V hne : - forall l n k, LevelMap.MapsTo l k m -> - exists k', LevelExprSet.In (l, k') (of_level_map_n m V n hne) /\ - (LevelSet.In l V -> k' = n + k) /\ - (~ LevelSet.In l V -> k' = k). -Proof. -Admitted. - Lemma entails_any_one V cls m nem m' nem' : model_of V m -> cls ⊢a of_level_map m nem → of_level_map m' nem' -> @@ -5439,73 +5296,29 @@ Proof. apply infers_atom_of_level_map. red. rewrite (level_value_MapsTo hm''). constructor. lia. Qed. -Lemma of_level_map_of_level_map_n m V ne : - of_level_map m ne = of_level_map_n m V 0 ne. -Proof. - apply eq_univ'. - intros [l k]. - rewrite of_level_map_spec. - firstorder. - - unshelve eapply (of_level_map_n_spec_inv _ V ne _ 0) in H. - destruct H as [k' [hin [inv ninv]]]. - destruct (inLevelSet V l) as [hvin|hnin]. - specialize (inv hvin). cbn in inv. now subst k'. - specialize (ninv hnin). cbn in ninv. now subst. - - eapply of_level_map_n_spec in H as [k' [hm [hin hnin]]]. - destruct (inLevelSet V l) as [hvin|hvnin]. - now rewrite (hin hvin). - now rewrite (hnin hvnin). -Qed. - -Lemma of_level_map_n_only_model m V n ne : - only_model_of V m -> - of_level_map_n m V n ne = add_prems n (of_level_map m ne). + +Lemma only_model_of_model_of {V m} : only_model_of V m -> model_of V m. Proof. - intros om. - apply eq_univ'. - intros [l k]. - rewrite In_add_prems. - split. - - move/of_level_map_n_spec => [k' [hm [hin hnin]]]. - destruct (inLevelSet V l) as [hvin|hvnin]. - * rewrite (hin hvin). exists (l, k'). - rewrite of_level_map_spec. split => //. rewrite /add_expr. lia_f_equal. - * elim hvnin. apply om. now exists k'. - - intros [[? ?] [hin heq]]. unfold add_expr in heq; noconf heq. - unshelve eapply of_level_map_spec in hin. - have inv : LevelSet.In l V. - { apply om. now exists n0. } - eapply (of_level_map_n_spec_inv _ V ne _ n) in hin as [k' [hin [hinv hninv]]]. - specialize (hinv inv). subst k'. now rewrite Nat.add_comm. + intros om l. move/om. intros [k hm]; now exists k. Qed. +Coercion only_model_of_model_of : only_model_of >-> model_of. + Lemma entails_any V cls m nem m' nem' : - model_of V m -> + only_model_of V m -> cls ⊢a of_level_map m nem → of_level_map m' nem' -> model_rel_partial Nat.lt V m m' -> - cls ⊢a of_level_map m nem → of_level_map_n m V 1 nem. + cls ⊢a of_level_map m nem → succ_prems (of_level_map m nem). Proof. intros tot cla mp [l k]. - move/of_level_map_n_spec. - intros [k' [hm [hin hnin]]]. - destruct (LevelSetDecide.MSetDecideAuxiliary.dec_In l V). - rewrite (hin H). - rewrite -[1 + _]Nat.add_1_r. - eapply entails_any_one; tea. - rewrite (hnin H). - constructor. now rewrite of_level_map_spec. + rewrite In_add_prems => [] [[l' k']] [] /of_level_map_spec hm [=] -> ->. + eapply entails_any_one; tea. exact tot. apply tot. now exists k'. Qed. -(* Lemma entails_any V cls m nem m' nem' : - model_of V m -> - model_rel_partial Z.lt V m m' -> - cls ⊢a of_level_map_n m V 1 nem → of_level_map_n m V 2 nem. -Proof. *) - Lemma strictly_updates_entails_on_V cls V mzero hne m : - model_of V mzero -> + only_model_of V mzero -> strictly_updates cls V mzero m -> - entails_all (cls ↓ V) (of_level_map mzero hne) (of_level_map_n mzero V 1 hne). + entails_all (cls ↓ V) (of_level_map mzero hne) (succ_prems (of_level_map mzero hne)). Proof. move=> tot su. have mp := strictly_updates_model_lt su tot. @@ -5515,87 +5328,17 @@ Proof. eapply entails_any in su; tea. Qed. -(* Lemma entails_concls cls V n m hne hne' : - model_of V m -> - entails_all cls (of_level_map_n m V n hne) (of_level_set V n hne'). -Proof. - move=> tot [l k]. - rewrite levelexprset_of_levels_spec => [] [] hin ->. - specialize (tot _ hin) as [k' hm]. - move/of_level_map_n_spec_inv in hm. - specialize (hm V hne n) as [k'' [hm [hin' hnin]]]. - specialize (hin' hin). subst k''. cbn in *. - exists - depind ent. - - move: H. - rewrite of_level_map_n_spec => [] [k' [mt [hin hnin]]]. - destruct (inLevelSet V l) as [H|H]. - * now left. - * right. apply hnin in H. now subst k'. - - specialize (IHent _ _ _ en l). - - intros [] *) - -(* -Lemma strictly_updates_entails_loop_relax cls V mzero hne m : - let bound := v_minus_w_bound V m in - let maxgain := max_gain cls in - let n := Z.to_nat bound + maxgain in - model_of V mzero -> - strictly_updates cls V mzero m -> - entails_all cls (of_level_map_n mzero V n hne) (of_level_map_n mzero V (n + 1) hne). -Proof. - move=> bound maxgain n tot su. - have mp := strictly_updates_model_lt su tot. - have nem := strictly_updates_non_empty_map su. - eapply (strictly_updates_entails hne nem) in su; tea. - eapply entails_any in su; tea. - eapply (entails_all_shift n) in su. - rewrite -of_level_map_of_level_map_n. -Qed. -*) -(* Lemma of_level_map_n_split m V n hne : of_level_map_n m V n hne = of_level_set V n hne' *) - -(* -Lemma strictly_updates_entails_loop_relax' ocls cls V (hne : ~ LevelSet.Empty V) mzero m : - above_max_premise_model ocls mzero -> - cls ⊂_clset ocls -> - V =_lset clauses_levels cls -> - model_of V mzero -> - strictly_updates cls V mzero m -> - entails_all cls (of_level_set V (max_clause_premise cls) hne) - (of_level_set V (max_clause_premise cls + 1) hne). -Proof. - move=> habove hincl hv tot su. - eapply strictly_updates_entails_loop_relax; tea. *) - - - - Lemma add_prems_add {n lk prems} : add_prems n (add lk prems) = add (add_expr n lk) (add_prems n prems). Proof. - apply eq_univ'. intros x. + apply eq_univ_equal. intros x. rewrite In_add_prems LevelExprSet.add_spec In_add_prems /LevelExprSet.E.eq; rw LevelExprSet.add_spec. firstorder. subst. red in H; subst x0. now left. Qed. -(* -Lemma above_max_premise_model_strengthen {cls cls' m} : - cls ⊂_clset cls' -> - above_max_premise_model cls m -> - above_max_premise_model cls' m. -Proof. - intros hincl [[V' su]|eq]. - left. 2:{ subst. red. } exists V'. - eapply strictly_updates_weaken; tea. red in ha. - move/(hmon _ _ hincl)/(ha l) => ha'. - eapply infer_atom_downward; tea. - apply max_clause_premise_mon in hincl. lia. -Qed. *) Lemma add_prems_of_level_set k W k' prf : add_prems k (of_level_set W k' prf) = of_level_set W (k + k') prf. Proof. - apply eq_univ' => [] [l n]. + apply eq_univ_equal => [] [l n]. rewrite In_add_prems /of_level_set //= levelexprset_of_levels_spec. split. - move=> [] [l' n']. rewrite levelexprset_of_levels_spec => [] [[inw eq] eq']. @@ -5606,7 +5349,7 @@ Qed. Lemma of_level_set_singleton l k hne : of_level_set (LevelSet.singleton l) k hne = singleton (l, k). Proof. - apply: eq_univ'. move=> [l' k']. + apply: eq_univ_equal. move=> [l' k']. rewrite /of_level_set //= levelexprset_of_levels_spec !LevelExprSet.singleton_spec LevelSet.singleton_spec /LevelSet.E.eq /LevelExprSet.E.eq. firstorder subst => //. now noconf H. now noconf H. Qed. @@ -5656,13 +5399,6 @@ Proof. now eapply strictly_updates_non_empty_map in su. Qed. -Lemma only_model_of_model_of {V m} : only_model_of V m -> model_of V m. -Proof. - intros om l. move/om. intros [k hm]; now exists k. -Qed. - -Coercion only_model_of_model_of : only_model_of >-> model_of. - #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) (prf : [/\ clauses_levels cls ⊂_lset V, only_model_of V minit & is_update_of cls U minit m]) : result V U cls minit @@ -5702,8 +5438,7 @@ Proof. eapply check_model_is_update_of in eqm; tea. rewrite eq in eqm. destruct eqm as [eqm incl]. rewrite union_idem in eqm. unshelve eapply strictly_updates_entails_on_V in eqm; tea. - rewrite of_level_map_n_only_model in eqm => //. - eapply entails_all_clauses_subset; tea. apply clauses_with_concl_subset. exact mof. + eapply entails_all_clauses_subset; tea. apply clauses_with_concl_subset. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hi := strictly_updates_incl eqm. rewrite union_idem in hi, eqm. @@ -5727,7 +5462,6 @@ Proof. eapply check_model_is_update_of in eqm' as [eqm' incl']; tea. rewrite ClausesProp.union_sym union_with_concl in eqm'. eapply (strictly_updates_entails_on_V _ _ _ ne) in eqm'. red. - rewrite of_level_map_n_only_model in eqm'. eapply LevelSet.equal_spec in e. now rewrite e. eapply entails_all_clauses_subset; tea. eapply clauses_with_concl_subset. apply LevelSet.equal_spec in e. rewrite e. exact om. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. @@ -5804,7 +5538,7 @@ Transparent lexprod_rel_wf. Lemma add_prems_0 u : add_prems 0 u = u. Proof. rewrite /add_prems. - apply eq_univ'. + apply eq_univ_equal. intros x. rewrite map_spec. split. - intros[e [hin ->]]. unfold add_expr. now destruct e; rewrite Nat.add_0_r. @@ -5900,7 +5634,6 @@ Definition min_model_map (m : model) cls : model := LevelExprSet.fold (fun '(l, k) acc => add_max l k acc) cl (add_max (levelexpr_level concl) 0 acc)) cls m. - Lemma In_add_max l l' k acc : LevelMap.In (elt:=nat) l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). @@ -5946,61 +5679,6 @@ Proof. right. intuition eauto. Qed. -Definition opt_max (x y : option nat) : option nat := - match x, y with - | Some x, Some y => Some (Nat.max x y) - | None, Some x => Some x - | Some x, None => Some x - | None, None => None - end. - -Definition find_max (ls : LevelExprSet.t) (l : Level.t) := - LevelExprSet.fold (fun '(l', k) acc => if eqb l l' then opt_max (Some k) acc else acc) ls None. - -Inductive find_max_spec ls l : option nat -> Prop := -| find_max_ex m : LevelExprSet.In (l, m) ls -> (forall k, LevelExprSet.In (l, k) ls -> k <= m) -> find_max_spec ls l (Some m) -| find_max_absent : ~ (exists k, LevelExprSet.In (l, k) ls) -> find_max_spec ls l None. - -Lemma find_max_correct ls l : find_max_spec ls l (find_max ls l). -Proof. - unfold find_max. - apply: (LevelExprSetProp.fold_rec (P := fun ls a => find_max_spec ls l a)). - - intros s' ise; constructor. intros [k hin]. now apply ise in hin. - - intros x a s' s'' hin hnotin hadd hspec. - destruct x as [l' k]. - destruct (eqb_spec l l'); subst. - * depelim hspec. - { constructor. destruct (Nat.max_spec k m) as [[hle hm]|[hle hm]]. - + rewrite hm. apply hadd; right; apply H. - + rewrite hm. apply hadd; left; reflexivity. - + intros k' hin'. apply hadd in hin' as []. - { noconf H1. lia. } - { specialize (H0 _ H1). lia. } } - { constructor. apply hadd; now left. - intros k0 hin'. apply hadd in hin' as []. - { noconf H0; reflexivity. } - { elim H. now exists k0. } } - * depelim hspec; constructor; eauto. - + apply hadd; now right. - + intros k' hin'. apply hadd in hin' as []. - { noconf H2. congruence. } - now apply H0 in H2. - + intros [k0 hk0]. apply hadd in hk0 as []. - { noconf H1; congruence. } - apply H. now exists k0. -Qed. - -Definition update_max acc l k0 := - option_map2 Nat.max (level_value acc l) (Some k0). - -(* Lemma update_max_spec acc l k : update_max acc l k0 = *) - -Definition maximal_pre (l : Level.t) (n : nat) les := - forall n', In (l, n') les -> n' <= n. - -Definition maximal_map (l : Level.t) (n : nat) m := - forall n', LevelMap.MapsTo l (Some n') m -> (n' <= Z.of_nat n)%Z. - Lemma In_fold_add_max k n a : LevelMap.In (elt:=nat) k (LevelExprSet.fold @@ -6025,7 +5703,6 @@ Proof. right. now left; exists k''. right; right. apply H3. Qed. - Lemma MapsTo_fold_add_max l n a : let map := LevelExprSet.fold (fun '(l, k0) acc => add_max l k0 acc) n a in (forall k, LevelMap.MapsTo (elt:=nat) l k map -> @@ -6130,23 +5807,29 @@ Qed. Definition maximal_prem l n cls := Clauses.For_all (fun cl => forall n', LevelExprSet.In (l, n') (premise cl) -> n' <= n) cls. +(* Definition max_clause_premise_of l (cls : clauses) := + Clauses.fold (fun cl acc => Nat.max (premise_max (premise cl)) acc) cls 0%nat. *) + +(* Definition enabled_premises_map cls : model := + let max := max_clause_premise cls in + let ls := clauses_levels cls in + LevelSet.fold (fun l acc => LevelMap.add l max acc) ls (LevelMap.empty _). *) + Lemma min_model_mapsto_gen m cls : forall l, LevelSet.In l (clauses_levels cls) -> exists k, LevelMap.MapsTo l k (min_model_map m cls) /\ (exists cl, Clauses.In cl cls /\ exists n, k = n /\ LevelExprSet.In (l,n) (premise cl) /\ - (* (forall cl', Clauses.In cl cls -> forall l k, LevelExprSet.In (l, k) (premise cl') -> k <= n) *) + maximal_prem l n cls) \/ LevelMap.MapsTo l k m. Proof. rewrite /min_model_map. + intros l. eapply ClausesProp.fold_rec. - - intros s' he. intuition auto. admit. - - intros x a s' s'' inx ninx hadd ih. - destruct x as [prem cl]. - intros. - Admitted. -(* - pose proof (MapsTo_fold_add_max l prem (add_max cl 0 a)) as [hf hneq]. + - intros. admit. + - intros x a s' s'' hin hnin hadd ih hin''. + destruct x as [prem concl]. + pose proof (MapsTo_fold_add_max l prem (add_max concl 0 a)) as [hf hneq]. apply hf in H. clear hf. destruct H as [[kl [inkl leq]]|]. { destruct leq as [eq [leqprems leqacc]]; noconf eq. @@ -6215,25 +5898,6 @@ Proof. - apply is_update_of_empty. Qed. -(* Lemma valuation_of_model_pos l k model : LevelMap.MapsTo l (Z.to_nat k) (valuation_of_model model) -> (k >= 0)%Z. -Proof. - unfold valuation_of_model. - revert l k. - eapply LevelMapFact.fold_rec. - - intros. now rewrite LevelMapFact.F.empty_mapsto_iff in H0. - - intros l0 k0 e m' m'' me nk hadd hind l k. - rewrite LevelMapFact.F.add_mapsto_iff. - intros []. - * destruct H. red in H; subst. - destruct k0. - { have hmax := (model_max_spec model l (Some z) me). depelim hmax. - have hmin := (model_min_spec model l (Some z) me). depelim hmin. - assert (0 <= model_max model)%Z. admit. - assert (model_min model <= 0)%Z. admit. - assert (model_max model - option_get 0%Z (Some z) - model_min model = k)%Z. admit. - cbn in H4. - lia. *) - Local Open Scope string_scope2. Definition print_level_Z_map (m : LevelMap.t (option Z)) := @@ -6416,7 +6080,15 @@ Definition correct_model (cls : clauses) (m : model) := Definition infer_correctness cls := forall m, infer_model cls = Some m -> correct_model cls m. Lemma enabled_clauses_ext m m' cls : m ⩽ m' -> enabled_clauses m cls -> enabled_clauses m' cls. -Proof. Admitted. +Proof. + intros hext. + rewrite /enabled_clauses. + intros ha cl; move/ha. + unfold enabled_clause. + intros [minp [heq hge]]. + have hp := min_premise_pres (premise cl) hext. + rewrite heq in hp. depelim hp. exists y. split => //; lia. +Qed. Lemma interp_prems_ge v (prems : nonEmptyLevelExprSet) : forall prem, LevelExprSet.In prem prems -> @@ -6438,6 +6110,7 @@ Proof. * specialize (IHl H). lia. Qed. +(** Enabled and valid clauses are satisfied by valuation *) Lemma valid_clause_model model cl : enabled_clause model cl -> valid_clause model cl -> @@ -6483,15 +6156,12 @@ Lemma infer_correct cls : infer_correctness cls. Proof. intros m. funelim (infer_model cls) => //. - intros [= <-]. clear Heq Heqcall. destruct vm as [model ofV isupd clsconcl ism]; cbn in *. + intros [= <-]. + set (obl := infer_model_obligation_1 cls). clearbody obl. + clear Heq Heqcall. + have mincl := model_incl vm. + destruct vm as [model ofV isupd clsconcl ism]; cbn in *. set (V := clauses_levels cls) in *. - assert (model_of V model). - { intros l inl. eapply is_update_of_ext in isupd as mext. red in mext. - (* eapply clauses_levels_spec in inl as [cl [hcl hin]]. *) - unfold init_model in mext. - have [kmin [hm incl]] := min_model_mapsto cls l inl. - eapply mext in hm as [kmodel [mapmodel hmodel]]. - now exists kmodel. } unfold correct_model. have encl : enabled_clauses model cls. { eapply enabled_clauses_ext. apply is_update_of_ext in isupd. exact isupd. From f71a91d5639aa03c226f06711bdd087f85830fc4 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 28 Aug 2025 23:52:35 +0200 Subject: [PATCH 025/164] Decidability of inference / satisfiability completed --- template-rocq/theories/Junk.v | 213 ++++++ template-rocq/theories/PartialLoopChecking.v | 703 ++++++++++--------- 2 files changed, 591 insertions(+), 325 deletions(-) diff --git a/template-rocq/theories/Junk.v b/template-rocq/theories/Junk.v index b0350f7a4..532e4d24c 100644 --- a/template-rocq/theories/Junk.v +++ b/template-rocq/theories/Junk.v @@ -320,3 +320,216 @@ Proof. move/level_value_MapsTo => ->. reflexivity. Qed. *) + + +Definition add_max l k m := + match LevelMap.find l m with + | Some k' => + if (k' LevelMap.add l k m + end. + +Definition min_model_map (m : model) cls : model := + Clauses.fold (fun '(cl, concl) acc => + LevelExprSet.fold (fun '(l, k) acc => + add_max l k acc) cl (add_max (levelexpr_level concl) 0 acc)) cls m. + +Lemma In_add_max l l' k acc : + LevelMap.In (elt:=nat) l (add_max l' k acc) <-> + (l = l' \/ LevelMap.In l acc). +Proof. + unfold add_max. + destruct LevelMap.find eqn:hl. + - case: Nat.ltb_spec. + + rewrite LevelMapFact.F.add_in_iff /Level.eq. + firstorder eauto. + + intros. intuition auto. subst. + now rewrite LevelMapFact.F.in_find_iff hl. + - LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. +Qed. + +Definition is_max k' k l acc := + match LevelMap.find l acc with + | Some k'' => k' = Nat.max k k'' + | _ => k' = k + end. + + +Definition min_model_map (m : model) cls : model := + Clauses.fold (fun '(cl, concl) acc => + LevelExprSet.fold (fun '(l, k) acc => + add_max l k acc) cl (add_max (levelexpr_level concl) 0 acc)) cls m. + +Lemma MapsTo_add_max l l' k k' acc : + LevelMap.MapsTo (elt:=nat) l k' (add_max l' k acc) <-> + if eqb l l' then is_max k' k l acc else LevelMap.MapsTo l k' acc. +Proof. + unfold add_max. + destruct LevelMap.find eqn:hl. + { case: Nat.ltb_spec. + - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. + destruct (eqb_spec l l'). + { unfold is_max. + firstorder eauto. subst k' l'. rewrite hl. f_equal. lia. congruence. subst l'. + rewrite hl in H0. subst k'. + left. split; auto. f_equal; lia. } + intros. firstorder eauto. congruence. + - intros. unfold is_max. + destruct (eqb_spec l l'); subst. rewrite hl. firstorder eauto. apply LevelMap.find_1 in H. rewrite hl in H. noconf H. + f_equal; lia. subst k'. apply LevelMap.find_2. rewrite hl. f_equal. f_equal. lia. reflexivity. + } + - rewrite LevelMapFact.F.add_mapsto_iff. intuition auto; subst. + destruct (eqb_spec l l'); subst. unfold is_max. now rewrite hl. congruence. + destruct (eqb_spec l l'); subst. unfold is_max. now rewrite hl. congruence. + destruct (eqb_spec l l'); subst. unfold is_max in H; rewrite hl in H. subst k'. left; intuition eauto. reflexivity. + right. intuition eauto. +Qed. + +Lemma In_fold_add_max k n a : + LevelMap.In (elt:=nat) k + (LevelExprSet.fold + (fun '(l, k0) acc => add_max l k0 acc) n a) <-> + (LevelSet.In k (levels n)) \/ LevelMap.In k a. +Proof. + eapply LevelExprSetProp.fold_rec. + - intros s' he. + rewrite (LevelExprSetProp.empty_is_empty_1 he). + cbn. unfold levels. rewrite LevelExprSetProp.fold_empty. rewrite LevelSetFact.empty_iff. intuition auto. + - intros. + destruct x as [l k']. + rewrite In_add_max. + rewrite H2 !levelexprset_levels_spec. + split. + * intros []; subst. + left. exists k'. apply H1. now left. + destruct H3 as [[k'' ?]|?]. left; exists k''. apply H1. now right. + now right. + * red in H1. setoid_rewrite H1. + intros [[k'' []]|]. noconf H3. now left. + right. now left; exists k''. right; right. apply H3. +Qed. + +Lemma MapsTo_fold_add_max l n a : + let map := LevelExprSet.fold (fun '(l, k0) acc => add_max l k0 acc) n a in + (forall k, LevelMap.MapsTo (elt:=nat) l k map -> + ((exists kl, LevelExprSet.In (l, kl) n /\ kl = k /\ + (forall kl', LevelExprSet.In (l, kl') n -> kl' <= kl) /\ + (forall kl', LevelMap.MapsTo l kl' a -> kl' <= kl)) \/ + (LevelMap.MapsTo l k a /\ (forall kl', LevelExprSet.In (l, kl') n -> kl' <= k)))) + /\ (forall l, ~ LevelMap.In l map -> ~ (exists k, LevelExprSet.In (l, k) n) /\ ~ (LevelMap.In l a)). +Proof. + eapply LevelExprSetProp.fold_rec. + - intros s' he. cbn. + setoid_rewrite (LevelExprSetProp.empty_is_empty_1 he). + intuition auto. right. split; eauto. + intros kl. now move/LevelExprSet.empty_spec. + destruct H0. now apply LevelExprSet.empty_spec in H0. + (* destruct H0 as [? [he' _]]. now rewrite LevelExprSetFact.empty_iff in he'. *) + - cbn; intros. + destruct x as [xl k']. split. + 2:{ intros l0 hnin. destruct H2 as [_ H2]. specialize (H2 l0). split. + { intros [k hex]. eapply H1 in hex as [hin|hin]. noconf hin. apply hnin. + eapply In_add_max. now left. + unshelve eapply (proj1 (H2 _)). + intros hin'. apply hnin. rewrite In_add_max. now right. now exists k. } + { apply H2 => hin. elim hnin. rewrite In_add_max. now right. } } + intros. + rewrite MapsTo_add_max in H3. + destruct (eqb_spec l xl); subst. + * unfold is_max in H3 at 1. + destruct LevelMap.find eqn:hfind. + { subst k. pose proof (LevelMap.find_2 hfind). destruct H2 as [H2 Hnotin]. destruct (H2 _ H3). + left. destruct H4 as [kl [hkl hleq]]. destruct hleq as [hleq hmax]. subst n0. + destruct (Nat.max_spec k' kl) as [[]|[]]. + { exists kl. split. apply H1. now right. split. f_equal. lia. split. intros. + apply H1 in H6 as []. noconf H6. lia. now apply (proj1 hmax). destruct hmax as [_ hmax]. + intros. now apply hmax. } + { exists k'. split. apply H1. now left. split. f_equal; lia. destruct hmax as [hmax hmax']; split. + intros kl' hin. apply H1 in hin as []; subst. noconf H6. lia. specialize (hmax _ H6). lia. + intros. transitivity kl. now apply hmax'. lia. } + destruct (H2 _ H3) as [[kl [hkl hleq]]|]. noconf hleq. + destruct hleq as [hleq hmax]. subst n0. + destruct (Nat.max_spec k' kl) as [[]|[]]. + { left. exists kl. split. apply H1. now right. destruct hmax as [hmax hmax']. split. f_equal. lia. split. + intros. apply H1 in H7 as []. noconf H7. lia. now apply hmax. apply hmax'. } + { left. exists k'. split. apply H1. now left. destruct hmax as [hmax hmax']. split. f_equal. lia. split. + intros kl' hin. apply H1 in hin as []. noconf H7. lia. specialize (hmax _ H7). lia. + intros. transitivity kl => //. now eapply hmax'. } + destruct H4. clear H5. + destruct (Nat.max_spec k' n0) as [[]|[]]. + { right. split. now rewrite H7. + intros kl' hin. apply H1 in hin as [hin|hin]; noconf hin. lia. + specialize (H6 _ hin). depelim H6; lia. } + { left. exists k'. split. apply H1. now left. split. f_equal. lia. split. + intros kl' hin. apply H1 in hin as []. noconf H8. lia. + specialize (H6 _ H8). lia. + intros. transitivity n0. 2: lia. eapply (LevelMapFact.F.MapsTo_fun H4) in H8. subst kl'. reflexivity. } + } + subst k. left. exists k'. split; eauto. firstorder. split. reflexivity. + destruct H2 as [hl hnotin]. eapply LevelMapFact.F.not_find_in_iff in hfind. + apply hnotin in hfind as hfind'. + split. + { intros. eapply H1 in H2 as [hin|hin]; noconf hin. reflexivity. + destruct hfind' as [hfind' _]. + elim hfind'. now exists kl'. } + { intros kl' hin. destruct hfind' as []. now elim H3; exists kl'. } + * destruct H2 as [H2 hfind]. destruct (H2 _ H3) as [[lk [hkl hleq]]|]. + + left. depelim hleq. destruct H6 as [hinl hinacc]. exists lk. split; [firstorder|]. split => //. + split => //. + { intros kl' hin. apply H1 in hin as [hin|hin]. noconf hin. congruence. subst k. now apply hinl. } + + right. intuition auto. + eapply H1 in H5 as [hin|hin]; noconf hin. congruence. + now eapply H7. +Qed. + + +Lemma min_model_map_levels m cls k : + LevelMap.In k (min_model_map m cls) <-> + LevelSet.In k (clauses_levels cls) \/ LevelMap.In k m. +Proof. + rewrite /min_model_map. + rewrite clauses_levels_spec. + eapply ClausesProp.fold_rec. + - intros s' he. intuition auto. + destruct H0 as [cl []]. + clsets. + - intros x a s' s'' inx ninx hadd ih. + destruct x as [cl k']. + rewrite In_fold_add_max In_add_max. rewrite ih. + intuition auto. left. exists (cl, k'); intuition auto. + apply hadd. now left. + rewrite clause_levels_spec. now left. + subst. left. exists (cl, k'). split. apply hadd; now left. + rewrite clause_levels_spec. now right. + destruct H as [cl'' []]. left. exists cl''. + intuition auto. apply hadd. now right. + destruct H3 as [cl'' []]. + apply hadd in H0 as []; subst. + rewrite clause_levels_spec in H3. destruct H3; subst. + cbn in H0. now left. right. now left. + right. right. left; exists cl''. split => //. +Qed. + +Lemma premises_model_map_levels m cls k : + LevelMap.In k (premises_model_map m cls) <-> + LevelSet.In k (clauses_premises_levels cls) \/ LevelMap.In k m. +Proof. + rewrite /premises_model_map. + rewrite clauses_premises_levels_spec. + eapply ClausesProp.fold_rec. + - intros s' he. intuition auto. + destruct H0 as [cl []]. + clsets. + - intros x a s' s'' inx ninx hadd ih. + destruct x as [cl k']. + rewrite In_fold_add_max ih. + intuition auto. + * left. exists (cl, k'); intuition auto. + apply hadd. now left. + * destruct H as [cl'' []]. left. exists cl''. + intuition auto. apply hadd. now right. + * destruct H3 as [cl'' []]. + apply hadd in H0 as []; subst. + now left. right. now left. +Qed. diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index fc1a3e0b5..d83680cef 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -334,26 +334,25 @@ Module NonEmptySetFacts. apply or_iff_compat_l. apply in_rev. Qed. - Definition map (f : LevelExpr.t -> LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := - let '(e, l) := to_nonempty_list u in - add_list (List.map f l) (singleton (f e)). + Program Definition map (f : LevelExpr.t -> LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + {| t_set := LevelExprSetProp.of_list (List.map f (LevelExprSet.elements u)) |}. + Next Obligation. + have hs := to_nonempty_list_spec u. + destruct (to_nonempty_list u). rewrite -hs. cbn. + apply not_Empty_is_empty => he. apply (he (f t)). + lesets. + Qed. Lemma map_spec f u e : LevelExprSet.In e (map f u) <-> exists e0, LevelExprSet.In e0 u /\ e = (f e0). Proof. - unfold map. symmetry. etransitivity. - { eapply iff_ex; intro. eapply and_iff_compat_r. eapply In_to_nonempty_list. } - destruct (to_nonempty_list u) as [e' l]; cbn in *. - symmetry. etransitivity. eapply add_list_spec. - etransitivity. eapply or_iff_compat_l. apply LevelExprSet.singleton_spec. - etransitivity. eapply or_iff_compat_r. - apply in_map_iff. clear u. split. - - intros [[e0 []]|H]. - + exists e0. split. right; tas. congruence. - + exists e'. split; tas. left; reflexivity. - - intros [xx [[H|H] ?]]. - + right. congruence. - + left. exists xx. split; tas; congruence. + unfold map; cbn. + rewrite LevelExprSetProp.of_list_1 InA_In_eq in_map_iff. + split. + - intros [x [<- hin]]. exists x. split => //. + rewrite -InA_In_eq in hin. now apply LevelExprSet.elements_spec1 in hin. + - intros [x [hin ->]]. exists x. split => //. + rewrite -InA_In_eq. now apply LevelExprSet.elements_spec1. Qed. Program Definition non_empty_union (u v : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := @@ -2375,14 +2374,6 @@ Proof. intros ih hv k. now rewrite hv. Qed. -Lemma model_of_sub V m : model_of V m -> model_of V m. -Proof. - rewrite /model_of /model_of. - intros H k hin. specialize (H k hin) as [? ?]. - now exists x. -Qed. -Coercion model_of_sub : model_of >-> model_of. - Lemma clauses_conclusions_subset {cls cls'} : Clauses.Subset cls cls' -> clauses_conclusions cls ⊂_lset clauses_conclusions cls'. @@ -2651,7 +2642,7 @@ Qed. Lemma add_prems_add_prems n n' lk : add_prems n (add_prems n' lk) = add_prems (n + n') lk. Proof. destruct lk; unfold add_prems. rewrite map_map. apply eq_univ_equal. - intros x; rewrite /= !map_spec. cbn in *. + intros x. rewrite !map_spec. cbn in *. firstorder eauto. subst. exists x0. firstorder eauto. now rewrite add_expr_add_expr. subst. exists x0. @@ -2671,10 +2662,19 @@ Notation succ_expr := (add_expr 1). Notation succ_prems := (add_prems 1). Notation succ_clause := (add_clause 1). +Arguments add_prems : simpl never. + +Lemma pair_inj {A B} (x x' : A) (y y' : B) P : + (x = x' -> y = y' -> P) -> + ((x, y) = (x', y') -> P). +Proof. + now intros h [=]. +Qed. + Lemma add_clause_inj {n x y} : add_clause n x = add_clause n y -> x = y. Proof. - destruct x as [prems concl], y as [prems' concl']. - now move=> [=] /add_prems_inj -> /add_expr_inj ->. + destruct x as [prems concl], y as [prems' concl']. cbn. + apply: pair_inj. now move=> /add_prems_inj -> /add_expr_inj ->. Qed. Definition add_clauses n cls := ClausesProp.of_list (List.map (fun cl => add_clause n cl) (ClausesProp.to_list cls)). Notation succ_clauses := (add_clauses 1). @@ -4864,8 +4864,6 @@ Proof. now eapply is_update_of_strictly_updates. Qed. -Axiom todo : forall {A}, A. - Lemma opt_le_lt_trans {x y z} : opt_le Z.le x y -> opt_le Z.lt y z -> opt_le Z.lt x z. Proof. destruct 1; intros H'; depelim H'; constructor. lia. @@ -5180,7 +5178,7 @@ Lemma of_level_map_of_level_set cls sel V m hne hne' : V =_lset sel cls -> of_level_map m hne = of_level_set V (max_clause_premise cls) hne'. Proof. - move=> mp hv. apply: eq_univ_equal => [[l k]]. + move=> mp hv. apply: (proj1 (eq_univ_equal _ _)) => [[l k]]. rewrite of_level_map_spec levelexprset_of_levels_spec. split. red in mp. move/(proj2 mp l) => [hin eq]. split. 2:lia. lsets. @@ -5349,7 +5347,7 @@ Qed. Lemma of_level_set_singleton l k hne : of_level_set (LevelSet.singleton l) k hne = singleton (l, k). Proof. - apply: eq_univ_equal. move=> [l' k']. + apply eq_univ_equal. move=> [l' k']. rewrite /of_level_set //= levelexprset_of_levels_spec !LevelExprSet.singleton_spec LevelSet.singleton_spec /LevelSet.E.eq /LevelExprSet.E.eq. firstorder subst => //. now noconf H. now noconf H. Qed. @@ -5621,264 +5619,80 @@ Qed. We also ensure that all levels in the conclusions are in the model. *) -Definition add_max l k m := - match LevelMap.find l m with - | Some k' => - if (k' LevelMap.add l k m - end. - -Definition min_model_map (m : model) cls : model := - Clauses.fold (fun '(cl, concl) acc => - LevelExprSet.fold (fun '(l, k) acc => - add_max l k acc) cl (add_max (levelexpr_level concl) 0 acc)) cls m. - -Lemma In_add_max l l' k acc : - LevelMap.In (elt:=nat) l (add_max l' k acc) <-> - (l = l' \/ LevelMap.In l acc). -Proof. - unfold add_max. - destruct LevelMap.find eqn:hl. - - case: Nat.ltb_spec. - + rewrite LevelMapFact.F.add_in_iff /Level.eq. - firstorder eauto. - + intros. intuition auto. subst. - now rewrite LevelMapFact.F.in_find_iff hl. - - LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. -Qed. +Definition maximal_prem l n cls := + Clauses.For_all (fun cl => forall n', LevelExprSet.In (l, n') (premise cl) -> n' <= n) cls. -Definition is_max k' k l acc := - match LevelMap.find l acc with - | Some k'' => k' = Nat.max k k'' - | _ => k' = k - end. +Definition max_premise_of l (u : univ) : nat := + LevelExprSet.fold (fun '(l', k) acc => if eqb l l' then Nat.max k acc else acc) u 0. -Lemma MapsTo_add_max l l' k k' acc : - LevelMap.MapsTo (elt:=nat) l k' (add_max l' k acc) <-> - if eqb l l' then is_max k' k l acc else LevelMap.MapsTo l k' acc. -Proof. - unfold add_max. - destruct LevelMap.find eqn:hl. - { case: Nat.ltb_spec. - - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. - destruct (eqb_spec l l'). - { unfold is_max. - firstorder eauto. subst k' l'. rewrite hl. f_equal. lia. congruence. subst l'. - rewrite hl in H0. subst k'. - left. split; auto. f_equal; lia. } - intros. firstorder eauto. congruence. - - intros. unfold is_max. - destruct (eqb_spec l l'); subst. rewrite hl. firstorder eauto. apply LevelMap.find_1 in H. rewrite hl in H. noconf H. - f_equal; lia. subst k'. apply LevelMap.find_2. rewrite hl. f_equal. f_equal. lia. reflexivity. - } - - rewrite LevelMapFact.F.add_mapsto_iff. intuition auto; subst. - destruct (eqb_spec l l'); subst. unfold is_max. now rewrite hl. congruence. - destruct (eqb_spec l l'); subst. unfold is_max. now rewrite hl. congruence. - destruct (eqb_spec l l'); subst. unfold is_max in H; rewrite hl in H. subst k'. left; intuition eauto. reflexivity. - right. intuition eauto. -Qed. - -Lemma In_fold_add_max k n a : - LevelMap.In (elt:=nat) k - (LevelExprSet.fold - (fun '(l, k0) acc => add_max l k0 acc) n a) <-> - (LevelSet.In k (levels n)) \/ LevelMap.In k a. -Proof. - eapply LevelExprSetProp.fold_rec. - - intros s' he. - rewrite (LevelExprSetProp.empty_is_empty_1 he). - cbn. unfold levels. rewrite LevelExprSetProp.fold_empty. rewrite LevelSetFact.empty_iff. intuition auto. - - intros. - destruct x as [l k']. - rewrite In_add_max. - rewrite H2 !levelexprset_levels_spec. - split. - * intros []; subst. - left. exists k'. apply H1. now left. - destruct H3 as [[k'' ?]|?]. left; exists k''. apply H1. now right. - now right. - * red in H1. setoid_rewrite H1. - intros [[k'' []]|]. noconf H3. now left. - right. now left; exists k''. right; right. apply H3. -Qed. - -Lemma MapsTo_fold_add_max l n a : - let map := LevelExprSet.fold (fun '(l, k0) acc => add_max l k0 acc) n a in - (forall k, LevelMap.MapsTo (elt:=nat) l k map -> - ((exists kl, LevelExprSet.In (l, kl) n /\ kl = k /\ - (forall kl', LevelExprSet.In (l, kl') n -> kl' <= kl) /\ - (forall kl', LevelMap.MapsTo l kl' a -> kl' <= kl)) \/ - (LevelMap.MapsTo l k a /\ (forall kl', LevelExprSet.In (l, kl') n -> kl' <= k)))) - /\ (forall l, ~ LevelMap.In l map -> ~ (exists k, LevelExprSet.In (l, k) n) /\ ~ (LevelMap.In l a)). +Lemma max_premise_of_spec l k (u : univ) : LevelExprSet.In (l, k) u -> k <= max_premise_of l u. Proof. + rewrite /max_premise_of. eapply LevelExprSetProp.fold_rec. - - intros s' he. cbn. - setoid_rewrite (LevelExprSetProp.empty_is_empty_1 he). - intuition auto. right. split; eauto. - intros kl. now move/LevelExprSet.empty_spec. - destruct H0. now apply LevelExprSet.empty_spec in H0. - (* destruct H0 as [? [he' _]]. now rewrite LevelExprSetFact.empty_iff in he'. *) - - cbn; intros. - destruct x as [xl k']. split. - 2:{ intros l0 hnin. destruct H2 as [_ H2]. specialize (H2 l0). split. - { intros [k hex]. eapply H1 in hex as [hin|hin]. noconf hin. apply hnin. - eapply In_add_max. now left. - unshelve eapply (proj1 (H2 _)). - intros hin'. apply hnin. rewrite In_add_max. now right. now exists k. } - { apply H2 => hin. elim hnin. rewrite In_add_max. now right. } } - intros. - rewrite MapsTo_add_max in H3. - destruct (eqb_spec l xl); subst. - * unfold is_max in H3 at 1. - destruct LevelMap.find eqn:hfind. - { subst k. pose proof (LevelMap.find_2 hfind). destruct H2 as [H2 Hnotin]. destruct (H2 _ H3). - left. destruct H4 as [kl [hkl hleq]]. destruct hleq as [hleq hmax]. subst n0. - destruct (Nat.max_spec k' kl) as [[]|[]]. - { exists kl. split. apply H1. now right. split. f_equal. lia. split. intros. - apply H1 in H6 as []. noconf H6. lia. now apply (proj1 hmax). destruct hmax as [_ hmax]. - intros. now apply hmax. } - { exists k'. split. apply H1. now left. split. f_equal; lia. destruct hmax as [hmax hmax']; split. - intros kl' hin. apply H1 in hin as []; subst. noconf H6. lia. specialize (hmax _ H6). lia. - intros. transitivity kl. now apply hmax'. lia. } - destruct (H2 _ H3) as [[kl [hkl hleq]]|]. noconf hleq. - destruct hleq as [hleq hmax]. subst n0. - destruct (Nat.max_spec k' kl) as [[]|[]]. - { left. exists kl. split. apply H1. now right. destruct hmax as [hmax hmax']. split. f_equal. lia. split. - intros. apply H1 in H7 as []. noconf H7. lia. now apply hmax. apply hmax'. } - { left. exists k'. split. apply H1. now left. destruct hmax as [hmax hmax']. split. f_equal. lia. split. - intros kl' hin. apply H1 in hin as []. noconf H7. lia. specialize (hmax _ H7). lia. - intros. transitivity kl => //. now eapply hmax'. } - destruct H4. clear H5. - destruct (Nat.max_spec k' n0) as [[]|[]]. - { right. split. now rewrite H7. - intros kl' hin. apply H1 in hin as [hin|hin]; noconf hin. lia. - specialize (H6 _ hin). depelim H6; lia. } - { left. exists k'. split. apply H1. now left. split. f_equal. lia. split. - intros kl' hin. apply H1 in hin as []. noconf H8. lia. - specialize (H6 _ H8). lia. - intros. transitivity n0. 2: lia. eapply (LevelMapFact.F.MapsTo_fun H4) in H8. subst kl'. reflexivity. } - } - subst k. left. exists k'. split; eauto. firstorder. split. reflexivity. - destruct H2 as [hl hnotin]. eapply LevelMapFact.F.not_find_in_iff in hfind. - apply hnotin in hfind as hfind'. - split. - { intros. eapply H1 in H2 as [hin|hin]; noconf hin. reflexivity. - destruct hfind' as [hfind' _]. - elim hfind'. now exists kl'. } - { intros kl' hin. destruct hfind' as []. now elim H3; exists kl'. } - * destruct H2 as [H2 hfind]. destruct (H2 _ H3) as [[lk [hkl hleq]]|]. - + left. depelim hleq. destruct H6 as [hinl hinacc]. exists lk. split; [firstorder|]. split => //. - split => //. - { intros kl' hin. apply H1 in hin as [hin|hin]. noconf hin. congruence. subst k. now apply hinl. } - + right. intuition auto. - eapply H1 in H5 as [hin|hin]; noconf hin. congruence. - now eapply H7. + - intros s' he hin. now apply he in hin. + - intros x a s' s'' hin nin hadd hle. + intros hs''. destruct x. + apply hadd in hs'' as []. + * noconf H. rewrite eqb_refl. lia. + * elim: eqb_spec; try intros ->; + specialize (hle H); lia. Qed. +Definition max_clause_premise_of l (cls : clauses) := + Clauses.fold (fun cl acc => Nat.max (max_premise_of l (premise cl)) acc) cls 0%nat. -Lemma min_model_map_levels m cls k : - LevelMap.In k (min_model_map m cls) <-> - LevelSet.In k (clauses_levels cls) \/ LevelMap.In k m. +Lemma max_clause_premise_of_spec l k cls : + forall cl, Clauses.In cl cls -> LevelExprSet.In (l, k) (premise cl) -> k <= max_clause_premise_of l cls. Proof. - rewrite /min_model_map. - rewrite clauses_levels_spec. + rewrite /max_clause_premise_of => cl. eapply ClausesProp.fold_rec. - - intros s' he. intuition auto. - destruct H0 as [cl []]. - clsets. - - intros x a s' s'' inx ninx hadd ih. - destruct x as [cl k']. - rewrite In_fold_add_max In_add_max. rewrite ih. - intuition auto. left. exists (cl, k'); intuition auto. - apply hadd. now left. - rewrite clause_levels_spec. now left. - subst. left. exists (cl, k'). split. apply hadd; now left. - rewrite clause_levels_spec. now right. - destruct H as [cl'' []]. left. exists cl''. - intuition auto. apply hadd. now right. - destruct H3 as [cl'' []]. - apply hadd in H0 as []; subst. - rewrite clause_levels_spec in H3. destruct H3; subst. - cbn in H0. now left. right. now left. - right. right. left; exists cl''. split => //. + - intros s' he hin. now apply he in hin. + - intros x a s' s'' hin nin hadd hle. + intros hs''. destruct x. + apply hadd in hs'' as []. + * noconf H. cbn. move/max_premise_of_spec. lia. + * specialize (hle H); lia. Qed. -Definition maximal_prem l n cls := - Clauses.For_all (fun cl => forall n', LevelExprSet.In (l, n') (premise cl) -> n' <= n) cls. - -(* Definition max_clause_premise_of l (cls : clauses) := - Clauses.fold (fun cl acc => Nat.max (premise_max (premise cl)) acc) cls 0%nat. *) - -(* Definition enabled_premises_map cls : model := - let max := max_clause_premise cls in +Definition max_clause_premises cls : model := let ls := clauses_levels cls in - LevelSet.fold (fun l acc => LevelMap.add l max acc) ls (LevelMap.empty _). *) + let fn l m := LevelMap.add l (max_clause_premise_of l cls) m in + LevelSet.fold fn ls (LevelMap.empty _). -Lemma min_model_mapsto_gen m cls : - forall l, LevelSet.In l (clauses_levels cls) -> - exists k, LevelMap.MapsTo l k (min_model_map m cls) /\ - (exists cl, Clauses.In cl cls /\ - exists n, k = n /\ LevelExprSet.In (l,n) (premise cl) /\ - - maximal_prem l n cls) \/ LevelMap.MapsTo l k m. +Lemma max_clause_premises_spec l k cls : + LevelMap.MapsTo l k (max_clause_premises cls) -> LevelSet.In l (clauses_levels cls) /\ k = max_clause_premise_of l cls. Proof. - rewrite /min_model_map. - intros l. - eapply ClausesProp.fold_rec. - - intros. admit. - - intros x a s' s'' hin hnin hadd ih hin''. - destruct x as [prem concl]. - pose proof (MapsTo_fold_add_max l prem (add_max concl 0 a)) as [hf hneq]. - apply hf in H. clear hf. - destruct H as [[kl [inkl leq]]|]. - { destruct leq as [eq [leqprems leqacc]]; noconf eq. - destruct (Nat.ltb_spec kl ) - left. exists (prem, cl). split. apply hadd. now left. exists kl. - split => //. split => //. red. - intros x hin. apply hadd in hin as []; subst. cbn. exact leqprems. - intros n hin. - specialize (ih (Z.of_nat n)). destruct ih as [_ ih]. - forward ih. left. exists x. split => //. exists kl. split => //. - intros n' hin. - rewrite In_fold_add_max In_add_max. rewrite ih. - intuition auto. left. exists (cl, k'); intuition auto. - apply hadd. now left. - rewrite clause_levels_spec. now left. - subst. left. exists (cl, k'). split. apply hadd; now left. - rewrite clause_levels_spec. now right. - destruct H as [cl'' []]. left. exists cl''. - intuition auto. apply hadd. now right. - destruct H3 as [cl'' []]. - apply hadd in H0 as []; subst. - rewrite clause_levels_spec in H3. destruct H3; subst. - cbn in H0. now left. right. now left. - right. right. left; exists cl''. split => //. + unfold max_clause_premises. + eapply LevelSetProp.fold_rec. + - intros s' he hm. now rewrite LevelMapFact.F.empty_mapsto_iff in hm. + - intros x a s' s'' hin hnin hadd ih. + rewrite LevelMapFact.F.add_mapsto_iff. + intros [[-> <-]|[]] => //. + * split => //. apply hadd. now left. + * split => //. apply hadd; now right. now apply ih. Qed. -*) -Lemma min_model_mapsto cls : - forall l, LevelSet.In l (clauses_levels cls) -> - exists k, LevelMap.MapsTo l k (min_model_map (LevelMap.empty _) cls) /\ - (exists cl, Clauses.In cl cls /\ - exists n, k = n /\ LevelExprSet.In (l,n) (premise cl) /\ - (* (forall cl', Clauses.In cl cls -> forall l k, LevelExprSet.In (l, k) (premise cl') -> k <= n) *) - maximal_prem l n cls). + +Lemma max_clause_premises_spec_inv cls : + forall l, LevelSet.In l (clauses_levels cls) -> LevelMap.MapsTo l (max_clause_premise_of l cls) (max_clause_premises cls). Proof. - intros. - eapply (min_model_mapsto_gen (LevelMap.empty _)) in H as [k []]. - exists k. intuition eauto. - now eapply LevelMapFact.F.empty_mapsto_iff in H. + unfold max_clause_premises. + eapply LevelSetProp.fold_rec. + - intros s' he hm. now move/he. + - intros x a s' s'' hin hnin hadd ih l ls''. + rewrite LevelMapFact.F.add_mapsto_iff. + destruct (eq_dec x l). subst. + * now left. + * right. split => //. apply ih. eapply hadd in ls''. destruct ls''; auto. contradiction. Qed. -Definition min_model m cls : model := min_model_map m cls. - -Definition init_model cls := min_model (LevelMap.empty _) cls. +Definition init_model cls := max_clause_premises cls. Lemma init_model_levels cls k : LevelMap.In k (init_model cls) <-> LevelSet.In k (clauses_levels cls). Proof. - rewrite min_model_map_levels. intuition auto. - now rewrite LevelMapFact.F.empty_in_iff in H0. + split. + now move => [] k' /max_clause_premises_spec. + move/max_clause_premises_spec_inv. now eexists. Qed. Definition init_w (levels : LevelSet.t) : LevelSet.t := LevelSet.empty. @@ -5996,35 +5810,32 @@ Definition clauses_of_list := ClausesProp.of_list. Definition list_of_clauses := Clauses.elements. Definition valuation := LevelMap.t nat. -Definition premises_model_map (m : model) cls : model := - Clauses.fold (fun '(cl, concl) acc => - LevelExprSet.fold (fun '(l, k) acc => - add_max l k acc) cl acc) cls m. - +Definition add_max l k m := + match LevelMap.find l m with + | Some k' => + if (k' LevelMap.add l k m + end. -Lemma premises_model_map_levels m cls k : - LevelMap.In k (premises_model_map m cls) <-> - LevelSet.In k (clauses_premises_levels cls) \/ LevelMap.In k m. +Lemma In_add_max l l' k acc : + LevelMap.In (elt:=nat) l (add_max l' k acc) <-> + (l = l' \/ LevelMap.In l acc). Proof. - rewrite /premises_model_map. - rewrite clauses_premises_levels_spec. - eapply ClausesProp.fold_rec. - - intros s' he. intuition auto. - destruct H0 as [cl []]. - clsets. - - intros x a s' s'' inx ninx hadd ih. - destruct x as [cl k']. - rewrite In_fold_add_max ih. - intuition auto. - * left. exists (cl, k'); intuition auto. - apply hadd. now left. - * destruct H as [cl'' []]. left. exists cl''. - intuition auto. apply hadd. now right. - * destruct H3 as [cl'' []]. - apply hadd in H0 as []; subst. - now left. right. now left. + unfold add_max. + destruct LevelMap.find eqn:hl. + - case: Nat.ltb_spec. + + rewrite LevelMapFact.F.add_in_iff /Level.eq. + firstorder eauto. + + intros. intuition auto. subst. + now rewrite LevelMapFact.F.in_find_iff hl. + - LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. Qed. +Definition premises_model_map (m : model) cls : model := + Clauses.fold (fun '(cl, concl) acc => + LevelExprSet.fold (fun '(l, k) acc => + add_max l k acc) cl acc) cls m. Variant checking_result (cls : clauses) (cl : clause) : Type := | DoesNotHold : ~ entails cls cl -> checking_result cls cl @@ -6041,8 +5852,8 @@ Program Definition loop_check {V init cls} (m : valid_model V V init cls) (cl : loop (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 (premises_model V cl).2 _. Next Obligation. destruct m. split => //. - - apply todo. - - apply todo. + - apply (todo "incl"). + - apply (todo "only"). - apply is_update_of_empty. Qed. @@ -6077,7 +5888,11 @@ Definition enabled_clauses (m : model) (cls : clauses) := Definition correct_model (cls : clauses) (m : model) := enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. -Definition infer_correctness cls := forall m, infer_model cls = Some m -> correct_model cls m. +Definition infer_correctness cls := + match infer_model cls with + | Some m => correct_model cls m + | None => ~ exists v, clauses_sem v cls + end. Lemma enabled_clauses_ext m m' cls : m ⩽ m' -> enabled_clauses m cls -> enabled_clauses m' cls. Proof. @@ -6142,7 +5957,6 @@ Proof. eapply LevelMap.find_2 in findp. have premm := valuation_of_model_spec _ _ _ findp. unfold interp_level. - (* destruct premm as [vppos vpmap]. *) eapply LevelMap.find_1 in premm. rewrite premm. apply Nat.leb_le in hrel. assert (Z.to_nat (Z.of_nat n0 - Z.of_nat k') = n0 - k'). lia. rewrite H in hrel. @@ -6152,39 +5966,278 @@ Proof. lia. Qed. +Lemma init_model_enabled cls : enabled_clauses (init_model cls) cls. +Proof. + unfold enabled_clauses. + intros x hin. unfold enabled_clause. + pose proof (@min_premise_spec (init_model cls) (premise x)) as [premmin [prem [premin premeq]]]. + have inV : LevelSet.In prem (clauses_levels cls). + { rewrite clauses_levels_spec. exists x; split => //. rewrite /clause_levels. + eapply LevelSet.union_spec; left. rewrite levelexprset_levels_spec. exists prem.2. + destruct prem. exact premin. } + unfold init_model. rewrite premeq. unfold min_atom_value. + destruct prem as [l k]. + have hm := max_clause_premises_spec_inv cls l inV. + rewrite (level_value_MapsTo hm). + have hs := max_clause_premise_of_spec l k _ _ hin premin. + eexists; split => //. lia. +Qed. + +Lemma interp_add_expr V n e : interp_expr V (add_expr n e) = n + interp_expr V e. +Proof. + destruct e as [l k]; cbn. lia. +Qed. + +From Stdlib Require Import Structures.OrdersEx. + +Module Nat_as_OT. + Include OrdersEx.Nat_as_DT. + + Lemma eq_leibniz : forall x y, eq x y -> Logic.eq x y. + Proof. auto. Qed. + +End Nat_as_OT. + +Module NatSet := MSetList.MakeWithLeibniz Nat_as_OT. + +Definition interp_prems_nat V e := LevelExprSet.fold (fun e acc => NatSet.add (interp_expr V e) acc) e NatSet.empty. + +Lemma interp_prems_eq V (u : univ) : interp_prems V u = LevelExprSet.fold (fun e acc => Nat.max (interp_expr V e) acc) u 0. +Proof. + rewrite /interp_prems. + have he := to_nonempty_list_spec u. + destruct to_nonempty_list. + pose proof to_nonempty_list_spec'. + rewrite LevelExprSet.fold_spec. rewrite -he. cbn. unfold flip. + rewrite Nat.max_0_r. + rewrite -fold_left_rev_right. + rewrite Universes.fold_right_map (Universes.fold_right_map _ (interp_expr V)). + rewrite Universes.fold_right_assoc_comm. 1-2:lia. + now rewrite map_rev. +Qed. + +Lemma fold_right_comm_add_n n l : + l <> [] -> + n + fold_right Nat.max 0 l = fold_right Nat.max 0 (map (Nat.add n) l). +Proof. + induction l => //. + intros _. cbn. destruct l; cbn. + lia. cbn in IHl. rewrite -IHl. congruence. lia. +Qed. + +Lemma fold_right_comm_add_n' n l : + l <> [] -> + n + fold_right Nat.max 0 l = + fold_right (fun x acc => Nat.max (n + x) acc) 0 l. +Proof. + induction l => //. + intros _. cbn. destruct l; cbn. + lia. cbn in IHl. rewrite -IHl. congruence. lia. +Qed. + +Lemma fold_right_max_in {a l} n : In a l -> a <= fold_right Nat.max n l. +Proof. + induction l. + - now cbn. + - intros [eq|inl]. subst a0. cbn. lia. + cbn. specialize (IHl inl). lia. +Qed. + +Lemma fold_right_max_acc {n l} : n <= fold_right Nat.max n l. +Proof. + induction l. + - now cbn. + - cbn. lia. +Qed. + +Lemma fold_right_impl n l l' : + (forall x, In x l -> In x l') -> fold_right Nat.max n l <= fold_right Nat.max n l'. +Proof. + induction l in l' |- *. + - cbn. destruct l'; cbn. lia. + intros. have := @fold_right_max_acc n l'. lia. + - cbn; intros h. + have inal' := (h a (or_introl eq_refl)). + have := fold_right_max_in n inal'. + specialize (IHl l'). + forward IHl. + intros. apply h. now right. + lia. +Qed. + +Lemma fold_right_equivlist n l l' : + equivlistA eq l l' -> fold_right Nat.max n l = fold_right Nat.max n l'. +Proof. + intros eq. + have h := fold_right_impl n l l'. + forward h. intros x; rewrite -!InA_In_eq. apply eq. + have h' := fold_right_impl n l' l. + forward h'. intros x; rewrite -!InA_In_eq. apply eq. + lia. +Qed. + +Lemma interp_add_prems V n e : interp_prems V (add_prems n e) = n + interp_prems V e. +Proof. + rewrite !interp_prems_eq. + rewrite !LevelExprSetProp.fold_spec_right. + rewrite Universes.fold_right_map (Universes.fold_right_map _ (interp_expr V)). + rewrite fold_right_comm_add_n. + { have he := to_nonempty_list_spec e. + destruct to_nonempty_list. rewrite -he. cbn. rewrite map_app. + move/app_eq_nil. now intros []. } + apply fold_right_equivlist. + intros x. rewrite !InA_In_eq. + rewrite map_map_compose !map_rev -!In_rev. + rewrite !in_map_iff. + split. + - move=> [[l k] [<- hin]]. + apply InA_In_eq in hin. eapply LevelExprSet.elements_spec1 in hin. + eapply In_add_prems in hin as [[l' k'] []]. noconf H0. + eexists (l, k'); split. cbn. lia. + now apply InA_In_eq, LevelExprSet.elements_spec1. + - move=> [[l k] [<- hin]]. + apply InA_In_eq in hin. eapply LevelExprSet.elements_spec1 in hin. + eexists (l, k + n); split. cbn. lia. + apply InA_In_eq, LevelExprSet.elements_spec1. + eapply In_add_prems. exists (l, k); split => //. +Qed. + +Lemma interp_prems_singleton V e : + interp_prems V (singleton e) = interp_expr V e. +Proof. + rewrite /interp_prems. + now rewrite singleton_to_nonempty_list /=. +Qed. + +Lemma in_pred_closure_entails cls cl : + in_pred_closure cls cl -> + (forall V, clauses_sem V cls -> clause_sem V cl). +Proof. + induction 1. + - intros V. rewrite /clauses_sem. intros ha. + apply ha in H. + move: H; rewrite /clause_sem. + destruct cl as [prems concl]. + cbn. rewrite interp_add_prems. + destruct concl as [concl conclk]. + rewrite /add_expr; cbn. lia. + - intros V clsm. cbn. + rewrite interp_prems_singleton. + cbn. lia. +Qed. + +Lemma interp_prems_add V cl (u : univ) : + interp_prems V (add cl u) = Nat.max (interp_expr V cl) (interp_prems V u). +Proof. + rewrite !interp_prems_eq. unfold add. cbn. + destruct (LevelExprSetProp.In_dec cl u). + erewrite LevelExprSetProp.add_fold => //. 2-3:tc. 2:red; lia. + rewrite LevelExprSetProp.fold_spec_right. + rewrite (Universes.fold_right_map _ (interp_expr V)). + have leq : (interp_expr V cl <= fold_right (fun x acc : nat => Nat.max x acc) 0 + (map (interp_expr V) (rev (LevelExprSet.elements u)))). + { eapply fold_right_max_in. + apply in_map_iff. exists cl. split => //. + rewrite -In_rev. apply InA_In_eq. + now apply LevelExprSet.elements_spec1. } + lia. + unshelve erewrite LevelExprSetProp.fold_add => //. 1-2:tc. red; lia. +Qed. + +Lemma clauses_sem_subset {u u' : univ} : u ⊂_leset u' -> + forall V, interp_prems V u' >= interp_prems V u. +Proof. + intros hsub V. + rewrite !interp_prems_eq. red. + rewrite !LevelExprSetProp.fold_spec_right. + rewrite !(Universes.fold_right_map _ (interp_expr V)). + eapply fold_right_impl. intros x. + rewrite !in_map_iff. + intros [[l k] [<- hin]]. + exists (l, k). split => //. + apply In_rev, InA_In_eq in hin. apply (proj1 (In_rev _ _)), InA_In_eq. + eapply LevelExprSet.elements_spec1 in hin. + now eapply LevelExprSet.elements_spec1. +Qed. + +Lemma clauses_sem_entails {cls cl} : + entails cls cl -> + (forall V, clauses_sem V cls -> clause_sem V cl). +Proof. + induction 1. + - intros v clls. red. + destruct concl0 as [concl k]. + now have hge := interp_prems_ge v prems _ H. + - move=> V Hcls. + move: {IHentails} (IHentails _ Hcls). + unfold clause_sem. unfold ge => hyp. + etransitivity; tea. rewrite interp_prems_add. + rewrite interp_prems_add in hyp. + eapply in_pred_closure_entails in H; tea. + move: H; rewrite /clause_sem. unfold ge. + have ssub := clauses_sem_subset H1 V. lia. +Qed. + +Lemma clauses_sem_entails_all {cls prems concl} : + cls ⊢a prems → concl -> + (forall V, clauses_sem V cls -> interp_prems V prems >= interp_prems V concl). +Proof. + intros ha V hcls. + red in ha. + move: ha. + rewrite (interp_prems_eq _ concl); cbn. + destruct concl as [concl t_ne]; cbn. clear t_ne. + eapply LevelExprSetProp.fold_rec. + - lia. + - intros. + forward H2. intros ? hin. apply ha, H1. now right. + specialize (ha x). forward ha. apply H1. now left. cbn in ha. + eapply clauses_sem_entails in ha; tea. cbn in ha. lia. +Qed. + Lemma infer_correct cls : infer_correctness cls. Proof. - intros m. - funelim (infer_model cls) => //. - intros [= <-]. - set (obl := infer_model_obligation_1 cls). clearbody obl. - clear Heq Heqcall. - have mincl := model_incl vm. - destruct vm as [model ofV isupd clsconcl ism]; cbn in *. - set (V := clauses_levels cls) in *. - unfold correct_model. - have encl : enabled_clauses model cls. - { eapply enabled_clauses_ext. apply is_update_of_ext in isupd. exact isupd. - unfold enabled_clauses. - intros x hin. unfold enabled_clause. - pose proof (@min_premise_spec (init_model cls) (premise x)) as [premmin [prem [premin premeq]]]. - have inV : LevelSet.In prem (clauses_levels cls). - { rewrite clauses_levels_spec. exists x; split => //. rewrite /clause_levels. - eapply LevelSet.union_spec; left. rewrite levelexprset_levels_spec. exists prem.2. - destruct prem. exact premin. } - have [kmin [hm incl]] := min_model_mapsto cls prem inV. - unfold init_model. rewrite premeq. unfold min_atom_value. - destruct prem as [l k]. - eapply LevelMap.find_1 in hm. unfold level_value. rewrite hm. eexists; split; eauto. - destruct incl as [cl [hin' [n [heq' [hin'' maxp]]]]]. subst n. red in maxp. - eapply maxp in hin. eapply hin in premin. lia. } - split => //. - unfold clauses_sem. - intros cl hin. - eapply valid_clause_model. now eapply encl in hin. - eapply Clauses.for_all_spec in ism; tc. now specialize (ism _ hin). + unfold infer_correctness. + destruct infer_model as [m|] eqn:hi. + - (* Correct *) move: hi. + funelim (infer_model cls) => //. + intros [= <-]. + set (obl := infer_model_obligation_1 cls). clearbody obl. + clear Heq Heqcall. + have mincl := model_incl vm. + destruct vm as [model ofV isupd clsconcl ism]; cbn in *. + set (V := clauses_levels cls) in *. + unfold correct_model. + have encl : enabled_clauses model cls. + { eapply enabled_clauses_ext. apply is_update_of_ext in isupd. exact isupd. + apply init_model_enabled. } + split => //. + unfold clauses_sem. + intros cl hin. + eapply valid_clause_model. now eapply encl in hin. + eapply Clauses.for_all_spec in ism; tc. now specialize (ism _ hin). + - intros [v clssem]. + move: hi. + funelim (infer_model cls) => //. intros _. + red in islooping. + have sem := clauses_sem_entails_all islooping v0. + specialize (sem clssem). + rewrite interp_add_prems in sem. lia. Qed. +Section Completeness. + + Record semilattice := + { V : Type; + succ : V -> V; + max : V -> V -> V; + succ_max : forall x, succ (max x y) = max (x) + + } + + + + (* If a clause checks, then it should be valid in any extension of the model *) Lemma check_entails {V init cls} (m : valid_model V V init cls) (cl : clause) : check m cl = true -> forall m', model_model m ⩽ m' -> valid_clause m' cl. From 19eb5afec4d830fd2930ec9a332d143146d22d72 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 29 Aug 2025 19:04:26 +0200 Subject: [PATCH 026/164] Proven correctness of the checking algorithm --- template-rocq/theories/Junk.v | 59 +++ template-rocq/theories/PartialLoopChecking.v | 487 ++++++++++++++++--- 2 files changed, 475 insertions(+), 71 deletions(-) diff --git a/template-rocq/theories/Junk.v b/template-rocq/theories/Junk.v index 532e4d24c..e3cfc2831 100644 --- a/template-rocq/theories/Junk.v +++ b/template-rocq/theories/Junk.v @@ -533,3 +533,62 @@ Proof. apply hadd in H0 as []; subst. now left. right. now left. Qed. + + + +Section Completeness. + Reserved Notation "x ≡ y" (at level 90). + Record semilattice := + { carrier :> Type; + eq : carrier -> carrier -> Prop where "x ≡ y" := (eq x y); + succ : carrier -> carrier; + join : carrier -> carrier -> carrier; + join_assoc x y z : join x (join y z) ≡ join (join x y) z; + join_comm x y : join x y ≡ join y x; + join_idem x : join x x ≡ x; + join_sub x : join x (succ x) ≡ succ x; + succ_join : forall x y, succ (join x y) ≡ join (succ x) (succ y); + }. + + Notation "x ≡ y" := (eq _ x y). + + Section Derived. + Context (s : semilattice). + Definition le (x y : s) := join s x y ≡ y. + + Fixpoint add (x : s) n : s := + match n with + | 0 => x + | S n => succ _ (add x n) + end. + + End Derived. + + Definition term (V : Type) : Type := list (V * nat). + Definition relation (V : Type) := term V -> term V -> Prop. + + Record presented (V : Type) := { + terms : term V -> Prop; + relations : relation V }. + + Definition valid (V : Type) (C : presented V) (t u : term V) := relations _ C t u. + + Section Terms. + Context (V : Type) (pres : presented V). + Definition succV (t : term V) := map (fun '(x, n) => (x, S n)) t. + Definition maxV (t u : term V) := t ++ u. + + Definition presents : semilattice. + Proof. + unshelve refine {| carrier := term V; eq := relations _ pres; succ := succV; join := maxV |}. + all:apply (todo "laws"). + Defined. + + (* Definition interp_exp (vn : V * nat) : presents := let '(v, n) := vn in add presents v n. *) + Definition interp_term (t : term V) := + let '(hd, tl) := t in + List.fold_left (fun x n => join _ n (interp_exp x)) tl (interp_exp hd). + + Lemma all_terms (x : s) : exists t : term, + + diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index d83680cef..83b278bb6 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -2679,7 +2679,8 @@ Qed. Definition add_clauses n cls := ClausesProp.of_list (List.map (fun cl => add_clause n cl) (ClausesProp.to_list cls)). Notation succ_clauses := (add_clauses 1). Import SetoidList. -Lemma succ_clauses_spec cl cls : Clauses.In cl cls <-> Clauses.In (succ_clause cl) (succ_clauses cls). + +Lemma add_clauses_spec {cl cls} n : Clauses.In cl cls <-> Clauses.In (add_clause n cl) (add_clauses n cls). Proof. unfold succ_clauses. rewrite ClausesProp.of_list_1 InA_In_eq in_map_iff. @@ -2688,6 +2689,14 @@ Proof. - eapply Clauses_In_elements in H0. apply add_clause_inj in H. now subst. Qed. +Lemma in_add_clauses {cl cls} n : Clauses.In cl (add_clauses n cls) -> exists cl', Clauses.In cl' cls /\ cl = add_clause n cl'. +Proof. + unfold succ_clauses. + rewrite ClausesProp.of_list_1 InA_In_eq in_map_iff. + firstorder eauto. + exists x; split => //. unfold ClausesProp.to_list. now eapply Clauses_In_elements. +Qed. + Variant in_pred_closure cls : clause -> Prop := | incls cl n : Clauses.In cl cls -> in_pred_closure cls (add_clause n cl) | predcl x k : in_pred_closure cls (singleton (x, k + 1)%nat, (x, k)). @@ -2733,7 +2742,7 @@ Proof. { destruct cl as [prems'' concl'']. cbn in H0. noconf H0. rewrite add_prems_add_prems add_expr_add_expr add_clause_add_clause. now rewrite Nat.add_1_r. } - constructor. now rewrite -succ_clauses_spec. + constructor. now rewrite -add_clauses_spec. * have eq : (succ_prems (singleton (x, (k + 1)%nat))) = (singleton (x, k + 1 + 1)%nat). { apply eq_univ_equal. unfold succ_prems. intros le. rewrite map_spec LevelExprSet.singleton_spec. @@ -5833,9 +5842,9 @@ Proof. Qed. Definition premises_model_map (m : model) cls : model := - Clauses.fold (fun '(cl, concl) acc => - LevelExprSet.fold (fun '(l, k) acc => - add_max l k acc) cl acc) cls m. + let levels := clauses_premises_levels cls in + LevelSet.fold (fun l acc => + LevelMap.add l (max_clause_premise_of l cls) acc) levels m. Variant checking_result (cls : clauses) (cl : clause) : Type := | DoesNotHold : ~ entails cls cl -> checking_result cls cl @@ -5848,25 +5857,103 @@ Definition premises_model V cl : LevelSet.t * model := let levels := LevelSet.union (clause_levels cl) V in (levels, premises_model_map (zero_model levels) (Clauses.singleton cl)). -Program Definition loop_check {V init cls} (m : valid_model V V init cls) (cl : clause) : result (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 := - loop (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 (premises_model V cl).2 _. -Next Obligation. - destruct m. split => //. - - apply (todo "incl"). - - apply (todo "only"). - - apply is_update_of_empty. +Lemma premises_model_map_spec m cls : + forall l k, + LevelMap.MapsTo l k (premises_model_map m cls) -> + ((LevelSet.In l (clauses_premises_levels cls) /\ k = max_clause_premise_of l cls) \/ + (~ LevelSet.In l (clauses_premises_levels cls) /\ LevelMap.MapsTo l k m)). +Proof. + intros l k; rewrite /premises_model_map. + eapply LevelSetProp.fold_rec. + - intros s' he hm. right. split => //. + - intros x a s' s'' hin hnin hadd ih. + rewrite LevelMapFact.F.add_mapsto_iff. + firstorder. subst k. red in H; subst. firstorder. Qed. -Equations check {V init cls} (m : valid_model V V init cls) (cl : clause) : bool := - check m cl with loop_check m cl := - | Loop _ _ => false (* Actually impossible *) - | Model W v _ => - let '(concl, k) := concl cl in - match LevelMap.find concl v.(model_model) with - | Some v => (k <=? v) - | None => false - end. +Lemma premises_model_map_in m cls l : + LevelMap.In l (premises_model_map m cls) <-> (LevelSet.In l (clauses_premises_levels cls) \/ LevelMap.In l m). +Proof. + rewrite /premises_model_map. + eapply LevelSetProp.fold_rec. + - intros s' he. firstorder. + - intros x a s' s'' hin hnin hadd ih. + rewrite LevelMapFact.F.add_in_iff. + firstorder. +Qed. +Lemma zero_model_spec {l ls n} : LevelMap.MapsTo l n (zero_model ls) <-> LevelSet.In l ls /\ n = 0. +Proof. + unfold zero_model. + eapply LevelSetProp.fold_rec. + - intros s' he. rewrite LevelMapFact.F.empty_mapsto_iff. firstorder. + - intros x a s s' hin hnin hadd eq. + rewrite LevelMapFact.F.add_mapsto_iff. firstorder. + destruct (eq_dec x l). + * subst. now left. + * right. split => //. apply hadd in H1. destruct H1; try congruence. now apply H0. +Qed. + +Lemma in_premises_model V cl : + forall l, + LevelMap.In l (premises_model V cl).2 <-> + LevelSet.In l V \/ LevelSet.In l (clause_levels cl). +Proof. + intros l. rewrite premises_model_map_in. + rewrite clauses_premises_levels_spec. + firstorder. + - right. apply Clauses.singleton_spec in H. + apply clause_levels_spec. left. now subst. + - apply zero_model_spec in H as [hin ->]. + apply LevelSet.union_spec in hin. firstorder. + - right. exists 0. apply zero_model_spec. split => //; lsets. + - eapply clause_levels_spec in H as [H|H]. + * left. exists cl. split => //. now apply Clauses.singleton_spec. + * subst. right. exists 0. apply zero_model_spec. split => //. + apply LevelSet.union_spec. left. apply clause_levels_spec. now right. +Qed. + +Lemma clauses_levels_add {n cls} : clauses_levels (add_clauses n cls) =_lset clauses_levels cls. +Proof. + rewrite /clauses_levels. + symmetry. + apply ClausesProp.fold_rec. + - intros s' he l. rewrite LevelSetFact.empty_iff. split => //. + move/clauses_levels_spec => [] cl []. + move/in_add_clauses => [] cl' [] hin ->. + now apply he in hin. + - intros x a s s' incls nins hadd -> l. + rewrite LevelSet.union_spec !clauses_levels_spec. + rewrite clause_levels_spec. + split. + * move => [[hin|->]|]. + { exists (add_clause n x). split => //. apply add_clauses_spec. apply hadd. now left. + rewrite clause_levels_spec. left. move: hin. rewrite !levelexprset_levels_spec. + intros [k hin]; exists (k + n). destruct x as [prems concl]. cbn. + apply In_add_prems. exists (l, k). split => //. } + { exists (add_clause n x). rewrite -add_clauses_spec. split => //. apply hadd. now left. + rewrite clause_levels_spec. right. + destruct x; cbn. destruct t => //. } + { intros [cl [hin hl]]; exists cl. split => //. + move/in_add_clauses: hin => [cl' [incl' ->]]. + apply add_clauses_spec. now apply hadd. } + * move=> [] cl [] /in_add_clauses [[prems concl] [incl' ->]] /clause_levels_spec. + apply hadd in incl' as [->|ins]. + { move=> [hin|->]. left. left. move/levelexprset_levels_spec: hin => [] k. cbn [premise add_clause]. cbn. + move/In_add_prems => [] [l' k'] [] hinle' [=] -> _. + apply levelexprset_levels_spec. now exists k'. + now left; right; destruct concl. } + { cbn. move=> [hin|->]. + { right. exists (add_clause n (prems, concl)). + split. now apply add_clauses_spec. + apply clause_levels_spec. left. apply levelexprset_levels_spec in hin as [k hin]. + apply In_add_prems in hin as [[l' k'] [hin eq]]. noconf eq. + apply levelexprset_levels_spec. exists (k' + n). eapply In_add_prems. + now exists (l, k'). } + { right. exists (add_clause n (prems, concl)). + split. now apply add_clauses_spec. + apply clause_levels_spec. now right. } } +Qed. Equations? infer_model (cls : clauses) : option model := infer_model cls with loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (init_model cls) _ := @@ -6225,67 +6312,325 @@ Proof. rewrite interp_add_prems in sem. lia. Qed. -Section Completeness. +Definition valid_entailment cls cl := forall V, clauses_sem V cls -> clause_sem V cl. - Record semilattice := - { V : Type; - succ : V -> V; - max : V -> V -> V; - succ_max : forall x, succ (max x y) = max (x) +Program Definition loop_check cls (cl : clause) : result (premises_model (clauses_levels cls) cl).1 LevelSet.empty (succ_clauses cls) (premises_model (clauses_levels cls) cl).2 := + let V := clauses_levels cls in + loop (premises_model V cl).1 LevelSet.empty (succ_clauses cls) (premises_model V cl).2 (premises_model V cl).2 _. +Next Obligation. + split => //. + - rewrite clauses_levels_add. lsets. + - intros l. rewrite LevelSet.union_spec. + rewrite -/(LevelMap.In l (premises_model (clauses_levels cls) cl).2). + rewrite in_premises_model. intuition auto. + - apply is_update_of_empty. +Qed. - } +Definition premises_of_level_set (l : LevelSet.t) := + LevelSet.fold (fun l acc => (l, 0) :: acc) l []. + +Definition extendV V (cl : clause) := + let '(prems, concl) := cl in + (add_list (premises_of_level_set V) prems, concl). + +Equations check (cls : clauses) (cl : clause) : bool := + check cls cl with loop_check cls (succ_clause cl) := + | Loop _ _ => false (* Actually impossible *) + | Model W v _ => + let '(concl, k) := concl cl in + match LevelMap.find concl v.(model_model) with + | Some v => (S k <=? v) + | None => false + end. + +Lemma premises_model_map_min_premise {levels cls prems z} : + min_premise (premises_model_map (zero_model levels) cls) prems = Some z -> + (exists minp mink, LevelExprSet.In (minp, mink) prems /\ z = (Z.of_nat (max_clause_premise_of minp cls) - Z.of_nat mink)%Z) \/ + (z <= 0)%Z. +Proof. + set (m := premises_model_map _ _). + have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m prems. + rewrite mineq. rewrite /min_atom_value. + destruct level_value eqn:hl => //. intros [= <-]. + eapply LevelMap.find_2 in hl. eapply premises_model_map_spec in hl as [[inpcls hm]|[ninpcls h']]. left. + 2:{ right. apply zero_model_spec in h' as [h' ->]. cbn. lia. } + exists minp, mink. split => //. lia. +Qed. + +Lemma is_update_of_entails {cls V m m' hne hne'} : is_update_of cls V m m' -> + cls ⊢a of_level_map m hne → of_level_map m' hne'. +Proof. + rewrite /is_update_of. + destruct LevelSet.is_empty. + - intros heq []. + rewrite !of_level_map_spec. rewrite -heq. + constructor. now apply of_level_map_spec. + - eapply strictly_updates_entails. +Qed. + +Lemma is_update_of_non_empty {cls V m m'} : ~ LevelMap.Empty m -> + is_update_of cls V m m' -> + ~ LevelMap.Empty m'. +Proof. + rewrite /is_update_of. destruct LevelSet.is_empty. + - now intros he <-. + - intros he su. now eapply strictly_updates_non_empty_map in su. +Qed. + +Lemma inj_add_prems_sub {n u u'} : add_prems n u ⊂_leset add_prems n u' -> u ⊂_leset u'. +Proof. + rewrite /add_prems. + intros hm [l k]. specialize (hm (l, k + n)%nat). + rewrite !map_spec in hm. + intros hin. + forward hm. exists (l, k); split => //. + destruct hm as [[] [hin' eq]]. + apply (@add_expr_inj n (l, k)) in eq. now noconf eq. +Qed. + +Lemma premises_of_level_set_spec l k V : LevelSet.In l V /\ k = 0 <-> In (l, k) (premises_of_level_set V). +Proof. + rewrite /premises_of_level_set. + eapply LevelSetProp.fold_rec. + - intros s' he. firstorder. + - intros x a s' s'' hin hnin hadd ih. + red in hadd. rewrite {}hadd. + cbn. firstorder. subst. now left. noconf H1. now left. now noconf H1. +Qed. + +Lemma in_succ_add_premises {V u x k} : LevelExprSet.In (x, k + 1) (add_list (premises_of_level_set V) u) -> LevelExprSet.In (x, k + 1) u. +Proof. + rewrite add_list_spec. intros [hn|hn] => //. + eapply premises_of_level_set_spec in hn as []; lia. +Qed. + +Lemma inj_succ_prems {V u u'} : succ_prems u ⊂_leset add_list (premises_of_level_set V) u' -> succ_prems u ⊂_leset u'. +Proof. + intros sub x. rewrite In_add_prems => [] [[l k] [hin ->]]. + specialize (sub (l, k + 1)%nat). + forward sub. + apply In_add_prems. exists (l, k). split => //. + now apply in_succ_add_premises in sub. +Qed. + +Lemma succ_clauses_equiv cls V prems concl : + succ_clauses cls ⊢ add_list (premises_of_level_set V) (succ_prems prems) → succ_expr concl -> + cls ⊢ prems → concl. +Proof. + intros ha; depind ha. + - constructor. + move: H. + rewrite add_list_spec. intros [hle|heq]. + destruct concl1 as [l k]. + eapply premises_of_level_set_spec in hle as [inv eq]. lia. + move: heq; rewrite In_add_prems => [] [le [hin heq]]. + move/add_expr_inj: heq. now intros ->. + - depelim H. + + destruct cl as [prems concl]. noconf H0. + eapply in_add_clauses in H as [[prems' concl'] [hin heq]]. + noconf heq. + eapply (clause_cut _ (add_prems n prems') (add_expr n concl')). 2:eapply (IHha V). + 2:{ f_equal. rewrite !add_expr_add_expr. rewrite add_prems_add add_expr_add_expr Nat.add_1_r. + apply eq_univ_equal. intros l. + rewrite add_list_spec !add_spec add_list_spec. firstorder. } + exact: (incls cls (prems', concl') n hin). + rewrite add_prems_add_prems in H1. rewrite Nat.add_1_r in H1. + rewrite -(add_prems_add_prems 1 n prems') in H1. + move/inj_succ_prems: H1. + now move/inj_add_prems_sub. + + specialize (H0 (x, k + 1)). forward H0. now apply LevelExprSet.singleton_spec. + destruct k. + * specialize (IHha (LevelSet.add x V)). + eapply in_succ_add_premises in H0. + eapply In_add_prems in H0 as [[] [hin heq]]; noconf heq. assert (n = 0) by lia. subst n. clear H. + eapply IHha. + f_equal. eapply eq_univ_equal => [] [l' k']. + rewrite !add_list_spec add_spec add_list_spec -!premises_of_level_set_spec In_add_prems LevelSet.add_spec /LevelSet.E.eq. + firstorder; subst. now left. noconf H. left. split => //. now left. + * eapply in_succ_add_premises, In_add_prems in H0 as [[l' k'] [hin heq]]. noconf heq. + have eq: k' = S k by lia. subst k'. clear H. + eapply clause_cut. 2:eapply (IHha V). eapply (predcl _ x k). + 2:{ intros x'. move/LevelExprSet.singleton_spec => ->. now rewrite Nat.add_1_r. } + f_equal. + eapply eq_univ_equal => l. + rewrite !add_list_spec !add_spec !add_list_spec !In_add_prems. firstorder; subst. + { eapply LevelExprSet.add_spec in H as []. red in H; subst x0. left. cbn. now rewrite Nat.add_1_r. + right. right. exists x0. split => //. } + { right. exists (x, k). rewrite LevelExprSet.add_spec. split => //. now left. rewrite /add_expr; now rewrite Nat.add_1_r. } + { right. exists x0. rewrite LevelExprSet.add_spec. split => //. now right. } +Qed. + +Lemma entails_weak_list {cls prem concl concl'} : + cls ⊢ prem → concl -> + cls ⊢ add_list concl' prem → concl. +Proof. + intros hcl. + induction concl' in prem, hcl |- *. + - exact hcl. + - cbn. eapply IHconcl'. now eapply entails_weak. +Qed. + +Lemma entails_all_weak_list {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (add_list concl' prem) concl. +Proof. + intros hcl x hin. + specialize (hcl _ hin). cbn in hcl. + now eapply entails_weak_list. +Qed. + +Lemma premises_of_level_set_empty : premises_of_level_set LevelSet.empty = []. +Proof. + now rewrite /premises_of_level_set LevelSetProp.fold_empty. +Qed. + +Lemma succ_clauses_equiv_weak cls prems concl : + succ_clauses cls ⊢ succ_prems prems → succ_expr concl -> + cls ⊢ prems → concl. +Proof. + move/(entails_weak_list (concl' := [])) => he. + eapply (succ_clauses_equiv _ LevelSet.empty). + cbn. now rewrite premises_of_level_set_empty. +Qed. + +Definition entails_equiv cls u u' := + cls ⊢a u → u' /\ cls ⊢a u' → u. + +Notation "cls '⊢a' u ↔ u'" := (entails_equiv cls u u') (at level 90). + +Lemma max_premise_of_spec_aux s l k : + max_premise_of l s = k -> + (forall k', LevelExprSet.In (l, k') s -> (k' <= k)%nat) /\ + ((exists k', LevelExprSet.In (l, k') s /\ k = k') \/ + ((~ exists k', LevelExprSet.In (l, k') s) /\ k = 0%nat)). +Proof. + unfold max_premise_of. + revert k. + eapply LevelExprSetProp.fold_rec. + - intros s' he k <-. cbn. split => //. + * now move=> k' /he. + * right; split => //. now move=> [] k' /he. + - intros [l' k'] a s' s'' hin hnin hadd ih k. + specialize (ih _ eq_refl) as [hle hex]. + intros hmax. + split. move=> k'0 /hadd => [] []. + { move=> [=] eq eq'. subst l' k'. rewrite eqb_refl in hmax. lia. } + { move/hle. move: hmax. destruct (eqb_spec l l'); subst. lia. lia. } + destruct hex as [[k'' [hin' heq]]|nex]. subst k''. + { left. destruct (eqb_spec l l'). subst. eexists; split; trea. eapply hadd. + destruct (Nat.max_spec k' a) as [[hlt ->]|[hle' ->]] => //. now right. now left. subst k. + exists a; split => //. apply hadd; now right. } + destruct nex as [nex ->]. + destruct (eqb_spec l l'). subst. left. exists k'. split => //. apply hadd; now left. lia. + subst k. right. split => //. + intros [k'' hin']. apply hadd in hin' as []. noconf H0. congruence. + apply nex. now exists k''. +Qed. + + +Lemma max_premise_of_prems_max l prems : max_premise_of l prems > 0 -> LevelExprSet.In (l, max_premise_of l prems) prems. +Proof. + destruct max_premise_of eqn:maxp => //. lia. intros _. + apply max_premise_of_spec_aux in maxp as [hle hex]. + destruct hex as [[k' [hin <-]]|hne] => //. + destruct hne; lia. +Qed. + +Lemma max_premise_of_singleton l k : max_premise_of l (singleton (l, k)) = k. +Proof. + remember (max_premise_of l (singleton (l, k))) as mp. symmetry in Heqmp. + apply max_premise_of_spec_aux in Heqmp as [hle hex]. + destruct hex as [[k' [hin <-]]|hne] => //. + eapply LevelExprSet.singleton_spec in hin. now noconf hin. + destruct hne as [nein ->]. elim nein. + exists k. now eapply LevelExprSet.singleton_spec. +Qed. +Lemma max_premise_of_spec2 l k (u : univ) : LevelExprSet.In (l, k) u -> exists k', LevelExprSet.In (l, k') u /\ k' = max_premise_of l u. +Proof. + remember (max_premise_of l u) as mp. symmetry in Heqmp. + apply max_premise_of_spec_aux in Heqmp as [hle hex]. + intros hin. destruct hex. firstorder. + destruct H as [nein ->]. elim nein. now exists k. +Qed. +Lemma max_premise_of_spec_in l (u : univ) : LevelSet.In l (levels u) -> LevelExprSet.In (l, max_premise_of l u) u. +Proof. + intros hexi. + remember (max_premise_of l u) as mp. symmetry in Heqmp. + apply max_premise_of_spec_aux in Heqmp as [hle hex]. + destruct hex. now destruct H as [l' [hin ->]]. + destruct H as [nein ->]. elim nein. + now eapply levelexprset_levels_spec in hexi. +Qed. +Lemma of_level_map_premises_model_map cls cl V ne : + cls ⊢a add_list (premises_of_level_set V) (premise cl) → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. +Proof. + intros [l k]. + rewrite of_level_map_spec. move/premises_model_map_spec; cbn. + cbn; rewrite LevelSet.union_spec. firstorder try lsets. subst. + - rewrite Nat.max_0_r. constructor. + rewrite add_list_spec. right. + now eapply max_premise_of_spec_in. + - eapply zero_model_spec in H0 as [hin ->]. constructor. + eapply add_list_spec. left. now eapply premises_of_level_set_spec. +Qed. + +Lemma entails_all_satisfies {cls prems m hne l k} : + cls ⊢a prems → of_level_map m hne -> + infers_atom m l k -> + cls ⊢ prems → (l, k). +Proof. + intros hl hi. + eapply entails_all_one; tea. now apply infers_atom_of_level_map. +Qed. + +Lemma premises_model_map_ne V cls : + ~ LevelMap.Empty V -> + ~ LevelMap.Empty (premises_model_map V cls). +Proof. + intros ne he. apply ne. + have ne' := premises_model_map_in V cls. + intros l k hin. + specialize (ne' l). destruct ne'. forward H0. right. now exists k. + destruct H0 as [k' hin']. + now move/he: hin'. +Qed. (* If a clause checks, then it should be valid in any extension of the model *) -Lemma check_entails {V init cls} (m : valid_model V V init cls) (cl : clause) : - check m cl = true -> forall m', model_model m ⩽ m' -> valid_clause m' cl. +Lemma check_entails {cls cl} : + check cls cl = true -> valid_entailment cls cl. Proof. - funelim (check m cl) => //. + funelim (check cls cl) => //. + set (V := clause_levels (succ_clause cl) ∪ clauses_levels cls) in *. destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *. destruct LevelMap.find as [conclval_v|] eqn:hfind => //. (* Found a value *) - unfold valid_clause, level_value_above. cbn. + unfold valid_clause, level_value_above. move/Nat.leb_le => hgt. - intros m' ext. - destruct min_premise eqn:hmin => //. - pose proof (min_premise_spec m' prems) as [minle mineq]. - unfold level_value. - set (all_levels := clause_levels _ ∪ V) in *. - set (undef_model := premises_model_map _ _) in *. - have vcheck := model_ok v. - unfold is_model in vcheck. - assert (model_model v ⩽ model_model m). admit. - assert (model_model v ⩽ m'). etransitivity; tea. - eapply LevelMap.find_2 in hfind. - apply H0 in hfind as [k' [hmk' neq]]. red in neq. rename k' into conclval_m'. - eapply LevelMap.find_1 in hmk'. rewrite hmk'. -Abort. - (*eapply Z.leb_le. transitivity conclval_v => //. - destruct (Z.leb_spec z 0). - (* If min_premise m' z > 0 in the final model, it means prems -> prems + 1, - i.e. there is a loop, which is impossible. - We start with min_premise undef_model prems = Some 0 by definition. - Any increase of [z]'s value means a consequence of [z] - was found requiring to increase its value. But then it must mean [z -> z + 1]. - *) - exfalso. - have updundef := model_updates v. - have me := is_update_of_ext updundef. - assert (not (exists x, is_loop cls x)). admit. - apply H3. - destruct mineq as [minelt [hprems hmin']]. - exists (singleton minelt). - unfold is_loop, to_clauses. - intros x hin. - rewrite LevelExprSet.fold_spec in hin. - move: hin. - assert (LevelExprSet.elements (succ_prems (singleton minelt)) = [succ_expr minelt]). admit. - rewrite H4 //=. unfold flip. move/Clauses.add_spec. intros [->|] => //. 2:{ now apply Clauses.empty_spec in H5. } - destruct minelt as [min k']. cbn. - -Abort. -*) + intros val ext. + have vmupd := model_updates v. + have vmok := model_ok v. + set (pm := premises_model_map _ _) in *. + have nepm : ~ LevelMap.Empty pm. + { apply premises_model_map_ne. + have zm := proj2 (@zero_model_spec concl V 0). + forward zm. split => //. subst V. + eapply LevelSet.union_spec. left. apply clause_levels_spec. + now right. intros he. now move/he: zm. } + have nev : ~ LevelMap.Empty (model_model v). + by apply (is_update_of_non_empty nepm vmupd). + move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. + set (cl := (prems, (concl, k))) in V. + have of_lset := of_level_map_premises_model_map (succ_clauses cls) (succ_clause cl) V nepm. + have tr := entails_all_trans of_lset ent. + eapply (entails_all_satisfies (l := concl) (k := S k)) in tr. + 2:{ red. rewrite /level_value hfind. now constructor. } + have se := (succ_clauses_equiv cls V (premise cl) (concl, k)). + cbn in se, tr. rewrite Nat.add_1_r in se. + specialize (se tr). + eapply clauses_sem_entails in se ; tea. +Qed. End LoopChecking. From 5705c51a87a9be2a85078528b83e3857630a304a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 29 Aug 2025 19:56:38 +0200 Subject: [PATCH 027/164] WIP towards completeness --- template-rocq/theories/PartialLoopChecking.v | 87 ++++++++++++++++++++ 1 file changed, 87 insertions(+) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 83b278bb6..3df4f0eba 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -6493,6 +6493,15 @@ Proof. cbn. now rewrite premises_of_level_set_empty. Qed. +Lemma entails_all_succ_clauses cls prems concl : + succ_clauses cls ⊢a succ_prems prems → succ_prems concl -> + cls ⊢a prems → concl. +Proof. + intros ha l hin. specialize (ha (succ_expr l)). forward ha. + eapply In_add_prems. exists l. split => //. cbn in ha. + now eapply succ_clauses_equiv_weak in ha. +Qed. + Definition entails_equiv cls u u' := cls ⊢a u → u' /\ cls ⊢a u' → u. @@ -6633,4 +6642,82 @@ Proof. eapply clauses_sem_entails in se ; tea. Qed. +Definition invalid_entailment cls cl := + ~ entails cls cl. + (* forall V, clauses_sem V cls -> clause_sem V cl -> False. *) + +Lemma entails_su cls cl : entails cls cl -> + forall m, is_model cls m -> enabled_clause m cl -> valid_clause m cl. +Proof. + induction 1. + - intros m ism. + unfold enabled_clause, valid_clause. + intros [z [eqmin hge]]. rewrite eqmin. cbn. + destruct concl0 as [concl k]. + have hge' := hge. + apply Z.leb_le in hge'. rewrite Z.leb_antisym in hge'. + move/negbTE: hge' => -> //=. + unfold level_value_above. + destruct level_value eqn:hl. cbn in eqmin. + eapply min_premise_spec_aux in eqmin as [hle [x [hin heq]]]. + specialize (hle _ H). depelim hle. rewrite hl in H1. noconf H1. + eapply Nat.leb_le. lia. + eapply min_premise_spec_aux in eqmin as [hle [x [hin heq]]]. + specialize (hle _ H). depelim hle. rewrite hl in H1. congruence. + - intros. + specialize (IHentails m H2). + + +Lemma check_entails_false {cls cl} : + check cls cl = false -> invalid_entailment cls cl. +Proof. + funelim (check cls cl) => //. + - intros _; clear Heq Heqcall. red in islooping. red. + eapply (entails_all_shift 1) in islooping. + eapply entails_all_succ_clauses in islooping. + eapply clauses_sem_entails_all in islooping; tea. + rewrite interp_add_prems in islooping. lia. admit. + - set (V := clause_levels (succ_clause cl) ∪ clauses_levels cls) in *. + destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *. + destruct LevelMap.find as [conclval_v|] eqn:hfind => //. + 2:{ apply (todo "impossible, concl is in the model"). } + (* Found a value *) + unfold valid_clause, level_value_above. + move/leb_complete_conv => hgt. intro. + intros val ext. + have vmupd := model_updates v. + have vmok := model_ok v. + set (pm := premises_model_map _ _) in *. + have nepm : ~ LevelMap.Empty pm. + { apply premises_model_map_ne. + have zm := proj2 (@zero_model_spec concl V 0). + forward zm. split => //. subst V. + eapply LevelSet.union_spec. left. apply clause_levels_spec. + now right. intros he. now move/he: zm. } + have nev : ~ LevelMap.Empty (model_model v). + by apply (is_update_of_non_empty nepm vmupd). + move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. + set (cl := (prems, (concl, k))) in V. + have of_lset := of_level_map_premises_model_map (succ_clauses cls) (succ_clause cl) V nepm. + have tr := entails_all_trans of_lset ent. + eapply (entails_all_satisfies (l := concl) (k := conclval_v)) in tr. + 2:{ red. rewrite /level_value hfind. now constructor. } + have he : ~ cls ⊢ prems → (concl, k). + { intros he. eapply clauses_sem_entails in he; tea. + cbn in he. admit. } + destruct conclval_v. admit. + have se := (succ_clauses_equiv cls V (premise cl) (concl, conclval_v)). + cbn in se, tr. rewrite Nat.add_1_r in se. + specialize (se tr). + eapply clauses_sem_entails in se ; tea. cbn in se. cbn. +Qe + intros _. red in islooping. clear Heqcall Heq. + - admit. + - destruct cl as [prems [concl k]]; cbn. + destruct LevelMap.find eqn:heq. + destruct n. clear Heqcall. intros _. + red. intros val semcls. cbn. + + } + End LoopChecking. From 2a81160a4e49cc1baba7f7434ee607bc54ca7cf2 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 30 Aug 2025 21:57:48 +0200 Subject: [PATCH 028/164] Verified entails -> model --- template-rocq/theories/PartialLoopChecking.v | 359 ++++++++++++++++++- 1 file changed, 341 insertions(+), 18 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 3df4f0eba..5aa8602a3 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -2306,7 +2306,7 @@ Qed. Lemma nonEmptyLevelExprSet_elim {P : nonEmptyLevelExprSet -> Prop} : (forall le, P (singleton le)) -> - (forall le prems, P prems -> P (add le prems)) -> + (forall le prems, P prems -> ~ LevelExprSet.In le prems -> P (add le prems)) -> forall prems, P prems. Proof. intros hs ha. @@ -2905,7 +2905,7 @@ Proof. - intros le. rewrite univ_union_comm univ_union_add_singleton. now apply entails_weak. - intros le prems ih. - rewrite univ_union_add_distr. + rewrite univ_union_add_distr. intros _. now eapply entails_weak. Qed. @@ -3011,7 +3011,7 @@ Proof. cbn in H. eapply entails_add; tea. now rewrite -univ_union_add_singleton. - - intros le prems ih prem concl' hadd hadd'. + - intros le prems ih _ prem concl' hadd hadd'. rewrite univ_union_comm univ_union_add_distr -univ_union_comm -univ_union_add_distr in hadd'. eapply ih in hadd'. 2:{ apply entails_all_weak. apply entails_all_add in hadd as []. exact H0. } apply entails_all_add in hadd as []. @@ -6646,27 +6646,348 @@ Definition invalid_entailment cls cl := ~ entails cls cl. (* forall V, clauses_sem V cls -> clause_sem V cl -> False. *) -Lemma entails_su cls cl : entails cls cl -> - forall m, is_model cls m -> enabled_clause m cl -> valid_clause m cl. +Definition infers_univ (m : model) (u : univ) := + exists z, min_premise m u = Some z /\ (0 <= z)%Z. + +Definition infers_expr (m : model) (le : LevelExpr.t) := + let '(l, k) := le in infers_atom m l k. + +Lemma valid_clause_elim {m prems concl k} : valid_clause m (prems, (concl, k)) -> + forall z, min_premise m prems = Some z -> (0 <= z)%Z -> + Some (Z.to_nat z + k) ≤ level_value m concl. +Proof. + rewrite /valid_clause => hcl z eqmin hge. + rewrite eqmin in hcl. cbn in *. + move: hcl; elim: Z.ltb_spec => //=. + * lia. + * move=> _. rewrite /level_value_above. destruct level_value eqn:hl => //. + move/Nat.leb_le. constructor. lia. +Qed. + +Lemma valid_clause_intro {m prems concl k} : + (forall z, + min_premise m prems = Some z -> (0 <= z)%Z -> + Some (Z.to_nat z + k) ≤ level_value m concl) -> + valid_clause m (prems, (concl, k)). +Proof. + rewrite /valid_clause //=. + destruct min_premise => //. + elim: Z.ltb_spec => //= hge. + intros hz. + specialize (hz _ eq_refl hge). depelim hz. + rewrite /level_value_above H0. + now apply Nat.leb_le. +Qed. + +Lemma infers_expr_min_atom_value m le : infers_expr m le -> exists k, min_atom_value m le = Some k /\ (0 <= k)%Z. +Proof. + destruct le as [l k]; rewrite /infers_expr //=. + rewrite /infers_atom. destruct level_value => // hle; depelim hle. + eexists; split; trea. lia. +Qed. + +Lemma min_premise_add_infers m prems le : + infers_expr m le -> + forall z, min_premise m prems = Some z -> (0 <= z)%Z -> + exists z', min_premise m (add le prems) = Some z' /\ + ((min_atom_value m le = Some z' /\ (0 <= z' <= z)%Z) \/ z' = z). +Proof. + intros infe z hmin hpos. + have [hle [min' [hin hm]]] := min_premise_spec m (add le prems). + have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. + move/LevelExprSet.add_spec: hin => [heq|hin]. + - noconf heq. + eapply infers_expr_min_atom_value in infe as [z' [mineq hge]]. + rewrite mineq in hm. exists z'; split => //. + specialize (hle min''). forward hle. + { rewrite LevelExprSet.add_spec. now right. } + rewrite hm -hm' hmin in hle. now depelim hle. + - exists z. split => //. 2:right; reflexivity. rewrite hm -hmin hm'. + move: (hle' _ hin). rewrite hmin. intros h; depelim h. + rewrite H0 in hm. + specialize (hle min''). forward hle. eapply LevelExprSet.add_spec. now right. + rewrite hm in hle. rewrite -hm' hmin in hle. depelim hle. + rewrite H0 -hm' hmin. f_equal. lia. +Qed. + +Lemma min_premise_add_down {m} {prems : univ} {l k} : + LevelExprSet.In (l, k + 1) prems -> + forall z, min_premise m prems = Some z -> + min_premise m (add (l, k) prems) = Some z. +Proof. + intros ine z hmin. + have [hle [min' [hin hm]]] := min_premise_spec m (add (l, k) prems). + have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. + move/LevelExprSet.add_spec: hin => [heq|hin]. + - noconf heq. + specialize (hle (l, k + 1)). + forward hle. eapply LevelExprSet.add_spec. now right. + rewrite hm in hle. + depelim hle. destruct level_value eqn:hl. noconf H0; noconf H1. lia. congruence. + destruct level_value eqn:hl' => //. + specialize (hle' _ ine). rewrite hmin in hle'; depelim hle'. + now rewrite hl' in H1. + - rewrite hm. specialize (hle' min' hin). rewrite hmin in hle'. + depelim hle'. rewrite H0. f_equal. rewrite H0 in hm. + specialize (hle min''). forward hle. eapply LevelExprSet.add_spec. now right. + rewrite hm in hle. rewrite -hm' hmin in hle. depelim hle. lia. +Qed. + +Lemma fold_left_map {A B C} (f : B -> A -> A) (g : C -> B) l acc : + fold_left (fun acc l => f (g l) acc) l acc = + fold_left (fun acc l => f l acc) (map g l) acc. +Proof. + induction l in acc |- *; cbn; auto. +Qed. + +Lemma fold_left_max_acc {n l} : (forall x, In x l -> x = n) -> n = fold_left (option_map2 Z.min) l n. +Proof. + induction l in n |- *. + - now cbn. + - cbn. intros he. transitivity (option_map2 Z.min n a). 2:apply IHl. + specialize (he a). forward he. now left. subst. destruct n => //= //. lia_f_equal. + intros. have h := (he x). forward h by now right. + have h' := (he a). forward h' by now left. subst. + destruct n => //=; lia_f_equal. +Qed. + +Lemma fold_left_impl n n' l l' : + (forall x, In x (n :: l) <-> In x (n' :: l')) -> + fold_left (option_map2 Z.min) l n = fold_left (option_map2 Z.min) l' n'. +Proof. + intros. +Admitted. + +Lemma fold_left_comm_f {A} (f : A -> A -> A) n l : + (forall x y, f x y = f y x) -> + fold_left f l n = fold_left (flip f) l n. +Proof. + induction l in n |- *; cbn; auto. + intros hf. rewrite IHl //. + unfold flip. now rewrite hf. +Qed. + +(* +Lemma min_premise_fold_equiv {A} (f : A -> A -> A) x x' l l' : + equivlistA eq (x :: l) (x' :: l') -> + NoDup (x :: l) -> + NoDup (x' :: l') -> + transpose eq f -> + fold_left f l x = + fold_left f l' x'. +Proof. + induction l in x', l' |- *. + - cbn. intros. + destruct (H x). destruct l' => //. cbn. + forward H3 by constructor; reflexivity. + now depelim H3. subst. + depelim H1. + destruct (H x). forward H6 by constructor; reflexivity. + depelim H6. subst. forward H4 by constructor; reflexivity. + forward H2 by constructor; reflexivity. + now depelim H. + destruct H as [H H']. forward H by constructor. reflexivity. + depelim H. subst. cbn. forward H'. constructor; reflexivity. + depelim H'. subst. *) + + +Lemma option_map2_comm x y : option_map2 Z.min x y = option_map2 Z.min y x. +Proof. + destruct x, y; cbn; lia_f_equal. +Qed. + +Lemma option_map2_assoc x y z : + option_map2 Z.min x (option_map2 Z.min y z) = + option_map2 Z.min (option_map2 Z.min x y) z. +Proof. + destruct x, y, z; cbn; lia_f_equal. +Qed. + +Lemma min_premise_elim m (P : univ -> option Z -> Prop): + (forall le, P (singleton le) (min_atom_value m le)) -> + (forall prems acc le, P prems acc -> ~ LevelExprSet.In le prems -> P (add le prems) (option_map2 Z.min (min_atom_value m le) acc)) -> + forall prems, P prems (min_premise m prems). +Proof. + intros hs hadd. + eapply nonEmptyLevelExprSet_elim. + - intros le. rewrite /min_premise. + rewrite singleton_to_nonempty_list. cbn. apply hs. + - intros le prems hp. + rewrite /min_premise. + have hs' := to_nonempty_list_spec (add le prems). + destruct to_nonempty_list. + have eqf : (fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (min_atom_value m t)) = + (option_map2 Z.min (min_atom_value m le) (min_premise m prems)). + 2:{ rewrite eqf. now eapply hadd. } + rewrite -(to_nonempty_list_spec' (add le prems)) in hs'. noconf hs'. + rewrite fold_left_map. rewrite fold_left_comm_f. intros [] []; cbn; auto. lia_f_equal. unfold flip. + have l := fold_left_impl (min_atom_value m (to_nonempty_list (add le prems)).1) (min_atom_value m le) + (map (min_atom_value m) (to_nonempty_list (add le prems)).2) (map (min_atom_value m) (LevelExprSet.elements prems)). + rewrite l. + intros x. + { rewrite -!map_cons to_nonempty_list_spec' !in_map_iff. + split. + - move=> [] lk [] <-. + rewrite -InA_In_eq. + move/LevelExprSet.elements_spec1. + rewrite LevelExprSet.add_spec. + intros [->|inp]. + * exists le. split => //. now left. + * exists lk. split => //. right. now apply InA_In_eq, LevelExprSet.elements_spec1. + - intros [x' [<- hin]]. + exists x'. split => //. rewrite -InA_In_eq. + eapply LevelExprSet.elements_spec1. rewrite LevelExprSet.add_spec. + apply InA_In_eq in hin. depelim hin. now left. + eapply LevelExprSet.elements_spec1 in hin. now right. } + rewrite option_map2_comm. + rewrite /min_premise. + destruct (to_nonempty_list prems) eqn:he. + rewrite fold_left_map. + rewrite (fold_left_comm_f _ _ (map _ l0)). intros. apply option_map2_comm. + rewrite -(fold_left_comm (option_map2 Z.min)). + { intros. now rewrite -option_map2_assoc (option_map2_comm x y) option_map2_assoc. } + rewrite -(to_nonempty_list_spec' prems) he; cbn. + now rewrite option_map2_comm. +Qed. + +Lemma add_prems_singleton n cl : add_prems n (singleton cl) = singleton (add_expr n cl). +Proof. +Admitted. + +Lemma min_premise_singleton m u : min_premise m (singleton u) = min_atom_value m u. +Proof. + now rewrite /min_premise singleton_to_nonempty_list; cbn. +Qed. + +Lemma min_premise_add m le u : min_premise m (add le u) = + option_map2 Z.min (min_atom_value m le) (min_premise m u). +Proof. + symmetry. + rewrite /min_premise. +Admitted. + +Lemma min_atom_value_add m e x n : + min_atom_value m e = Some x -> + min_atom_value m (add_expr n e) = Some (x - Z.of_nat n)%Z. +Proof. + rewrite /min_atom_value. destruct e. cbn. + destruct level_value => //. intros [= <-]. + f_equal. lia. +Qed. + + +Lemma min_atom_value_add_inv m e x n : + min_atom_value m (add_expr n e) = Some x -> + min_atom_value m e = Some (x + Z.of_nat n)%Z. +Proof. + rewrite /min_atom_value. destruct e. cbn. + destruct level_value => //. intros [= <-]. + f_equal. lia. +Qed. + +Lemma min_premise_add_prems {m n prems z} : min_premise m prems = Some z -> min_premise m (add_prems n prems) = Some (z - Z.of_nat n)%Z. +Proof. + revert z. + eapply min_premise_elim. + - intros le hm. + destruct le as [concl k]. + rewrite add_prems_singleton min_premise_singleton. + apply min_atom_value_add. + - intros prems' acc le ih nle z hm. + destruct acc; cbn in hm. 2:{ destruct (min_atom_value m le); cbn in hm; congruence. } + specialize (ih _ eq_refl). + rewrite add_prems_add min_premise_add. + destruct (min_atom_value m le) eqn:hm'; cbn in hm => //. noconf hm. + apply (min_atom_value_add _ _ _ n) in hm'. + rewrite ih hm'. cbn. f_equal. lia. +Qed. + +Lemma min_premise_add_prems_inv {m n prems z} : min_premise m (add_prems n prems) = Some z -> + min_premise m prems = Some (z + Z.of_nat n)%Z. +Proof. + revert z. + pattern prems. + set (P := (fun n0 hm => + forall z : Z, + min_premise m (add_prems n n0) = Some z -> hm = Some (z + Z.of_nat n)%Z)). + apply (@min_premise_elim _ P); subst P; cbn. + - intros le z hm. + destruct le as [concl k]. + rewrite add_prems_singleton min_premise_singleton in hm. + now apply min_atom_value_add_inv. + - intros prems' acc le ih nle z. + rewrite add_prems_add min_premise_add. + destruct (min_premise m (add_prems n prems')) eqn:he => //=. + * destruct (min_atom_value m (add_expr n le)) eqn:ha => //=. + intros [= <-]. + eapply min_atom_value_add_inv in ha. rewrite ha. + specialize (ih _ eq_refl). subst acc. cbn. lia_f_equal. + * destruct (min_atom_value m (add_expr n le)) eqn:ha => //=. +Qed. + +Lemma level_value_above_leq {m l k} : + Some k ≤ level_value m l -> + level_value_above m l k. +Proof. + intros h; rewrite /level_value_above. + depelim h. rewrite H0. apply Nat.leb_le. lia. +Qed. + +Lemma valid_clause_shift m n cl : + valid_clause m cl -> valid_clause m (add_clause n cl). +Proof. + destruct cl as [prems [concl k]]. + move/valid_clause_elim => hv. + apply valid_clause_intro => z eqmin zpos. + eapply min_premise_add_prems_inv in eqmin. + specialize (hv _ eqmin). forward hv. lia. + etransitivity; tea. constructor; lia. +Qed. + +Lemma entails_model_valid cls cl : entails cls cl -> + forall m, is_model cls m -> valid_clause m cl. Proof. induction 1. - intros m ism. - unfold enabled_clause, valid_clause. - intros [z [eqmin hge]]. rewrite eqmin. cbn. destruct concl0 as [concl k]. - have hge' := hge. - apply Z.leb_le in hge'. rewrite Z.leb_antisym in hge'. - move/negbTE: hge' => -> //=. - unfold level_value_above. - destruct level_value eqn:hl. cbn in eqmin. - eapply min_premise_spec_aux in eqmin as [hle [x [hin heq]]]. - specialize (hle _ H). depelim hle. rewrite hl in H1. noconf H1. - eapply Nat.leb_le. lia. - eapply min_premise_spec_aux in eqmin as [hle [x [hin heq]]]. - specialize (hle _ H). depelim hle. rewrite hl in H1. congruence. + apply valid_clause_intro => z hmin hge. + eapply min_premise_spec_aux in hmin as [hle [x [hin heq]]]. + specialize (hle _ H). depelim hle. + destruct level_value eqn:hl => //. noconf H1. + constructor. lia. - intros. specialize (IHentails m H2). - + depelim H. + * destruct cl as [premsc conclc]. + noconf H0. + eapply Clauses.for_all_spec in H3. + eapply H3 in H. 2:tc. + destruct concl0 as [concl k]. + eapply valid_clause_intro => z eqmin hge. + have mins := min_premise_subset m (add_prems n premsc) prems H2. + rewrite eqmin in mins; depelim mins. + destruct conclc as [conclc k']. + have vshift : valid_clause m (add_prems n premsc, add_expr n (conclc, k')). + { now eapply (valid_clause_shift _ n) in H. } + have hv := valid_clause_elim vshift _ H4. forward hv by lia. + eapply (min_premise_add_infers _ _ (add_expr n (conclc, k'))) in eqmin as [minadd [eqminadd disj]]; tea. + 2:{ rewrite /infers_expr /infers_atom. cbn. etransitivity; tea. constructor; lia. } + move/valid_clause_elim: IHentails => //=. + move/(_ _ eqminadd). + destruct disj as [[eqmnew le']| ->]. + + cbn in eqmnew. depelim hv. rewrite H6 in eqmnew. + have : (0 <= minadd)%Z by (noconf eqmnew; lia). + move=> h /(_ h). noconf eqmnew. intros h'; depelim h'. + rewrite H8. constructor; lia. + + move/(_ hge). intros h; depelim h. rewrite H6; constructor; lia. + * destruct concl0 as [concl0 k']. + apply valid_clause_intro => z hmin hgt. + have mins := min_premise_subset m _ _ H1. + rewrite min_premise_singleton in mins. + specialize (H1 (x, k+1)); forward H1 by now apply LevelExprSet.singleton_spec. + have hadd := min_premise_add_down H1 _ hmin. + exact: valid_clause_elim IHentails _ hadd hgt. +Qed. Lemma check_entails_false {cls cl} : check cls cl = false -> invalid_entailment cls cl. @@ -6675,6 +6996,7 @@ Proof. - intros _; clear Heq Heqcall. red in islooping. red. eapply (entails_all_shift 1) in islooping. eapply entails_all_succ_clauses in islooping. + intros he. eapply clauses_sem_entails_all in islooping; tea. rewrite interp_add_prems in islooping. lia. admit. - set (V := clause_levels (succ_clause cl) ∪ clauses_levels cls) in *. @@ -6684,6 +7006,7 @@ Proof. (* Found a value *) unfold valid_clause, level_value_above. move/leb_complete_conv => hgt. intro. + eapply entails_model_valid in H. 2:apply v. intros val ext. have vmupd := model_updates v. have vmok := model_ok v. From 9b139d7409e24a606770e0de56c3cf965c123e05 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 30 Aug 2025 23:19:55 +0200 Subject: [PATCH 029/164] Completeness relying on a few auxilliary lemmas --- template-rocq/theories/PartialLoopChecking.v | 163 ++++++++++++------- 1 file changed, 102 insertions(+), 61 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 5aa8602a3..5e6730336 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -6333,16 +6333,6 @@ Definition extendV V (cl : clause) := let '(prems, concl) := cl in (add_list (premises_of_level_set V) prems, concl). -Equations check (cls : clauses) (cl : clause) : bool := - check cls cl with loop_check cls (succ_clause cl) := - | Loop _ _ => false (* Actually impossible *) - | Model W v _ => - let '(concl, k) := concl cl in - match LevelMap.find concl v.(model_model) with - | Some v => (S k <=? v) - | None => false - end. - Lemma premises_model_map_min_premise {levels cls prems z} : min_premise (premises_model_map (zero_model levels) cls) prems = Some z -> (exists minp mink, LevelExprSet.In (minp, mink) prems /\ z = (Z.of_nat (max_clause_premise_of minp cls) - Z.of_nat mink)%Z) \/ @@ -6357,6 +6347,30 @@ Proof. exists minp, mink. split => //. lia. Qed. +Lemma premises_model_map_min_premise_inv {levels cls} : + forall cl, Clauses.In cl cls -> + exists z, min_premise (premises_model_map (zero_model levels) cls) (premise cl) = Some z /\ (0 <= z)%Z. +Proof. + set (m := premises_model_map _ _). + move=> cl hin. + have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m (premise cl). + rewrite mineq. rewrite /min_atom_value. + destruct level_value eqn:hl => //. + eexists. split; trea. + have ps := premises_model_map_spec _ cls minp n (level_value_MapsTo' hl). + destruct ps as [[minpsl eq]|]. + rewrite eq. + have sp := (max_clause_premise_of_spec _ _ _ _ hin inminp). lia. + destruct H. elim H. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. + unfold level_value in hl. + move/LevelMapFact.F.not_find_in_iff: hl; elim. + rewrite premises_model_map_in. left. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. +Qed. + Lemma is_update_of_entails {cls V m m' hne hne'} : is_update_of cls V m m' -> cls ⊢a of_level_map m hne → of_level_map m' hne'. Proof. @@ -6607,44 +6621,59 @@ Proof. now move/he: hin'. Qed. + +Variant check_result {cls} := + | IsLooping (v : univ) (islooping : loop_on_univ cls v) + | Invalid + | Valid. +Arguments check_result : clear implicits. + +Equations check (cls : clauses) (cl : clause) : check_result (succ_clauses cls) := + check cls cl with loop_check cls (succ_clause cl) := + | Loop v isl => IsLooping v isl + | Model W v _ with LevelMap.find (concl cl).1 v.(model_model) := { + | Some val with S (concl cl).2 <=? val := + { | true => Valid + | false => Invalid } + | None => Invalid + }. + (* If a clause checks, then it should be valid in any extension of the model *) Lemma check_entails {cls cl} : - check cls cl = true -> valid_entailment cls cl. + check cls cl = Valid -> valid_entailment cls cl. Proof. - funelim (check cls cl) => //. - set (V := clause_levels (succ_clause cl) ∪ clauses_levels cls) in *. - destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *. - destruct LevelMap.find as [conclval_v|] eqn:hfind => //. - (* Found a value *) - unfold valid_clause, level_value_above. - move/Nat.leb_le => hgt. - intros val ext. + destruct cl as [prems [concl k]]. + funelim (check cls _) => //. + set (V := clause_levels (succ_clause _) ∪ clauses_levels cls) in *. + clear Heqcall => _. cbn [concl fst snd] in *. + unfold valid_entailment, valid_clause, level_value_above. + move/Nat.leb_le: Heq => hgt. + intros valuation ext. have vmupd := model_updates v. have vmok := model_ok v. set (pm := premises_model_map _ _) in *. have nepm : ~ LevelMap.Empty pm. { apply premises_model_map_ne. - have zm := proj2 (@zero_model_spec concl V 0). + have zm := proj2 (@zero_model_spec concl0 V 0). forward zm. split => //. subst V. eapply LevelSet.union_spec. left. apply clause_levels_spec. now right. intros he. now move/he: zm. } have nev : ~ LevelMap.Empty (model_model v). by apply (is_update_of_non_empty nepm vmupd). move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. - set (cl := (prems, (concl, k))) in V. + set (cl := (prems, (concl0, k))) in V. have of_lset := of_level_map_premises_model_map (succ_clauses cls) (succ_clause cl) V nepm. have tr := entails_all_trans of_lset ent. - eapply (entails_all_satisfies (l := concl) (k := S k)) in tr. - 2:{ red. rewrite /level_value hfind. now constructor. } - have se := (succ_clauses_equiv cls V (premise cl) (concl, k)). + eapply (entails_all_satisfies (l := concl0) (k := S k)) in tr. + 2:{ red. rewrite /level_value Heq0. now constructor. } + have se := (succ_clauses_equiv cls V (premise cl) (concl0, k)). cbn in se, tr. rewrite Nat.add_1_r in se. specialize (se tr). eapply clauses_sem_entails in se ; tea. Qed. Definition invalid_entailment cls cl := - ~ entails cls cl. - (* forall V, clauses_sem V cls -> clause_sem V cl -> False. *) + forall V, clauses_sem V cls -> clause_sem V cl -> False. Definition infers_univ (m : model) (u : univ) := exists z, min_premise m u = Some z /\ (0 <= z)%Z. @@ -6989,25 +7018,44 @@ Proof. exact: valid_clause_elim IHentails _ hadd hgt. Qed. +Lemma check_entails_looping {cls cl v isl} : + check cls cl = IsLooping v isl -> cls ⊢a v → succ_prems v. +Proof. + funelim (check cls cl) => //. + intros [=]; subst v0. clear isl0 Heqcall. + red in isl. clear Heq; move: isl. + now move/(entails_all_shift 1)/entails_all_succ_clauses. +Qed. + +Lemma enabled_clause_ext {m m' cl} : + m ⩽ m' -> enabled_clause m cl -> enabled_clause m' cl. +Proof. + intros hext; rewrite /enabled_clause. + destruct cl as [prems [concl k]]; cbn; move=> [z [hm hpos]]. + have pr := min_premise_pres prems hext. + rewrite hm in pr. depelim pr. exists y. split => //. lia. +Qed. + Lemma check_entails_false {cls cl} : - check cls cl = false -> invalid_entailment cls cl. + check cls cl = Invalid -> ~ entails cls cl. Proof. funelim (check cls cl) => //. - - intros _; clear Heq Heqcall. red in islooping. red. - eapply (entails_all_shift 1) in islooping. - eapply entails_all_succ_clauses in islooping. - intros he. - eapply clauses_sem_entails_all in islooping; tea. - rewrite interp_add_prems in islooping. lia. admit. - - set (V := clause_levels (succ_clause cl) ∪ clauses_levels cls) in *. + - (* Found no value for the conclusion: impossible *) + clear Heq0 Heqcall prf => _ _. + set (V := clause_levels (succ_clause cl) ∪ clauses_levels cls) in *. + destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *. + have vmupd := model_of_V v. + set (pm := premises_model_map _ _) in *. + cbn in Heq. + move/LevelMapFact.F.not_find_in_iff: Heq; apply. + apply vmupd. rewrite LevelSet.union_spec; left. + rewrite clause_levels_spec. now right. + - (* Found a value *) + set (V := clause_levels (succ_clause cl) ∪ clauses_levels cls) in *. destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *. - destruct LevelMap.find as [conclval_v|] eqn:hfind => //. - 2:{ apply (todo "impossible, concl is in the model"). } - (* Found a value *) + rename val into conclval_v => _. clear Heq1 Heqcall prf. unfold valid_clause, level_value_above. - move/leb_complete_conv => hgt. intro. - eapply entails_model_valid in H. 2:apply v. - intros val ext. + move/leb_complete_conv: Heq => hgt. intro. have vmupd := model_updates v. have vmok := model_ok v. set (pm := premises_model_map _ _) in *. @@ -7021,26 +7069,19 @@ Proof. by apply (is_update_of_non_empty nepm vmupd). move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. set (cl := (prems, (concl, k))) in V. - have of_lset := of_level_map_premises_model_map (succ_clauses cls) (succ_clause cl) V nepm. - have tr := entails_all_trans of_lset ent. - eapply (entails_all_satisfies (l := concl) (k := conclval_v)) in tr. - 2:{ red. rewrite /level_value hfind. now constructor. } - have he : ~ cls ⊢ prems → (concl, k). - { intros he. eapply clauses_sem_entails in he; tea. - cbn in he. admit. } - destruct conclval_v. admit. - have se := (succ_clauses_equiv cls V (premise cl) (concl, conclval_v)). - cbn in se, tr. rewrite Nat.add_1_r in se. - specialize (se tr). - eapply clauses_sem_entails in se ; tea. cbn in se. cbn. -Qe - intros _. red in islooping. clear Heqcall Heq. - - admit. - - destruct cl as [prems [concl k]]; cbn. - destruct LevelMap.find eqn:heq. - destruct n. clear Heqcall. intros _. - red. intros val semcls. cbn. - - } + move/entails_plus: H. + move/entails_model_valid/(_ _ vmok). + have en : enabled_clause (model_model v) (succ_clause (prems, (concl, k))). + { apply (@enabled_clause_ext pm). + exact: is_update_of_ext (model_updates v). + red; cbn. + have hcl : Clauses.In (succ_clause cl) (Clauses.singleton (succ_clause cl)). + { now eapply Clauses.singleton_spec. } + exact: @premises_model_map_min_premise_inv V _ _ hcl. } + destruct en as [z [minp hge]]. + move/valid_clause_elim/(_ z minp hge). + cbn in minp. + rewrite /level_value Heq0 => h; depelim h. red in H. lia. +Qed. End LoopChecking. From 2cfec717181e0d98dc1fcc91f4f895b4097bb941 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sun, 31 Aug 2025 00:12:44 +0200 Subject: [PATCH 030/164] Completed proofs, including technical min_premise_add --- template-rocq/theories/PartialLoopChecking.v | 229 ++++++++++--------- 1 file changed, 124 insertions(+), 105 deletions(-) diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 5e6730336..feb396099 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -6739,29 +6739,6 @@ Proof. rewrite H0 -hm' hmin. f_equal. lia. Qed. -Lemma min_premise_add_down {m} {prems : univ} {l k} : - LevelExprSet.In (l, k + 1) prems -> - forall z, min_premise m prems = Some z -> - min_premise m (add (l, k) prems) = Some z. -Proof. - intros ine z hmin. - have [hle [min' [hin hm]]] := min_premise_spec m (add (l, k) prems). - have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. - move/LevelExprSet.add_spec: hin => [heq|hin]. - - noconf heq. - specialize (hle (l, k + 1)). - forward hle. eapply LevelExprSet.add_spec. now right. - rewrite hm in hle. - depelim hle. destruct level_value eqn:hl. noconf H0; noconf H1. lia. congruence. - destruct level_value eqn:hl' => //. - specialize (hle' _ ine). rewrite hmin in hle'; depelim hle'. - now rewrite hl' in H1. - - rewrite hm. specialize (hle' min' hin). rewrite hmin in hle'. - depelim hle'. rewrite H0. f_equal. rewrite H0 in hm. - specialize (hle min''). forward hle. eapply LevelExprSet.add_spec. now right. - rewrite hm in hle. rewrite -hm' hmin in hle. depelim hle. lia. -Qed. - Lemma fold_left_map {A B C} (f : B -> A -> A) (g : C -> B) l acc : fold_left (fun acc l => f (g l) acc) l acc = fold_left (fun acc l => f l acc) (map g l) acc. @@ -6780,12 +6757,61 @@ Proof. destruct n => //=; lia_f_equal. Qed. -Lemma fold_left_impl n n' l l' : - (forall x, In x (n :: l) <-> In x (n' :: l')) -> - fold_left (option_map2 Z.min) l n = fold_left (option_map2 Z.min) l' n'. +Lemma option_map2_comm x y : option_map2 Z.min x y = option_map2 Z.min y x. Proof. - intros. -Admitted. + destruct x, y; cbn; lia_f_equal. +Qed. + +Lemma option_map2_assoc x y z : + option_map2 Z.min x (option_map2 Z.min y z) = + option_map2 Z.min (option_map2 Z.min x y) z. +Proof. + destruct x, y, z; cbn; lia_f_equal. +Qed. + +Local Notation fn := (fold_left (option_map2 Z.min)). + +Lemma fold_left_impl n l : + (forall x, In x (n :: l) -> fn l n ≤Z x) /\ + (exists x, In x (n :: l) /\ fn l n = x). +Proof. + induction l in n |- *. + - cbn. split; intros. + destruct H => //. subst. reflexivity. + exists n. split => //. now left. + - cbn. split; intros. + { destruct (IHl n) as [hle [min [hin heq]]]. + rewrite fold_left_comm. + { now intros; rewrite -option_map2_assoc (option_map2_comm x0 y) option_map2_assoc. } + repeat destruct H; subst. + * specialize (hle n). forward hle. now left. + transitivity (fn l n); auto. eapply Zmin_opt_left. + * eapply Zmin_opt_right. + * transitivity (fn l n); auto. apply Zmin_opt_left. + apply hle. now right. } + * specialize (IHl (option_map2 Z.min n a)). + destruct IHl as [hle [min [hin heq]]]. subst min. eexists. split; trea. + destruct hin. + rewrite -H. + destruct n, a; cbn; firstorder. + destruct (Z.min_spec z z0) as [[? heq]|[? heq]]. + rewrite -{1}heq. now left. right; left. f_equal. lia. + now right. +Qed. + +Lemma fold_left_impl_eq n n' l l' : + (forall x, In x (n :: l) <-> In x (n' :: l' )) -> + fn l n = fn l' n'. +Proof. + intros heq. + destruct (fold_left_impl n l) as [hle [minl [hin heq']]]. + destruct (fold_left_impl n' l') as [hle' [minl' [hin' heq'']]]. + rewrite heq' heq''. + specialize (hle minl'). forward hle. now apply heq. + specialize (hle' minl). forward hle'. now apply heq. + rewrite heq'' in hle'. rewrite heq' in hle. depelim hle'. depelim hle. f_equal; lia. + now depelim hle. +Qed. Lemma fold_left_comm_f {A} (f : A -> A -> A) n l : (forall x y, f x y = f y x) -> @@ -6796,40 +6822,44 @@ Proof. unfold flip. now rewrite hf. Qed. -(* -Lemma min_premise_fold_equiv {A} (f : A -> A -> A) x x' l l' : - equivlistA eq (x :: l) (x' :: l') -> - NoDup (x :: l) -> - NoDup (x' :: l') -> - transpose eq f -> - fold_left f l x = - fold_left f l' x'. -Proof. - induction l in x', l' |- *. - - cbn. intros. - destruct (H x). destruct l' => //. cbn. - forward H3 by constructor; reflexivity. - now depelim H3. subst. - depelim H1. - destruct (H x). forward H6 by constructor; reflexivity. - depelim H6. subst. forward H4 by constructor; reflexivity. - forward H2 by constructor; reflexivity. - now depelim H. - destruct H as [H H']. forward H by constructor. reflexivity. - depelim H. subst. cbn. forward H'. constructor; reflexivity. - depelim H'. subst. *) - - -Lemma option_map2_comm x y : option_map2 Z.min x y = option_map2 Z.min y x. +Lemma min_premise_add {m le prems} : min_premise m (add le prems) = + option_map2 Z.min (min_atom_value m le) (min_premise m prems). Proof. - destruct x, y; cbn; lia_f_equal. -Qed. - -Lemma option_map2_assoc x y z : - option_map2 Z.min x (option_map2 Z.min y z) = - option_map2 Z.min (option_map2 Z.min x y) z. -Proof. - destruct x, y, z; cbn; lia_f_equal. + rewrite {1}/min_premise. + have hs' := to_nonempty_list_spec (add le prems). + destruct to_nonempty_list. + have eqf : (fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (min_atom_value m t)) = + (option_map2 Z.min (min_atom_value m le) (min_premise m prems)). + 2:{ now rewrite eqf. } + rewrite -(to_nonempty_list_spec' (add le prems)) in hs'. noconf hs'. + rewrite fold_left_map. rewrite fold_left_comm_f. intros [] []; cbn; auto. lia_f_equal. unfold flip. + have l := fold_left_impl_eq (min_atom_value m (to_nonempty_list (add le prems)).1) (min_atom_value m le) + (map (min_atom_value m) (to_nonempty_list (add le prems)).2) (map (min_atom_value m) (LevelExprSet.elements prems)). + rewrite l. + intros x. + { rewrite -!map_cons to_nonempty_list_spec' !in_map_iff. + split. + - move=> [] lk [] <-. + rewrite -InA_In_eq. + move/LevelExprSet.elements_spec1. + rewrite LevelExprSet.add_spec. + intros [->|inp]. + * exists le. split => //. now left. + * exists lk. split => //. right. now apply InA_In_eq, LevelExprSet.elements_spec1. + - intros [x' [<- hin]]. + exists x'. split => //. rewrite -InA_In_eq. + eapply LevelExprSet.elements_spec1. rewrite LevelExprSet.add_spec. + apply InA_In_eq in hin. depelim hin. now left. + eapply LevelExprSet.elements_spec1 in hin. now right. } + rewrite option_map2_comm. + rewrite /min_premise. + destruct (to_nonempty_list prems) eqn:he. + rewrite fold_left_map. + rewrite (fold_left_comm_f _ _ (map _ l0)). intros. apply option_map2_comm. + rewrite -(fold_left_comm (option_map2 Z.min)). + { intros. now rewrite -option_map2_assoc (option_map2_comm x y) option_map2_assoc. } + rewrite -(to_nonempty_list_spec' prems) he; cbn. + now rewrite option_map2_comm. Qed. Lemma min_premise_elim m (P : univ -> option Z -> Prop): @@ -6841,60 +6871,49 @@ Proof. eapply nonEmptyLevelExprSet_elim. - intros le. rewrite /min_premise. rewrite singleton_to_nonempty_list. cbn. apply hs. - - intros le prems hp. - rewrite /min_premise. - have hs' := to_nonempty_list_spec (add le prems). - destruct to_nonempty_list. - have eqf : (fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (min_atom_value m t)) = - (option_map2 Z.min (min_atom_value m le) (min_premise m prems)). - 2:{ rewrite eqf. now eapply hadd. } - rewrite -(to_nonempty_list_spec' (add le prems)) in hs'. noconf hs'. - rewrite fold_left_map. rewrite fold_left_comm_f. intros [] []; cbn; auto. lia_f_equal. unfold flip. - have l := fold_left_impl (min_atom_value m (to_nonempty_list (add le prems)).1) (min_atom_value m le) - (map (min_atom_value m) (to_nonempty_list (add le prems)).2) (map (min_atom_value m) (LevelExprSet.elements prems)). - rewrite l. - intros x. - { rewrite -!map_cons to_nonempty_list_spec' !in_map_iff. - split. - - move=> [] lk [] <-. - rewrite -InA_In_eq. - move/LevelExprSet.elements_spec1. - rewrite LevelExprSet.add_spec. - intros [->|inp]. - * exists le. split => //. now left. - * exists lk. split => //. right. now apply InA_In_eq, LevelExprSet.elements_spec1. - - intros [x' [<- hin]]. - exists x'. split => //. rewrite -InA_In_eq. - eapply LevelExprSet.elements_spec1. rewrite LevelExprSet.add_spec. - apply InA_In_eq in hin. depelim hin. now left. - eapply LevelExprSet.elements_spec1 in hin. now right. } - rewrite option_map2_comm. - rewrite /min_premise. - destruct (to_nonempty_list prems) eqn:he. - rewrite fold_left_map. - rewrite (fold_left_comm_f _ _ (map _ l0)). intros. apply option_map2_comm. - rewrite -(fold_left_comm (option_map2 Z.min)). - { intros. now rewrite -option_map2_assoc (option_map2_comm x y) option_map2_assoc. } - rewrite -(to_nonempty_list_spec' prems) he; cbn. - now rewrite option_map2_comm. + - intros le prems hp. now rewrite min_premise_add. +Qed. + +Lemma min_premise_add_down {m} {prems : univ} {l k} : + LevelExprSet.In (l, k + 1) prems -> + forall z, min_premise m prems = Some z -> + min_premise m (add (l, k) prems) = Some z. +Proof. + intros ine z hmin. + have [hle [min' [hin hm]]] := min_premise_spec m (add (l, k) prems). + have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. + move/LevelExprSet.add_spec: hin => [heq|hin]. + - noconf heq. + specialize (hle (l, k + 1)). + forward hle. eapply LevelExprSet.add_spec. now right. + rewrite hm in hle. + depelim hle. destruct level_value eqn:hl. noconf H0; noconf H1. lia. congruence. + destruct level_value eqn:hl' => //. + specialize (hle' _ ine). rewrite hmin in hle'; depelim hle'. + now rewrite hl' in H1. + - rewrite hm. specialize (hle' min' hin). rewrite hmin in hle'. + depelim hle'. rewrite H0. f_equal. rewrite H0 in hm. + specialize (hle min''). forward hle. eapply LevelExprSet.add_spec. now right. + rewrite hm in hle. rewrite -hm' hmin in hle. depelim hle. lia. Qed. Lemma add_prems_singleton n cl : add_prems n (singleton cl) = singleton (add_expr n cl). Proof. -Admitted. + apply eq_univ_equal => [] [l k]. + rewrite In_add_prems LevelExprSet.singleton_spec. + firstorder. + - destruct x; noconf H0. + eapply LevelExprSet.singleton_spec in H. + now red in H; noconf H. + - destruct cl. exists (t, n0). split => //. + red in H; noconf H. now apply LevelExprSet.singleton_spec. +Qed. Lemma min_premise_singleton m u : min_premise m (singleton u) = min_atom_value m u. Proof. now rewrite /min_premise singleton_to_nonempty_list; cbn. Qed. -Lemma min_premise_add m le u : min_premise m (add le u) = - option_map2 Z.min (min_atom_value m le) (min_premise m u). -Proof. - symmetry. - rewrite /min_premise. -Admitted. - Lemma min_atom_value_add m e x n : min_atom_value m e = Some x -> min_atom_value m (add_expr n e) = Some (x - Z.of_nat n)%Z. From c2a586f326932fb3f061a3adcc55e0b1ea99afb1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 6 Sep 2025 14:24:30 +0200 Subject: [PATCH 031/164] Model in Z requires partiality to make sense for checking --- template-rocq/theories/PartialLoopChecking.v | 1 + template-rocq/theories/PartialLoopCheckingZ.v | 7264 +++++++++++++++++ 2 files changed, 7265 insertions(+) create mode 100644 template-rocq/theories/PartialLoopCheckingZ.v diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index feb396099..5a9ac3733 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -5770,6 +5770,7 @@ Proof. - eapply is_update_of_empty. Qed. + (* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by setting a minimal value for the new atoms in [clauses_levels cls \ V] such that the new clauses [cls] do not hold vacuously. diff --git a/template-rocq/theories/PartialLoopCheckingZ.v b/template-rocq/theories/PartialLoopCheckingZ.v new file mode 100644 index 000000000..da9470a54 --- /dev/null +++ b/template-rocq/theories/PartialLoopCheckingZ.v @@ -0,0 +1,7264 @@ +(* Distributed under the terms of the MIT license. *) +From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils. + +From MetaRocq.Common Require Universes. +From Equations Require Import Equations. +Set Equations Transparent. + +Ltac rw l := rewrite_strat (topdown l). +Ltac rw_in l H := rewrite_strat (topdown l) in H. + + +(* TODO move *) +Arguments exist {A P}. +Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. + +Module FMapOrderedType_from_UsualOrderedType (O : UsualOrderedType). + Import O. + Definition t := O.t. + Definition eq : O.t -> O.t -> Prop := O.eq. + Definition lt : O.t -> O.t -> Prop := O.lt. + Definition eq_refl : forall x : O.t, eq x x := reflexivity. + Definition eq_sym : forall x y : O.t, eq x y -> eq y x := fun x y H => symmetry H. + + Lemma eq_trans : forall x y z, O.eq x y -> O.eq y z -> O.eq x z. + Proof. intros x y z. unfold O.eq. apply transitivity. Qed. + Lemma lt_trans : forall x y z, O.lt x y -> O.lt y z -> O.lt x z. + Proof. intros. eapply O.lt_strorder; tea. Qed. + + Lemma lt_not_eq : forall x y : O.t, lt x y -> ~ eq x y. + Proof. + intros x y H eq. do 2 red in eq. subst x. now eapply lt_strorder in H. + Qed. + + Definition compare : forall x y : O.t, Compare lt eq x y. + Proof. + intros. + case_eq (compare x y); intros. + apply EQ. abstract (destruct (compare_spec x y) => //). + apply LT. abstract (destruct (compare_spec x y) => //). + apply GT. abstract (destruct (compare_spec x y) => //). + Defined. + + Definition eq_dec : forall x y : O.t, {eq x y} + {~ eq x y} := eq_dec. +End FMapOrderedType_from_UsualOrderedType. + +Module Type LevelOrderedType. + Include UsualOrderedType. + + Parameter reflect_eq : ReflectEq t. + #[local] Existing Instance reflect_eq. + Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. + + Parameter to_string : t -> string. + +End LevelOrderedType. + +Module Type FMapOTInterface (E : UsualOrderedType). + Module OT := FMapOrderedType_from_UsualOrderedType E. + Include FMapInterface.Sfun OT. +End FMapOTInterface. + +Module Type LevelSet_fun (Level : LevelOrderedType). + Include SWithLeibniz with Module E := Level. +End LevelSet_fun. + +Module Type LevelExprItf (Level : LevelOrderedType). + Include UsualOrderedType with Definition t := (Level.t * Z)%type. + Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. +End LevelExprItf. + +Module Type LevelExprSet_fun (Level : LevelOrderedType) (LevelExpr : LevelExprItf Level). + Include SWithLeibniz with Module E := LevelExpr. + + Record nonEmptyLevelExprSet + := { t_set :> t ; + t_ne : is_empty t_set = false }. + + (* Parameter map : (LevelExpr.t -> LevelExpr.t) -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet. *) + + (* Parameter map_spec : forall e f u, In e (map f u) <-> exists e0, In e0 u /\ e = (f e0). *) + +End LevelExprSet_fun. + +Module Type LoopCheckingItf (Level : LevelOrderedType) + (LevelSet : LevelSet_fun Level) + (LevelExpr : LevelExprItf Level) + (LevelExprSet : LevelExprSet_fun Level LevelExpr) + (LevelMap : FMapOTInterface Level). + + Definition model := LevelMap.t Z. + Definition valuation := LevelMap.t nat. + + Definition clause : Type := LevelExprSet.nonEmptyLevelExprSet × LevelExpr.t. + + Parameter clauses : Type. + Parameter clauses_of_list : list clause -> clauses. + Parameter list_of_clauses : clauses -> list clause. + + Inductive constraint_type := UnivEq | UnivLe. + Notation constraint := (LevelExprSet.nonEmptyLevelExprSet * constraint_type * LevelExprSet.nonEmptyLevelExprSet). + + Parameter enforce_constraint : forall (cstr : constraint) (cls : clauses), clauses. + + Parameter valid_model : forall (V : LevelSet.t) (U : LevelSet.t) (m : model) (cls : clauses), Type. + + Parameter model_model : forall V U m cls, valid_model V U m cls -> model. + + (* { model_model : model; + model_of_V :> model_of V model_model; + model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; + model_ok :> is_model cls model_model; + model_extends : model_extension V m model_model; + }. *) + + Infix "⊂_lset" := LevelSet.Subset (at level 70). + + Parameter enforce_clauses : forall {V U init cls} (m : valid_model V U init cls) (cls' : clauses), option model. + + Parameter loop_on : forall w : LevelSet.t, ~ LevelSet.Empty w -> clauses -> Prop. + + Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := + | Loop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne cls) + | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). + + Parameter init_model : clauses -> model. + Parameter clauses_levels : clauses -> LevelSet.t. + + Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). + + Parameter infer : forall (cls : clauses), infer_result (clauses_levels cls) cls. + + Parameter print_result : forall {V cls}, infer_result V cls -> string. + + Parameter print_clauses : clauses -> string. + +End LoopCheckingItf. + +Module LoopChecking + (* Signature of levels: decidable, ordered type *) + (Level : LevelOrderedType) + (LevelSet : LevelSet_fun Level) + (LevelExpr : LevelExprItf Level) + (LevelExprSet : LevelExprSet_fun Level LevelExpr) + (LevelMap : FMapOTInterface Level) <: LoopCheckingItf Level LevelSet LevelExpr LevelExprSet LevelMap. + +Definition level (e : LevelExpr.t) : Level.t := fst e. +Definition levels (e : LevelExprSet.t) := + LevelExprSet.fold (fun le => LevelSet.add (level le)) e LevelSet.empty. + Import LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). + + +Local Existing Instance Level.reflect_eq. + +Module LevelSetFact := WFactsOn Level LevelSet. +Module LevelSetProp := WPropertiesOn Level LevelSet. +Module LevelSetDecide := LevelSetProp.Dec. +Module LevelMapFact := FMapFacts.WProperties_fun LevelMap.OT LevelMap. + +Ltac lsets := LevelSetDecide.fsetdec. +Notation "(=_lset)" := LevelSet.Equal (at level 0). +Infix "=_lset" := LevelSet.Equal (at level 30). +Infix "⊂_lset" := LevelSet.Subset (at level 70). +Infix "∪" := LevelSet.union (at level 70). + +Definition print_level_nat_map (m : LevelMap.t nat) := + let list := LevelMap.elements m in + print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_nat w) nl list. + +Definition print_lset (l : LevelSet.t) := + let list := LevelSet.elements l in + print_list Level.to_string " " list. + +Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. +Module LevelExprSetProp := WPropertiesOn LevelExpr LevelExprSet. + +(* We have decidable equality w.r.t leibniz equality for sets of levels. *) +#[global, program] Instance levelexprset_reflect : ReflectEq LevelExprSet.t := + { eqb := LevelExprSet.equal }. +Next Obligation. + destruct (LevelExprSet.equal x y) eqn:e; constructor. + eapply LevelExprSet.equal_spec in e. + now eapply LevelExprSet.eq_leibniz. + intros e'. + subst y. + pose proof (@LevelExprSetFact.equal_1 x x). + forward H. reflexivity. congruence. +Qed. + +#[global] Instance levelexprset_eq_dec : Classes.EqDec LevelExprSet.t := Classes.eq_dec. + +Derive NoConfusion for LevelExprSet.nonEmptyLevelExprSet. + +(* We use uip on the is_empty condition *) +#[global, program] Instance nonEmptyLevelExprSet_reflect : ReflectEq nonEmptyLevelExprSet := + { eqb x y := eqb x.(t_set) y.(t_set) }. +Next Obligation. + destruct (eqb_spec (t_set x) (t_set y)); constructor. + destruct x, y; cbn in *. subst. + now rewrite (uip t_ne0 t_ne1). + intros e; subst x; apply H. + reflexivity. +Qed. + +(** This coercion allows to see the non-empty set as a regular [LevelExprSet.t] *) +Coercion t_set : nonEmptyLevelExprSet >-> LevelExprSet.t. +Module LevelExprSetDecide := WDecide (LevelExprSet). +Ltac lesets := LevelExprSetDecide.fsetdec. +Infix "⊂_leset" := LevelExprSet.Subset (at level 70). + +Lemma levelset_not_Empty_is_empty s : + LevelSet.is_empty s = false <-> ~ LevelSet.Empty s. +Proof. + split. + - intros H he. red in he. apply negbT in H. unshelve eapply (contraNnot _ H). + 3:exact he. intros ha. now apply LevelSetFact.is_empty_1. + - intros ne. destruct LevelSet.is_empty eqn:he => //. + eapply LevelSetFact.is_empty_2 in he. contradiction. +Qed. + +Module NonEmptySetFacts. + #[program] Definition singleton (e : LevelExpr.t) : nonEmptyLevelExprSet + := {| t_set := LevelExprSet.singleton e |}. + Next Obligation. + apply negbTE. + eapply (contra_notN (P := LevelExprSet.Empty (LevelExprSet.singleton e))). + apply LevelExprSetFact.is_empty_2. intros ne. red in ne. specialize (ne e). lesets. + Qed. + + Lemma not_Empty_is_empty s : + ~ LevelExprSet.Empty s <-> LevelExprSet.is_empty s = false. + Proof. + split. + - intro H. apply not_true_is_false. intro H'. + apply H. now apply LevelExprSetFact.is_empty_2 in H'. + - intros H he. red in he. apply negbT in H. unshelve eapply (contraNnot _ H). + 3:exact he. intros ha. now apply LevelExprSetFact.is_empty_1. + Qed. + + Program Definition add (e : LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet + := {| t_set := LevelExprSet.add e u |}. + Next Obligation. + apply not_Empty_is_empty; intro H. + eapply H. eapply LevelExprSet.add_spec. + left; reflexivity. + Qed. + + Lemma add_spec e u e' : + LevelExprSet.In e' (add e u) <-> e' = e \/ LevelExprSet.In e' u. + Proof. + apply LevelExprSet.add_spec. + Qed. + + Definition add_list : list LevelExpr.t -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet + := List.fold_left (fun u e => add e u). + + Lemma add_list_spec l u e : + LevelExprSet.In e (add_list l u) <-> In e l \/ LevelExprSet.In e u. + Proof. + unfold add_list. rewrite <- fold_left_rev_right. + etransitivity. 2:{ eapply or_iff_compat_r. etransitivity. + 2: apply @InA_In_eq with (A:=LevelExpr.t). + eapply InA_rev. } + induction (List.rev l); cbn. + - split. intuition. intros [H|H]; tas. invs H. + - split. + + intro H. apply add_spec in H. destruct H as [H|H]. + * left. now constructor. + * apply IHl0 in H. destruct H as [H|H]; [left|now right]. + now constructor 2. + + intros [H|H]. inv H. + * apply add_spec; now left. + * apply add_spec; right. apply IHl0. now left. + * apply add_spec; right. apply IHl0. now right. + Qed. + + Lemma elements_not_empty {u : nonEmptyLevelExprSet} : LevelExprSet.elements u <> []. + Proof. + rewrite -LevelExprSetProp.elements_Empty. + move/LevelExprSetFact.is_empty_1. + destruct u as [u1 u2]; cbn in *. congruence. + Qed. + + Equations to_nonempty_list (u : nonEmptyLevelExprSet) : LevelExpr.t * list LevelExpr.t := + | u with inspect (LevelExprSet.elements u) := { + | exist [] eqel => False_rect _ (elements_not_empty eqel) + | exist (e :: l) _ => (e, l) }. + + Lemma singleton_to_nonempty_list e : to_nonempty_list (singleton e) = (e, []). + Proof. + funelim (to_nonempty_list (singleton e)). bang. + clear H. + pose proof (LevelExprSet.singleton_spec e1 e). + rewrite LevelExprSetFact.elements_iff in H. + rewrite InA_In_eq in H. rewrite e0 in H. + destruct H. forward H. now left. noconf H. f_equal. + pose proof (LevelExprSet.cardinal_spec (LevelExprSet.singleton e1)). rewrite e0 in H. cbn in H. + rewrite LevelExprSetProp.singleton_cardinal in H. + destruct l => //. + Qed. + + Lemma to_nonempty_list_spec u : + let '(e, u') := to_nonempty_list u in + e :: u' = LevelExprSet.elements u. + Proof. + funelim (to_nonempty_list u). bang. now rewrite e0. + Qed. + + Lemma to_nonempty_list_spec' u : + (to_nonempty_list u).1 :: (to_nonempty_list u).2 = LevelExprSet.elements u. + Proof. + pose proof (to_nonempty_list_spec u). + now destruct (to_nonempty_list u). + Qed. + + Lemma In_to_nonempty_list (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : + LevelExprSet.In e u + <-> e = (to_nonempty_list u).1 \/ In e (to_nonempty_list u).2. + Proof. + etransitivity. symmetry. apply LevelExprSet.elements_spec1. + pose proof (to_nonempty_list_spec' u) as H. + destruct (to_nonempty_list u) as [e' l]; cbn in *. + rewrite <- H; clear. etransitivity. apply InA_cons. + eapply or_iff_compat_l. apply InA_In_eq. + Qed. + + Lemma In_to_nonempty_list_rev (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : + LevelExprSet.In e u + <-> e = (to_nonempty_list u).1 \/ In e (List.rev (to_nonempty_list u).2). + Proof. + etransitivity. eapply In_to_nonempty_list. + apply or_iff_compat_l. apply in_rev. + Qed. + + Program Definition map (f : LevelExpr.t -> LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + {| t_set := LevelExprSetProp.of_list (List.map f (LevelExprSet.elements u)) |}. + Next Obligation. + have hs := to_nonempty_list_spec u. + destruct (to_nonempty_list u). rewrite -hs. cbn. + apply not_Empty_is_empty => he. apply (he (f t)). + lesets. + Qed. + + Lemma map_spec f u e : + LevelExprSet.In e (map f u) <-> exists e0, LevelExprSet.In e0 u /\ e = (f e0). + Proof. + unfold map; cbn. + rewrite LevelExprSetProp.of_list_1 InA_In_eq in_map_iff. + split. + - intros [x [<- hin]]. exists x. split => //. + rewrite -InA_In_eq in hin. now apply LevelExprSet.elements_spec1 in hin. + - intros [x [hin ->]]. exists x. split => //. + rewrite -InA_In_eq. now apply LevelExprSet.elements_spec1. + Qed. + + Program Definition non_empty_union (u v : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + {| t_set := LevelExprSet.union u v |}. + Next Obligation. + apply not_Empty_is_empty; intro H. + assert (HH: LevelExprSet.Empty u). { + intros x Hx. apply (H x). + eapply LevelExprSet.union_spec. now left. } + apply LevelExprSetFact.is_empty_1 in HH. + rewrite t_ne in HH; discriminate. + Qed. + + + Lemma eq_univ (u v : nonEmptyLevelExprSet) : + u = v :> LevelExprSet.t -> u = v. + Proof. + destruct u as [u1 u2], v as [v1 v2]; cbn. intros X; destruct X. + now rewrite (uip_bool _ _ u2 v2). + Qed. + + Lemma eq_univ_equal (u v : nonEmptyLevelExprSet) : + LevelExprSet.Equal u v <-> u = v. + Proof. + split. + - intro H. now apply eq_univ, LevelExprSet.eq_leibniz. + - intros ->; reflexivity. + Qed. + + Lemma eq_univ_elements (u v : nonEmptyLevelExprSet) : + LevelExprSet.elements u = LevelExprSet.elements v -> u = v. + Proof. + intro H. apply eq_univ. + destruct u as [u1 u2], v as [v1 v2]; cbn in *; clear u2 v2. + eapply LevelExprSet.eq_leibniz. red. + intros x. rewrite -!LevelExprSet.elements_spec1 H //. + Qed. + + Lemma univ_expr_eqb_true_iff (u v : nonEmptyLevelExprSet) : + LevelExprSet.equal u v <-> u = v. + Proof. + split. + - intros. + apply eq_univ_equal. now apply LevelExprSet.equal_spec. + - intros ->. now apply LevelExprSet.equal_spec. + Qed. + + Lemma univ_expr_eqb_comm (u v : nonEmptyLevelExprSet) : + LevelExprSet.equal u v <-> LevelExprSet.equal v u. + Proof. + transitivity (u = v). 2: transitivity (v = u). + - apply univ_expr_eqb_true_iff. + - split; apply eq_sym. + - split; apply univ_expr_eqb_true_iff. + Qed. + + + Lemma LevelExprSet_for_all_false f u : + LevelExprSet.for_all f u = false -> LevelExprSet.exists_ (negb ∘ f) u. + Proof. + intro H. rewrite LevelExprSetFact.exists_b. + rewrite LevelExprSetFact.for_all_b in H. + all: try now intros x y []. + induction (LevelExprSet.elements u); cbn in *; [discriminate|]. + apply andb_false_iff in H; apply orb_true_iff; destruct H as [H|H]. + left; now rewrite H. + right; now rewrite IHl. + Qed. + + Lemma LevelExprSet_For_all_exprs (P : LevelExpr.t -> Prop) (u : nonEmptyLevelExprSet) + : LevelExprSet.For_all P u + <-> P (to_nonempty_list u).1 /\ Forall P (to_nonempty_list u).2. + Proof. + etransitivity. + - eapply iff_forall; intro e. eapply imp_iff_compat_r. + apply In_to_nonempty_list. + - cbn; split. + + intro H. split. apply H. now left. + apply Forall_forall. intros x H0. apply H; now right. + + intros [H1 H2] e [He|He]. subst e; tas. + eapply Forall_forall in H2; tea. + Qed. + + Lemma add_comm {le le' e} : add le (add le' e) = add le' (add le e). + Proof. + apply eq_univ_equal. intros x. + rewrite !LevelExprSet.add_spec. firstorder. + Qed. + + #[program] + Definition univ_union (prems prems' : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + {| t_set := LevelExprSet.union prems prems' |}. + Next Obligation. + destruct prems, prems'; cbn. + destruct (LevelExprSet.is_empty (LevelExprSet.union _ _)) eqn:ise => //. + eapply LevelExprSetFact.is_empty_2 in ise. + eapply not_Empty_is_empty in t_ne0, t_ne1. + destruct t_ne0. lesets. + Qed. + + Lemma univ_union_spec u u' l : + LevelExprSet.In l (univ_union u u') <-> + LevelExprSet.In l u \/ LevelExprSet.In l u'. + Proof. + destruct u, u'; unfold univ_union; cbn. + apply LevelExprSet.union_spec. + Qed. + + Lemma univ_union_add_singleton u le : univ_union u (singleton le) = add le u. + Proof. + apply eq_univ_equal. + intros x. rewrite univ_union_spec LevelExprSet.singleton_spec add_spec. + intuition auto. + Qed. + + Lemma univ_union_comm {u u'} : univ_union u u' = univ_union u' u. + Proof. + apply eq_univ_equal. + intros x. rewrite !univ_union_spec. + intuition auto. + Qed. + + Lemma univ_union_add_distr {le u u'} : univ_union (add le u) u' = add le (univ_union u u'). + Proof. + apply eq_univ_equal. + intros x. rewrite !univ_union_spec !add_spec !univ_union_spec. + intuition auto. + Qed. + + +End NonEmptySetFacts. +Import NonEmptySetFacts. + +Notation univ := nonEmptyLevelExprSet. + +Definition clause : Type := univ × LevelExpr.t. + +Module Clause. + Definition t := clause. + + Definition eq : t -> t -> Prop := eq. + + Definition eq_equiv : RelationClasses.Equivalence eq := _. + + Inductive lt_ : t -> t -> Prop := + | lt_clause1 l e e' : LevelExpr.lt e e' -> lt_ (l, e) (l, e') + | lt_clause2 l l' b b' : LevelExprSet.lt l.(t_set) l'.(t_set) -> lt_ (l, b) (l', b'). + + Definition lt := lt_. + + Global Instance lt_strorder : RelationClasses.StrictOrder lt. + Proof. + constructor. + - intros x X; inversion X; subst. now eapply LevelExpr.lt_strorder in H1. + eapply LevelExprSet.lt_strorder; eassumption. + - intros x y z X1 X2; invs X1; invs X2; constructor; tea. + etransitivity; tea. + etransitivity; tea. + Qed. + + Definition lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt. + intros x x' H1 y y' H2. unfold lt. subst. reflexivity. + Qed. + + Definition compare (x y : t) : comparison := + match x, y with + | (l1, b1), (l2, b2) => + match LevelExprSet.compare l1.(t_set) l2.(t_set) with + | Eq => LevelExpr.compare b1 b2 + | x => x + end + end. + + Definition compare_spec : + forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y). + Proof. + intros [? ?] [? ?]; cbn; repeat constructor. + destruct (LevelExprSet.compare_spec n n0); repeat constructor; tas. + eapply LevelExprSet.eq_leibniz in H. apply NonEmptySetFacts.eq_univ in H. + subst. cbn in *. + destruct (LevelExpr.compare_spec t0 t1); repeat constructor; tas. now subst. + Qed. + + #[program] Global Instance reflect_eq_Z : ReflectEq Z := { + eqb := Z.eqb + }. + Next Obligation. + destruct (Z.eqb_spec x y); constructor => //. + Qed. + + Global Instance reflect_t : ReflectEq t := reflect_prod _ _ . + + Definition eq_dec : forall (l1 l2 : t), {l1 = l2} + {l1 <> l2} := Classes.eq_dec. + + Definition eq_leibniz (x y : t) : eq x y -> x = y := id. +End Clause. + +Module Clauses := MSetAVL.Make Clause. +Module ClausesFact := WFactsOn Clause Clauses. +Module ClausesProp := WPropertiesOn Clause Clauses. +Module ClausesDecide := WDecide (Clauses). +Ltac clsets := ClausesDecide.fsetdec. + +Definition clauses := Clauses.t. + +Lemma filter_add {p x s} : Clauses.Equal (Clauses.filter p (Clauses.add x s)) (if p x then Clauses.add x (Clauses.filter p s) else Clauses.filter p s). +Proof. + intros i. + rewrite Clauses.filter_spec. + destruct (eqb_spec i x); subst; + destruct (p x) eqn:px; rewrite !Clauses.add_spec !Clauses.filter_spec; intuition auto || congruence. +Qed. + +Local Instance proper_fold_transpose {A} (f : Clauses.elt -> A -> A) : + transpose eq f -> + Proper (Clauses.Equal ==> eq ==> eq) (Clauses.fold f). +Proof. + intros hf s s' Hss' x ? <-. + eapply ClausesProp.fold_equal; tc; tea. +Qed. +Existing Class transpose. + +Lemma clauses_fold_filter {A} (f : Clauses.elt -> A -> A) (p : Clauses.elt -> bool) cls acc : + transpose Logic.eq f -> + Clauses.fold f (Clauses.filter p cls) acc = + Clauses.fold (fun elt acc => if p elt then f elt acc else acc) cls acc. +Proof. + intros hf. + symmetry. eapply ClausesProp.fold_rec_bis. + - intros s s' a eq. intros ->. + eapply ClausesProp.fold_equal; tc. auto. + intros x. + rewrite !Clauses.filter_spec. + now rewrite eq. + - now cbn. + - intros. + rewrite H1. + rewrite filter_add. + destruct (p x) eqn:px => //. + rewrite ClausesProp.fold_add //. + rewrite Clauses.filter_spec. intuition auto. +Qed. + +Definition levelexpr_level : LevelExpr.t -> Level.t := fst. +Coercion levelexpr_level : LevelExpr.t >-> Level.t. +Extraction Inline levelexpr_level. + +Definition strict_subset (s s' : LevelSet.t) := + LevelSet.Subset s s' /\ ~ LevelSet.Equal s s'. + +Lemma strict_subset_incl (x y z : LevelSet.t) : LevelSet.Subset x y -> strict_subset y z -> strict_subset x z. +Proof. + intros hs []. split => //. lsets. + intros heq. apply H0. lsets. +Qed. + +Lemma strict_subset_cardinal s s' : strict_subset s s' -> LevelSet.cardinal s < LevelSet.cardinal s'. +Proof. + intros []. + assert (LevelSet.cardinal s <> LevelSet.cardinal s'). + { intros heq. apply H0. + intros x. split; intros. now apply H. + destruct (LevelSet.mem x s) eqn:hin. + eapply LevelSet.mem_spec in hin. + auto. eapply LevelSetProp.FM.not_mem_iff in hin. + exfalso. + eapply LevelSetProp.subset_cardinal_lt in hin; tea. + lia. } + enough (LevelSet.cardinal s <= LevelSet.cardinal s') by lia. + now eapply LevelSetProp.subset_cardinal. +Qed. + +Definition premise (cl : clause) := fst cl. +Definition concl (cl : clause) := snd cl. +Extraction Inline premise concl. + +Definition clause_levels cl := + LevelSet.union (levels (premise cl)) (LevelSet.singleton (levelexpr_level (concl cl))). + +Definition clauses_levels (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls LevelSet.empty. + +Lemma Clauses_In_elements l s : + In l (Clauses.elements s) <-> Clauses.In l s. +Proof. + rewrite ClausesFact.elements_iff. + now rewrite InA_In_eq. +Qed. + +Lemma clauses_levels_spec_aux l cls acc : + LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls acc) <-> + (exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl)) \/ LevelSet.In l acc. +Proof. + eapply ClausesProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k [hin hl]]. clsets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.union_spec. + split. + * intros [hin'|]. + left. exists x. split => //. + apply hadd. now left. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. + * intros [[k [ins'' ?]]|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma clauses_levels_spec l cls : + LevelSet.In l (clauses_levels cls) <-> + exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl). +Proof. + unfold clauses_levels. + rewrite clauses_levels_spec_aux. + intuition auto. lsets. +Qed. + +Instance clauses_levels_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_levels. +Proof. + intros cl cl' eq x. + rewrite !clauses_levels_spec. + now setoid_rewrite eq. +Qed. + +Lemma clause_levels_spec l cl : + LevelSet.In l (clause_levels cl) <-> + LevelSet.In l (levels (premise cl)) \/ l = levelexpr_level (concl cl). +Proof. + unfold clause_levels. + now rewrite LevelSet.union_spec LevelSet.singleton_spec. +Qed. + +Definition clause_conclusion cl := levelexpr_level (concl cl). + +Local Open Scope Z_scope. + +Definition model := LevelMap.t Z. + +Definition level_value (m : model) (level : Level.t) : option Z := LevelMap.find level m. + +Definition levelexpr_value (m : model) (atom : LevelExpr.t) := + level_value m (levelexpr_level atom). + +Extraction Inline levelexpr_value. + +Definition min_atom_value (m : model) (atom : LevelExpr.t) : option Z := + let '(l, k) := atom in + match level_value m l with + | None => None + | Some val => Some (val - k)%Z + end. + +Definition option_map2 {A} (f : A -> A -> A) (o o' : option A) : option A := + match o, o' with + | Some x, Some y => Some (f x y) + | None, Some _ + | Some _, None + | None, None => None + end. + +Definition min_premise (m : model) (l : nonEmptyLevelExprSet) : option Z := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (fun min atom => option_map2 Z.min (min_atom_value m atom) min) tl (min_atom_value m hd). + +Definition satisfiable_atom (m : model) (atom : Level.t * Z) : bool := + let '(l, k) := atom in + match level_value m l with + | Some val => k <=? val + | None => false + end. + +Definition satisfiable_premise (m : model) (l : nonEmptyLevelExprSet) := + LevelExprSet.for_all (satisfiable_atom m) l. + +(* Definition valid_clause (m : model) (cl : clause) := *) + (* implb (satisfiable_premise m (premise cl)) (satisfiable_atom m (concl cl)). *) +Definition level_value_above m l k := + match level_value m l with + | Some val => k <=? val + | None => false + end. + +Definition valid_clause (m : model) (cl : clause) := + let k0 := min_premise m (premise cl) in + match k0 with + | None => true + | Some k0 => + let (l, k) := concl cl in + level_value_above m l (k + k0) + end. + +Definition is_model (cls : clauses) (m : model) : bool := + Clauses.for_all (valid_clause m) cls. + +Inductive update_result := + | VacuouslyTrue + | Holds + | DoesntHold (wm : LevelSet.t × model). + +Definition update_model (m : model) l v : model := LevelMap.add l v m. + +Definition update_value (m : model) (cl : clause) : option model := + let k0 := min_premise m (premise cl) in + match k0 with + | None => None + | Some k0 => + let (l, k) := concl cl in + (* Does the conclusion also hold? + We optimize a bit here, rather than adding k0 in a second stage, + we do it already while checking the clause. In the paper, a second + pass computes this. + *) + if level_value_above m l (k + k0) then None + else Some (update_model m l (k + k0)) + end. + +Definition check_clause_model cl '(modified, m) := + match update_value m cl with + | None => (modified, m) + | Some m => (clause_conclusion cl :: modified, m) + end. + +Definition check_model_aux (cls : clauses) (wm : list Level.t × model) : list Level.t × model := + Clauses.fold check_clause_model cls wm. + +(* If check_model = None then we have a model of all clauses, + othewise, we return Some (W', m') where W ⊂ W' and the model has + been updated for at least one atom l ∈ W'. *) +Definition check_model (cls : clauses) (wm : LevelSet.t × model) : option (LevelSet.t × model) := + let '(modified, m) := check_model_aux cls ([], wm.2) in + match modified return option (LevelSet.t × model) with + | [] => None + | l => Some ((LevelSet.union (LevelSetProp.of_list l) wm.1), m) + end. + +Infix "=m" := LevelMap.Equal (at level 50). + +Definition strict_update m '(prems, (l, k)) m' := + exists v, + [/\ min_premise m prems = Some v, ~~ level_value_above m l (k + v) & + m' =m (LevelMap.add l (k + v) m)]. + +Inductive strictly_updates cls : LevelSet.t -> model -> model -> Prop := +| update_one m cl m' : Clauses.In cl cls -> + strict_update m cl m' -> strictly_updates cls (LevelSet.singleton (clause_conclusion cl)) m m' +| update_trans {ls ls' m m' m''} : + strictly_updates cls ls m m' -> + strictly_updates cls ls' m' m'' -> + strictly_updates cls (LevelSet.union ls ls') m m''. + +Lemma strictly_updates_step cls w m m' m'' : + strictly_updates cls w m m' -> + forall cl, Clauses.In cl cls -> strict_update m' cl m'' -> + strictly_updates cls (LevelSet.add (clause_conclusion cl) w) m m''. +Proof. + induction 1. + - intros. + replace (LevelSet.add (clause_conclusion cl0) (LevelSet.singleton (clause_conclusion cl))) + with (LevelSet.union (LevelSet.singleton (clause_conclusion cl)) (LevelSet.singleton (clause_conclusion cl0))). + eapply update_trans; eapply update_one; tea. + eapply LevelSet.eq_leibniz. red. lsets. + - intros. + specialize (IHstrictly_updates2 _ H1 H2). + replace (LevelSet.add (clause_conclusion cl) (LevelSet.union ls ls')) + with (LevelSet.union ls (LevelSet.add (clause_conclusion cl) ls')). + eapply update_trans; tea. + eapply LevelSet.eq_leibniz. red. lsets. +Qed. + +Lemma strictly_updates_weaken cls w cls' : + Clauses.Subset cls cls' -> + forall m m', strictly_updates cls w m m' -> strictly_updates cls' w m m'. +Proof. + intros hcls m m'. + induction 1. constructor => //. now eapply hcls. + econstructor 2; tea. +Qed. + +Lemma strictly_updates_W_trans cls m w m' cl m'' : + strictly_updates cls w m m' -> + strict_update m' cl m'' -> + strictly_updates (Clauses.add cl cls) (LevelSet.add (clause_conclusion cl) w) m m''. +Proof. + intros updW su. + destruct cl as [prems [concl k]]. + eapply strictly_updates_step; tea. + - eapply strictly_updates_weaken; tea. clsets. + - rewrite Clauses.add_spec. left; reflexivity. +Qed. + +#[local] Instance Clauses_For_All_proper : Proper (eq ==> Clauses.Equal ==> iff) Clauses.For_all. +Proof. + intros x y -> cl cl' eqcl. + unfold Clauses.For_all. now setoid_rewrite eqcl. +Qed. + +#[local] Instance Clauses_for_all_proper : Proper (eq ==> Clauses.Equal ==> eq) Clauses.for_all. +Proof. + intros x y -> cl cl' eqcl. + apply iff_is_true_eq_bool. + rewrite /is_true -!ClausesFact.for_all_iff. now rewrite eqcl. +Qed. + +#[local] Instance is_model_proper : Proper (Clauses.Equal ==> eq ==> eq) is_model. +Proof. + intros cl cl' eqcl x y ->. unfold is_model. now rewrite eqcl. +Qed. + + +Definition equal_model (m m' : model) := LevelMap.Equal m m'. + +#[local] Instance equal_model_equiv : Equivalence equal_model. +Proof. unfold equal_model. + split; try econstructor; eauto. + red. intros. now symmetry. + red; intros. now transitivity y. +Qed. + + +#[local] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. +Proof. + intros x y eqm l ? <-. unfold level_value. + unfold equal_model in eqm. + destruct LevelMap.find eqn:hl. + - eapply LevelMap.find_2 in hl. + rewrite eqm in hl. + eapply LevelMap.find_1 in hl. now rewrite hl. + - eapply LevelMapFact.F.not_find_in_iff in hl. + rewrite eqm in hl. + eapply LevelMapFact.F.not_find_in_iff in hl. + now rewrite hl. +Qed. + +#[local] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. +Proof. + intros m m' eqm ? ? ->. unfold min_atom_value. + destruct y => //. + now rewrite eqm. +Qed. + +#[local] Instance fold_left_ext {A B} : Proper (`=2` ==> eq ==> eq ==> eq) (@fold_left A B). +Proof. + intros f g hfg ? ? -> ? ? ->. + induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). +Qed. + +#[local] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. +Proof. + intros m m' eq ? ? ->. + unfold min_premise. + destruct to_nonempty_list. + now setoid_rewrite eq. +Qed. + +#[local] Instance update_model_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> LevelMap.Equal) update_model. +Proof. + intros m m' hm ? ? -> ? ? ->. + unfold update_model. + now rewrite hm. +Qed. + +#[local] Instance level_value_above_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> eq) level_value_above. +Proof. + intros m m' hm ? ? -> ? ? ->. + unfold level_value_above. + now rewrite hm. +Qed. + +Lemma eqlistA_eq {A} (l l' : list A) : eqlistA Logic.eq l l' -> l = l'. +Proof. + induction 1. + - reflexivity. + - now f_equal. +Qed. + +Instance clauses_elements_proper : Proper (Clauses.Equal ==> eq) Clauses.elements. +Proof. + intros cl cl' eq. + have sl := Clauses.elements_spec2 cl. + (* have nl := Clauses.elements_spec2w cl. *) + have sl' := Clauses.elements_spec2 cl'. + (* have nl' := Clauses.elements_spec2w cl'. *) + have heq := @SortA_equivlistA_eqlistA _ Logic.eq _ Clause.lt_. + do 3 forward heq by tc. + specialize (heq _ _ sl sl'). + forward heq. + red. intros x. + rewrite -! ClausesProp.Dec.F.elements_iff. apply eq. + now apply eqlistA_eq. +Qed. + +#[local] Instance check_model_aux_proper : Proper (Clauses.Equal ==> eq ==> eq) check_model_aux. +Proof. + intros ? ? eq ? ? ->. + rewrite /check_model_aux. + rewrite !ClausesProp.fold_spec_right. + now rewrite eq. +Qed. + +#[local] Instance check_model_proper : Proper (Clauses.Equal ==> eq ==> eq) check_model. +Proof. + intros cls cls' eq. + intros wm wm' ->. + unfold check_model. + destruct (check_model_aux cls _) eqn:eqc. + destruct (check_model_aux cls' _) eqn:eqc' => //. + pose proof (check_model_aux_proper cls cls' eq ([], wm'.2) _ eq_refl). + rewrite eqc eqc' in H. noconf H. + destruct l => //. +Qed. + +Instance strictly_updates_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) strictly_updates. +Proof. + intros ? ? H ? ? H' ? ? H'' ? ? H'''. + eapply LevelSet.eq_leibniz in H'. subst y0. + split. + induction 1 in y, H, y1, H'', y2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. + now rewrite <- H. move: H1; unfold strict_update. destruct cl as [premse []]. + intros [v []]; exists v; split; + try setoid_rewrite <- H; + try setoid_rewrite <- H''; + try setoid_rewrite <- H'''; firstorder. + eapply IHstrictly_updates1; firstorder. firstorder. + induction 1 in x, H, x1, H'', x2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. + now rewrite H. move: H1; unfold strict_update. destruct cl as [premse []]. + intros [v []]; exists v; split; + try setoid_rewrite H; + try setoid_rewrite H''; + try setoid_rewrite H'''; firstorder. + eapply IHstrictly_updates1; firstorder. firstorder. +Qed. + +Lemma update_value_valid {m cl} : + match update_value m cl with + | None => valid_clause m cl + | Some _ => ~~ valid_clause m cl + end. +Proof. + unfold update_value, valid_clause. + destruct cl as [prem [l k]]; cbn. + destruct min_premise => //. + unfold level_value_above; + destruct level_value => //. + destruct Z.leb => //. +Qed. + +Lemma check_clause_model_spec {cl w m w' m'} : + check_clause_model cl (w, m) = (w', m') -> + (w = w' -> m = m' /\ valid_clause m cl) /\ + (w <> w' -> w' = clause_conclusion cl :: w /\ + strictly_updates (Clauses.singleton cl) (LevelSet.singleton (clause_conclusion cl)) m m'). +Proof. + unfold check_clause_model. + destruct update_value eqn:upd; revgoals. + * intros [= <- <-]. split => //. split => //. + move: (@update_value_valid m cl). now rewrite upd. + * intros [= <- <-]. split => //. + + intros. eapply (f_equal (@List.length _)) in H. cbn in H; lia. + + intros _. split => //. constructor. clsets. unfold strict_update. + move: upd. unfold update_value. + destruct cl as [prems [concl k]]. cbn. + destruct min_premise => //. + destruct level_value_above eqn:hl => //. + intros [= <-]. + exists z. split => //. rewrite hl. split => //. +Qed. + +Derive Signature for InA. + +Lemma check_model_aux_spec {cls w m w' m'} : + check_model_aux cls (w, m) = (w', m') -> + (w = w' -> m = m' /\ is_model cls m) /\ + (w <> w' -> exists pref, w' = pref ++ w /\ strictly_updates cls (LevelSetProp.of_list pref) m m'). +Proof. + rewrite /check_model_aux /is_model. + revert w' m'. + eapply ClausesProp.fold_rec. + - intros s' he w' m' [= <- <-]. split => //. split => //. + eapply Clauses.for_all_spec. tc. intros x hin. now apply he in hin. + - clear. intros x [w'' m''] s' s'' inx nins' hadd ih w' m' cl. + specialize (ih _ _ eq_refl) as[]. + split; intros; subst. + + eapply check_clause_model_spec in cl as []. + destruct (eqb_spec w' w''). + { subst w''. specialize (H eq_refl) as []. specialize (H1 eq_refl) as []. split => //. congruence. + eapply Clauses.for_all_spec in H3. eapply Clauses.for_all_spec. all:tc. + intros ? hin. eapply hadd in hin as []; subst; firstorder. } + forward H0 by auto. forward H2 by auto. + destruct H0 as [pref [-> su]]. + destruct pref; cbn in *; try congruence. + destruct H2. eapply (f_equal (@List.length _)) in H0; cbn in H0. rewrite length_app in H0. lia. + + eapply check_clause_model_spec in cl as []. + destruct (eqb_spec w w''). + { subst w''. specialize (H eq_refl) as []. subst m''. + destruct (eqb_spec w w'); subst; try congruence. + specialize (H3 H) as []. subst w'. exists [clause_conclusion x]. split => //. + replace (LevelSetProp.of_list [clause_conclusion x]) with (LevelSet.singleton (clause_conclusion x)). + eapply ClausesProp.Add_Equal in hadd. rewrite hadd. eapply strictly_updates_weaken; tea. clsets. + eapply LevelSet.eq_leibniz. red. intros ?. rewrite LevelSetProp.of_list_1. firstorder. constructor. + rewrite LevelSet.singleton_spec in H3. firstorder. depelim H3. subst. lsets. depelim H3. } + specialize (H0 H4). + destruct (eqb_spec w'' w'); subst. + { specialize (H2 eq_refl) as []; subst m''. + destruct H0 as [pref []]. subst w'. exists pref; split => //. + eapply strictly_updates_weaken; tea. intros ? ?. eapply hadd. clsets. } + forward H3 by auto. destruct H3 as [->]. + destruct H0 as [pref [-> su]]. eexists (clause_conclusion x :: pref); split => //. + replace (LevelSetProp.of_list (clause_conclusion x :: pref)) with (LevelSet.union (LevelSetProp.of_list pref) (LevelSet.singleton (clause_conclusion x))). + eapply (strictly_updates_weaken _ _ s'') in su; tea; try firstorder. + eapply (strictly_updates_weaken _ _ s'') in H3; tea; try firstorder. + 2:{ intros ?; rewrite Clauses.singleton_spec. intros ->. now apply hadd. } + exact: update_trans _ su H3. + apply LevelSet.eq_leibniz. intros ?. cbn. lsets. +Qed. + +Lemma check_model_spec {cls w m w' m'} : + check_model cls (w, m) = Some (w', m') -> + exists w'', strictly_updates cls w'' m m' /\ w' = LevelSet.union w w''. +Proof. + unfold check_model. + destruct check_model_aux eqn:cm. + apply check_model_aux_spec in cm as []. + destruct l => //. forward H0. auto with datatypes. + intros [= <- <-]. destruct H0 as [pref [heq su]]. + rewrite app_nil_r in heq. subst pref. + exists (LevelSetProp.of_list (t :: l)). split => //. + eapply LevelSet.eq_leibniz. intros ?. cbn. lsets. +Qed. + + +Lemma strict_update_invalid m cl m' : strict_update m cl m' -> ~~ valid_clause m cl. +Proof. + destruct cl as [prems [concl k]]. + cbn. + intros [v [him hna heq]]. + rewrite /valid_clause. rewrite him //=. +Qed. + +Lemma strictly_updates_invalid cls w m m' : strictly_updates cls w m m' -> ~~ is_model cls m. +Proof. + induction 1. + - eapply strict_update_invalid in H0. + apply/negbT. unfold is_model. + destruct Clauses.for_all eqn:fa => //. + eapply Clauses.for_all_spec in fa; tc. eapply fa in H. + now rewrite H in H0. + - auto. +Qed. + +Lemma check_model_None {cls acc} : + check_model cls acc = None <-> is_model cls acc.2. +Proof. + unfold check_model. + destruct check_model_aux eqn:cm. + apply check_model_aux_spec in cm as [ne ex]. + destruct l => //. split => // _. now specialize (ne eq_refl) as []. + split => //. forward ex by auto with datatypes. destruct ex as [pref [eq su]]. + rewrite app_nil_r in eq; subst pref. + intros ism. eapply strictly_updates_invalid in su. + now rewrite ism in su. +Qed. + +Lemma check_model_updates_spec {cls w init_model m w' m'} : + check_model cls (w, m) = Some (w', m') -> + forall cls', strictly_updates cls' w init_model m -> + strictly_updates (Clauses.union cls cls') w' init_model m' /\ w ⊂_lset w'. +Proof. + move/check_model_spec => [w'' [su ->]]. + intros cls' su'. split. + eapply update_trans; eapply strictly_updates_weaken; tea; clsets. lsets. +Qed. + +Lemma strictly_updates_non_empty {cls W m m'} : + strictly_updates cls W m m' -> ~ LevelSet.Empty W. +Proof. + induction 1. + - intros he. specialize (he (clause_conclusion cl)). lsets. + - intros he. apply IHstrictly_updates2. lsets. +Qed. + +Lemma strictly_updates_non_empty_map {cls W m m'} : + strictly_updates cls W m m' -> ~ LevelMap.Empty m'. +Proof. + induction 1. + - intros he. specialize (he (clause_conclusion cl)). + destruct cl as [prems [concl k]]. + destruct H0 as [? [? ? heq]]. + setoid_rewrite heq in he. eapply (he (k + x)); cbn. + rewrite LevelMapFact.F.add_mapsto_iff. firstorder. + - intros he. now apply IHstrictly_updates2. +Qed. + +Definition clauses_conclusions (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.add (level (concl cl)) acc) cls LevelSet.empty. + +Lemma clauses_conclusions_spec a cls : + LevelSet.In a (clauses_conclusions cls) <-> + exists cl, Clauses.In cl cls /\ level (concl cl) = a. +Proof. + unfold clauses_conclusions. + eapply ClausesProp.fold_rec; clear. + - move=> s' he /=. rewrite LevelSetFact.empty_iff. + firstorder auto. + - move=> cl ls cls' cls'' hin hnin hadd ih. + rewrite LevelSet.add_spec. firstorder eauto. + specialize (H0 x). cbn in H0. + apply hadd in H1. firstorder eauto. + subst. left. now destruct x. +Qed. + +Lemma strictly_updates_incl {cls W m m'} : + strictly_updates cls W m m' -> W ⊂_lset clauses_conclusions cls. +Proof. + induction 1. + - intros x. rewrite clauses_conclusions_spec. firstorder. exists cl. + eapply LevelSet.singleton_spec in H1; red in H1; subst. split => //. + - lsets. +Qed. + +Lemma check_model_subset {cls v} : + forall w' v', check_model cls v = Some (w', v') -> ~ LevelSet.Empty w'. +Proof. + intros w' v'. + move/check_model_spec => [w'' [su ->]]. + eapply strictly_updates_non_empty in su. intros em. apply su. lsets. +Qed. + +Definition premise_restricted_to W cl := + LevelSet.subset (levels (premise cl)) W. + +Definition clause_restricted_to W cl := + LevelSet.subset (levels (premise cl)) W && + LevelSet.mem (level (concl cl)) W. + +Definition restrict_clauses (cls : clauses) (W : LevelSet.t) := + Clauses.filter (clause_restricted_to W) cls. + +Lemma in_restrict_clauses (cls : clauses) (concls : LevelSet.t) cl : + Clauses.In cl (restrict_clauses cls concls) <-> + [/\ LevelSet.In (level (concl cl)) concls, + LevelSet.Subset (levels (premise cl)) concls & + Clauses.In cl cls]. +Proof. + unfold restrict_clauses. + rewrite Clauses.filter_spec. + destruct cl. cbn. + rewrite andb_true_iff LevelSet.subset_spec LevelSet.mem_spec. + firstorder auto. +Qed. + +Lemma restrict_clauses_subset (cls : clauses) (concls : LevelSet.t) : Clauses.Subset (restrict_clauses cls concls) cls. +Proof. + intros x; rewrite in_restrict_clauses; now intros []. +Qed. + +Definition clauses_with_concl (cls : clauses) (concl : LevelSet.t) := + Clauses.filter (fun '(prem, concla) => LevelSet.mem (level concla) concl) cls. + +Lemma in_clauses_with_concl (cls : clauses) (concls : LevelSet.t) cl : + Clauses.In cl (clauses_with_concl cls concls) <-> + LevelSet.In (level (concl cl)) concls /\ Clauses.In cl cls. +Proof. + unfold clauses_with_concl. + rewrite Clauses.filter_spec. + destruct cl. rewrite LevelSet.mem_spec. cbn. firstorder eauto. +Qed. + +Lemma clauses_conclusions_clauses_with_concl cls concl : + LevelSet.Subset (clauses_conclusions (clauses_with_concl cls concl)) concl. +Proof. + intros x [cl []] % clauses_conclusions_spec. + eapply in_clauses_with_concl in H as []. + now rewrite H0 in H. +Qed. + +Lemma clauses_conclusions_restrict_clauses cls W : + LevelSet.Subset (clauses_conclusions (restrict_clauses cls W)) W. +Proof. + intros x [cl []] % clauses_conclusions_spec. + eapply in_restrict_clauses in H as []. + now rewrite H0 in H. +Qed. + +Definition in_clauses_conclusions (cls : clauses) (x : Level.t): Prop := + exists cl, Clauses.In cl cls /\ (level cl.2) = x. + +Definition v_minus_w_bound (W : LevelSet.t) (m : model) := + LevelMap.fold (fun w v acc => Z.max v acc) + (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0%Z. + +Definition levelexpr_k : LevelExpr.t -> Z := snd. +Coercion levelexpr_k : LevelExpr.t >-> Z. + +Definition level_expr_elt : LevelExprSet.elt -> LevelExpr.t := fun x => x. +Coercion level_expr_elt : LevelExprSet.elt >-> LevelExpr.t. + +Definition premise_min (l : nonEmptyLevelExprSet) : Z := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (B:=LevelExpr.t) (fun min atom => Z.min atom min) tl hd. + +Definition premise_max (l : nonEmptyLevelExprSet) : Z := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (B:=LevelExpr.t) (fun min atom => Z.max atom min) tl hd. + +Definition gain (cl : clause) : Z := + (levelexpr_k (concl cl)) - (premise_min (premise cl)). + +Definition max_gain (cls : clauses) := + Clauses.fold (fun cl acc => Nat.max (Z.to_nat (gain cl)) acc) cls 0%nat. + +Definition max_clause_premise (cls : clauses) := + Clauses.fold (fun cl acc => Z.max (premise_max (premise cl)) acc) cls 0%Z. + +Definition model_same_domain (m m' : model) := + forall l, LevelMap.In l m <-> LevelMap.In l m'. + +#[local] Instance model_same_domain_refl : Reflexive model_same_domain. +Proof. intros m l. reflexivity. Qed. + +#[local] Instance model_same_domain_trans : Transitive model_same_domain. +Proof. intros m m' m'' h h' l. rewrite (h l). apply h'. Qed. + + +Inductive opt_le {A} (le : relation A) : relation (option A) := +| opt_le_some x y : le x y -> opt_le le (Some x) (Some y) +| opt_le_none_some x : opt_le le None x. +Derive Signature for opt_le. + +Instance opt_le_refl {A} (le : relation A) : Reflexive le -> Reflexive (opt_le le). +Proof. + intros hre x; induction x; constructor; reflexivity. +Qed. + +Instance opt_le_trans {A} (le : relation A) : Transitive le -> Transitive (opt_le le). +Proof. + intros hre x; induction x; destruct y as [y|]; intros z H H'; depelim H; depelim H'; constructor. + now transitivity y. +Qed. + +Infix "≤" := (opt_le Z.le) (at level 50). + +Infix "≤Z" := (opt_le Z.le) (at level 50). + +Definition model_rel R (m m' : model) := + forall l k, LevelMap.MapsTo l k m -> exists k', LevelMap.MapsTo l k' m' /\ R k k'. + +Infix "⩽" := (model_rel Z.le) (at level 70). (* \leqslant *) + +Infix "⩹" := (model_rel Z.lt) (at level 70). + +Definition model_map_outside V (m m' : model) := + forall l, ~ LevelSet.In l V -> + forall k, LevelMap.MapsTo l k m <-> LevelMap.MapsTo l k m'. + +#[local] Instance model_map_outside_refl V : Reflexive (model_map_outside V). +Proof. intros m l. reflexivity. Qed. + +#[local] Instance model_map_outside_trans V : Transitive (model_map_outside V). +Proof. + intros m m' m'' h h' l hnin k. + rewrite (h l hnin k). now apply h'. +Qed. + +(** The termination proof relies on the correctness of check_model: + it does strictly increase a value but not above [max_gain cls]. +*) + +Lemma clauses_conclusions_diff cls s : + clauses_conclusions (Clauses.diff cls (clauses_with_concl cls s)) ⊂_lset + LevelSet.diff (clauses_conclusions cls) s. +Proof. + intros a. rewrite LevelSet.diff_spec !clauses_conclusions_spec. + firstorder eauto. + exists x; split => //. + now rewrite Clauses.diff_spec in H. + intros ha. + rewrite Clauses.diff_spec in H; destruct H as []. + apply H1. + rewrite in_clauses_with_concl. split => //. + now rewrite H0. +Qed. + +Lemma diff_eq U V : LevelSet.diff V U =_lset V <-> LevelSet.inter V U =_lset LevelSet.empty. +Proof. split. lsets. lsets. Qed. + +Lemma levelset_neq U V : LevelSet.equal U V = false -> ~ LevelSet.Equal U V. +Proof. intros eq heq % LevelSet.equal_spec. congruence. Qed. + +Lemma levelset_union_same U : LevelSet.union U U =_lset U. +Proof. lsets. Qed. + +Class Commutative {A} (f : A -> A -> A) := comm : forall x y, f x y = f y x. +Instance option_map_2_comm {A} f : @Commutative A f -> @Commutative (option A) (option_map2 f). +Proof. + intros com [x|] [y|] => //=. now rewrite comm. +Qed. + +Instance Zmin_comm : Commutative Z.min := Z.min_comm. +Instance Zmax_comm : Commutative Z.max := Z.max_comm. + +Instance nat_min_comm : Commutative Nat.min := Nat.min_comm. +Instance nat_max_comm : Commutative Nat.max := Nat.max_comm. + +Class Associative {A} (f : A -> A -> A) := assoc : forall x y z, f x (f y z) = f (f x y) z. +Instance option_map_2_assoc {A} f : @Associative A f -> @Associative (option A) (option_map2 f). +Proof. + intros assoc [x|] [y|] [z|]; cbn => //. now rewrite assoc. +Qed. + +Instance nat_min_assoc : Associative Nat.min := Nat.min_assoc. +Instance nat_max_assoc : Associative Nat.max := Nat.max_assoc. + + +Instance Zmin_assoc : Associative Z.min := Z.min_assoc. +Instance Zmax_assoc : Associative Z.max := Z.max_assoc. + +Lemma fold_left_comm {A B} (f : B -> A -> B) (l : list A) (x : A) (acc : B) : + (forall x y z, f (f z x) y = f (f z y) x) -> + fold_left f l (f acc x) = f (fold_left f l acc) x. +Proof. + intros. + induction l in acc, x |- *; cbn. auto. + rewrite -IHl. f_equal. now rewrite H. +Qed. + +Lemma fold_left_min_opt_comm {A} (f : A -> A -> A) l x acc : + Associative f -> Commutative f -> + fold_left (option_map2 f) l (option_map2 f acc x) = option_map2 f (fold_left (option_map2 f) l acc) x. +Proof. + intros ass c. rewrite fold_left_comm => //. + intros. rewrite -(assoc (f := option_map2 f)). + rewrite -(assoc (f := option_map2 f) z y x0). + f_equal. apply comm. +Qed. + +Lemma fold_left_le {A} {le} (f g : A -> LevelSet.elt -> A) l : + (forall acc acc' x, In x l -> le acc acc' -> le (f acc x) (g acc' x)) -> + forall acc acc', le acc acc' -> + le (fold_left f l acc) (fold_left g l acc'). +Proof. + intros hfg. + induction l => //. cbn. intros. + apply IHl. intros. apply hfg => //. now right. apply hfg => //. now left. +Qed. + +Local Open Scope nat_scope. +Lemma fold_left_ne_lt (f g : nat -> LevelSet.elt -> nat) l acc : + (forall (x y : LevelSet.elt) z, f (f z x) y = f (f z y) x) -> + (forall (x y : LevelSet.elt) z, g (g z x) y = g (g z y) x) -> + l <> [] -> + (forall acc acc' x, In x l -> (acc <= acc') -> (f acc x <= g acc' x)) -> + (forall acc acc' x, In x l -> (acc < acc') -> (f acc x < g acc' x)) -> + (exists x, In x l /\ forall acc acc', (acc <= acc') -> (f acc x < g acc' x)) -> + fold_left f l acc < fold_left g l acc. +Proof. + intros hf hg. + generalize (Nat.le_refl acc). + generalize acc at 2 4. + induction l in acc |- * => //. + intros. + destruct l; cbn. + { destruct H3 as [x []]. cbn in H3. destruct H3; subst => //. + now eapply (H4 acc acc0). } + cbn in IHl. + rewrite hf hg. + rewrite fold_left_comm //. rewrite (fold_left_comm g) //. + destruct H3 as [min [hmin hfg]]. + destruct hmin as [<-|hel]. + - apply hfg. apply fold_left_le => //. intros; eapply H1 => //. now right; right. + apply H1 => //. now right; left. + - apply H2. now left. eapply IHl => //. + * intros acc1 acc' x hin. apply (H1 acc1 acc' x). now right. + * intros acc1 acc' x hin. apply (H2 acc1 acc' x). now right. + * exists min. split => //. +Qed. +Close Scope nat_scope. + +Infix "↓" := clauses_with_concl (at level 70). (* \downarrow *) +Infix "⇂" := restrict_clauses (at level 70). (* \downharpoonright *) + +Lemma clauses_conclusions_diff_left cls W cls' : + clauses_conclusions (Clauses.diff (cls ↓ W) cls') ⊂_lset W. +Proof. + intros l. + rewrite clauses_conclusions_spec. + move=> [] cl. rewrite Clauses.diff_spec => [] [] []. + move/in_clauses_with_concl => [] hin ? ? eq. + now rewrite eq in hin. +Qed. + +Lemma clauses_conclusions_diff_restrict cls W cls' : + clauses_conclusions (Clauses.diff (cls ⇂ W) cls') ⊂_lset W. +Proof. + intros l. + rewrite clauses_conclusions_spec. + move=> [] cl. rewrite Clauses.diff_spec => [] [] []. + move/in_restrict_clauses => [] hin ? ? ? eq. + now rewrite eq in hin. +Qed. + +Lemma LevelSet_In_elements l s : + In l (LevelSet.elements s) <-> LevelSet.In l s. +Proof. + rewrite LevelSetFact.elements_iff. + now rewrite InA_In_eq. +Qed. + +Lemma clauses_empty_eq {s} : Clauses.Empty s -> Clauses.Equal s Clauses.empty. +Proof. clsets. Qed. + +Lemma valid_update_value {m cl} : + valid_clause m cl -> + match update_value m cl with + | None => true + | Some _ => false + end. +Proof. + unfold update_value, valid_clause. + destruct cl as [prem [l k]]; cbn. + destruct min_premise => //. + unfold level_value_above. + destruct level_value => //. + destruct Z.leb => //. +Qed. + +Lemma level_value_not_above_spec m l k : level_value_above m l k = false -> opt_le Z.lt (level_value m l) (Some k). +Proof. + unfold level_value_above; destruct level_value => // hlt; constructor. lia. +Qed. + +Lemma clauses_for_all_neg {p s}: + ~~ Clauses.for_all p s <-> ~ Clauses.For_all p s. +Proof. + intuition auto. + rewrite ClausesFact.for_all_iff in H0. red in H. now rewrite H0 in H. + revert H. apply contra_notN. + rewrite ClausesFact.for_all_iff //. +Qed. + +Lemma clauses_for_all_exists {p s}: + ~~ Clauses.for_all p s <-> Clauses.exists_ (fun x => ~~ p x) s. +Proof. + rewrite ClausesFact.for_all_b ClausesFact.exists_b. + induction (Clauses.elements s). + - cbn; auto. reflexivity. + - cbn. rewrite negb_and. intuition auto. + move/orP: H1 => [->|] //. move/H. intros ->. now rewrite orb_true_r. + move/orP: H1 => [->|] //. move/H0. intros ->. now rewrite orb_true_r. +Qed. +#[local] Instance model_le_refl R (HR : Reflexive R) : Reflexive (model_rel R). +Proof. intros x l k map. exists k; split => //. Qed. + +#[local] Instance model_le_trans R (HR : Transitive R) : Transitive (model_rel R). +Proof. intros m m' m'' mm' m'm'' l k map. + apply mm' in map as [k' [map ?]]. + apply m'm'' in map as [k'' [map ?]]. exists k''. split => //. + now transitivity k'. +Qed. + +Lemma update_model_monotone m l k : level_value m l ≤ Some k -> m ⩽ update_model m l k. +Proof. + intros hl. + intros l' k' maps. + unfold update_model. cbn. + destruct (eqb_spec l l'). + - subst l'. exists k. move: hl. + unfold level_value. + rewrite (LevelMap.find_1 maps). + intros hle. + split => //. eapply LevelMap.add_1. eapply LevelMap.OT.eq_refl. now depelim hle. + - exists k'. split => //. apply LevelMap.add_2 => //. lia. +Qed. + +Lemma update_model_not_above m l k : level_value_above m l k = false -> m ⩽ update_model m l k. +Proof. + unfold level_value_above. + intros hlev. + apply update_model_monotone. + destruct level_value as [v|] eqn:hv; constructor; lia. +Qed. + +Lemma level_value_MapsTo {l k} {m : model} : + LevelMap.MapsTo l k m -> level_value m l = Some k. +Proof. + unfold level_value. + move=> mapto; rewrite (LevelMap.find_1 mapto) //. +Qed. + +Lemma level_value_MapsTo' {l k} {m : model} : + level_value m l = Some k -> LevelMap.MapsTo l k m. +Proof. + unfold level_value. destruct LevelMap.find eqn:hfind => //. + eapply LevelMap.find_2 in hfind. now intros [= ->]. +Qed. + +Lemma strict_update_ext m cl m' : strict_update m cl m' -> m ⩽ m'. +Proof. + destruct cl as [prems [concl k]]. + unfold strict_update. + intros [v [hm ha heq]]. + intros x k' hin. setoid_rewrite heq. + setoid_rewrite LevelMapFact.F.add_mapsto_iff. + destruct (Level.eq_dec concl x). subst. + move: ha; rewrite /level_value_above. + eapply level_value_MapsTo in hin. rewrite hin. + intros hlt'. + exists (k + v). + split. left. split; reflexivity. + move/negbTE: hlt'. + elim: Z.leb_spec => //. lia. + exists k'. split => //. right; eauto. lia. +Qed. + +Lemma strictly_updates_ext cls w m m' : strictly_updates cls w m m' -> m ⩽ m'. +Proof. + induction 1. + now eapply strict_update_ext in H0. + now transitivity m'. +Qed. + +Lemma check_model_le {cls acc acc'} : + check_model cls acc = Some acc' -> acc.2 ⩽ acc'.2. +Proof. + destruct acc as [w m], acc' as [w' m']. + move/check_model_spec => [w'' [su ->]]. + cbn. now eapply strictly_updates_ext. +Qed. + +Lemma level_value_update_model m l k : + level_value (update_model m l k) l = Some k. +Proof. + unfold level_value, update_model. + cbn -[LevelMap.find LevelMap.add]. + rewrite LevelMapFact.F.add_o. + destruct LevelMap.OT.eq_dec => //. + exfalso. now apply n. +Qed. + +Lemma model_map_outside_weaken {W W'} {m m' : model} : + model_map_outside W m m' -> + W ⊂_lset W' -> + model_map_outside W' m m'. +Proof. + intros hm sub x hin k. + apply hm. intros hin'. apply sub in hin'. now apply hin. +Qed. + +Lemma is_model_union {cls cls' m} : + is_model cls m -> is_model cls' m -> is_model (Clauses.union cls cls') m. +Proof. + rewrite /is_model. rewrite /is_true -!ClausesFact.for_all_iff. + now move=> ism ism' x /Clauses.union_spec []. +Qed. + +Lemma model_le_values {m m' : model} x : m ⩽ m' -> level_value m x ≤ level_value m' x. +Proof. + intros lem. specialize (lem x). + unfold level_value. + destruct LevelMap.find eqn:hl => //. + - apply LevelMap.find_2 in hl. specialize (lem _ hl) as [k' [mapsto leq]]. + rewrite (LevelMap.find_1 mapsto). now constructor. + - constructor. +Qed. + +Infix "⊂_clset" := Clauses.Subset (at level 70). + +Lemma max_gain_in cl cls : + Clauses.In cl cls -> + (Z.to_nat (gain cl) <= max_gain cls)%nat. +Proof. + intros hin. + unfold max_gain. revert cl hin. + eapply ClausesProp.fold_rec. + - intros s' ise hin. firstorder eauto. + - intros x a s' s'' xs nxs' hadd IH cl' hin'. + eapply hadd in hin' as []. + * subst x. lia. + * specialize (IH _ H). lia. +Qed. + +Definition max_gain_subset (cls cls' : Clauses.t) : + cls ⊂_clset cls' -> + (max_gain cls <= max_gain cls')%nat. +Proof. + unfold max_gain at 1. + revert cls'. + eapply ClausesProp.fold_rec. + - intros s' ise sub. lia. + - intros x a s' s'' xs nxs' hadd IH cls'' hs. + specialize (IH cls''). forward IH. transitivity s'' => //. + intros ??. now apply hadd. + assert (incls'' : Clauses.In x cls''). + { now apply hs, hadd. } + apply max_gain_in in incls''. lia. +Qed. + +Lemma max_clause_premise_spec cl cls : + Clauses.In cl cls -> + (premise_max (premise cl) <= max_clause_premise cls)%Z. +Proof. + intros hin. + unfold max_clause_premise. revert cl hin. + eapply ClausesProp.fold_rec. + - intros s' ise hin. firstorder eauto. + - intros x a s' s'' xs nxs' hadd IH cl' hin'. + eapply hadd in hin' as []. + * subst x. lia. + * specialize (IH _ H). lia. +Qed. + +Notation cls_diff cls W := (Clauses.diff (cls ↓ W) (cls ⇂ W)) (only parsing). + +(* + Equations? extend_model {W cls} (m : valid_model W (cls ⇂ W)) + (r : result W (Clauses.diff (cls ↓ W) (cls ⇂ W))) + : result W (cls ↓ W) := + extend_model _ Loop := Loop; + extend_model m (Model w m' sub) := + Model w {| model_model := m'.(model_model) |} _. + Proof. + - apply LevelSet.subset_spec in sub. now apply clauses_conclusions_clauses_with_concl in H. + - eapply sub. now eapply m.(model_clauses_conclusions). + - apply m. + - eapply LevelSet.subset_spec. eapply LevelSet.subset_spec in sub. + now transitivity V. + Qed. + + *) + +Lemma not_mem l s : ~~ LevelSet.mem l s <-> ~ LevelSet.In l s. +Proof. + split. apply contraNnot. apply LevelSet.mem_spec. + eapply contra_notN; tea. now move/LevelSet.mem_spec. +Qed. + +Lemma v_minus_w_bound_irrel {W} m m' : + model_map_outside W m m' -> + v_minus_w_bound W m = v_minus_w_bound W m'. +Proof. + unfold v_minus_w_bound. + intros out. eapply LevelMapFact.fold_Equal. tc. cbn. + { intros x y eq. cbn. solve_proper. } + { intros x y. cbn. intros e e' a neq. lia. } + apply LevelMapFact.F.Equal_mapsto_iff. + intros k e. rewrite -> LevelMapFact.filter_iff. + 2:{ intros x y eq. red in eq. subst; solve_proper. } + rewrite -> LevelMapFact.filter_iff. + 2:{ move=> x y ->. solve_proper. } + rewrite [_ = true]not_mem. intuition auto. + - now apply out. + - now apply out. +Qed. + +Definition max_premise_value (m : model) (l : nonEmptyLevelExprSet) : option Z := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (fun min atom => option_map2 Z.max (levelexpr_value m atom) min) tl (levelexpr_value m hd). + +Definition non_W_atoms W (l : LevelExprSet.t) := + LevelExprSet.filter (fun lk => ~~ LevelSet.mem lk.1 W) l. + +Lemma non_W_atoms_spec W l : forall x, LevelExprSet.In x (non_W_atoms W l) <-> LevelExprSet.In x l /\ ~ LevelSet.In x.1 W. +Proof. + intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec -not_mem. +Qed. + +Lemma non_W_atoms_subset W l : non_W_atoms W l ⊂_leset l. +Proof. intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec. Qed. + +Lemma levelexprset_levels_spec_aux l (e : LevelExprSet.t) acc : + LevelSet.In l (LevelExprSet.fold (fun le : LevelExprSet.elt => LevelSet.add (level le)) e acc) <-> + (exists k, LevelExprSet.In (l, k) e) \/ LevelSet.In l acc. +Proof. + eapply LevelExprSetProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k hin]. lesets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.add_spec. + split. + * intros [->|]. + left. exists (levelexpr_k x). red in H. subst. + apply hadd. cbn. left. now destruct x. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. apply hadd. now right. + * intros [[k ins'']|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma levelexprset_levels_spec l (e : LevelExprSet.t) : + LevelSet.In l (levels e) <-> exists k, LevelExprSet.In (l, k) e. +Proof. + rewrite levelexprset_levels_spec_aux. intuition auto. lsets. +Qed. + +Lemma levels_exprs_non_W_atoms {W prem} : + LevelSet.Equal (levels (non_W_atoms W prem)) (LevelSet.diff (levels prem) W). +Proof. + intros e. unfold non_W_atoms. + rewrite levelexprset_levels_spec LevelSet.diff_spec levelexprset_levels_spec. + firstorder eauto. + rewrite LevelExprSet.filter_spec in H. now exists x. + rewrite LevelExprSet.filter_spec in H. destruct H. + rewrite LevelSetFact.not_mem_iff. + destruct LevelSet.mem => //. + exists x. + rewrite LevelExprSet.filter_spec. split => //. + rewrite LevelSetFact.not_mem_iff in H0. now rewrite H0. +Qed. + +Lemma levelexprset_empty_levels x : LevelExprSet.Empty x <-> LevelSet.Empty (levels x). +Proof. + split. + - intros he. + intros l hin. + eapply levelexprset_levels_spec in hin as [k hin]. lesets. + - intros emp l hin. eapply emp. eapply (levelexprset_levels_spec l.1). exists l.2. + now destruct l. +Qed. + +Lemma non_W_atoms_ne W cl cls : + Clauses.In cl (cls_diff cls W) -> + LevelExprSet.is_empty (non_W_atoms W (premise cl)) = false. +Proof. + intros x. + apply Clauses.diff_spec in x as [clw clr]. + eapply in_clauses_with_concl in clw as [clw incls]. + apply/negbTE. + apply/(contra_notN _ clr). + intros he. rewrite in_restrict_clauses. split => //. + epose proof (@levels_exprs_non_W_atoms W (premise cl)). + eapply LevelExprSetFact.is_empty_2 in he. + intros x hin. eapply levelexprset_empty_levels in he. rewrite H in he. + specialize (he x). rewrite LevelSet.diff_spec in he. intuition auto. + rewrite -LevelSet.mem_spec in H1 |- *. destruct LevelSet.mem; intuition auto. +Qed. + +Local Open Scope Z_scope. + +Section MoreNonEmpty. + + Import LevelExprSet. + Lemma In_elements {x} {s : LevelExprSet.t} : In x s <-> List.In x (elements s). + Proof. + split. now move/LevelExprSetFact.elements_1/InA_In_eq. + now move/InA_In_eq/LevelExprSetFact.elements_2. + Qed. + Import NonEmptySetFacts. + + Notation min_opt := (option_map2 Z.min). + Lemma Zmin_opt_left x y : min_opt x y ≤Z x. + Proof. + destruct x as [x|], y as [y|]; constructor. lia. + Qed. + + Lemma Zmin_opt_right x y : min_opt x y ≤Z y. + Proof. + destruct x as [x|], y as [y|]; constructor. lia. + Qed. + + Lemma min_opt_spec x y z : min_opt x y = z -> (z = y \/ z = x). + Proof. + destruct x as [x|], y as [y|], z as [z|]; cbn; intuition auto. + - noconf H. pose proof (Zmin_irreducible x y). destruct H; intuition (f_equal; auto). + - noconf H. + Qed. + + Lemma min_premise_spec_aux (m : model) s k : + min_premise m s = k -> + (forall x, LevelExprSet.In x s -> (k ≤Z min_atom_value m x)) /\ + (exists x, LevelExprSet.In x s /\ k = min_atom_value m x). + Proof. + unfold min_premise. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. reflexivity. + now exists t0; split => //. + - destruct IHl as [ha hex]. + split. + * intros x hin. + eapply (in_elt_inv x a [t0]) in hin as [<-|inih]. + { cbn. rewrite fold_left_comm. + { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } + apply Zmin_opt_left. } + specialize (ha _ inih). + cbn. rewrite fold_left_comm. + { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } + etransitivity; [apply Zmin_opt_right|assumption]. + * destruct hex as [minval [inmin ih]]. + cbn. rewrite fold_left_comm. + { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } + rewrite ih. + destruct (min_opt_spec (min_atom_value m a) (min_atom_value m minval) _ eq_refl). + { rewrite H. exists minval. cbn in inmin. split; [intuition|reflexivity]. } + { rewrite H. exists a. cbn in inmin. split; [intuition|reflexivity]. } + Qed. + + Lemma min_premise_spec (m : model) (s : nonEmptyLevelExprSet) : + (forall x, LevelExprSet.In x s -> min_premise m s ≤Z min_atom_value m x) /\ + (exists x, LevelExprSet.In x s /\ min_premise m s = min_atom_value m x). + Proof. + now apply min_premise_spec_aux. + Qed. + + Lemma min_premise_subset (m : model) (s s' : nonEmptyLevelExprSet) : + LevelExprSet.Subset s s' -> + min_premise m s' ≤Z min_premise m s. + Proof. + intros sub. + have [has [mins [ins eqs]]] := min_premise_spec m s. + have [has' [mins' [ins' eqs']]] := min_premise_spec m s'. + specialize (sub _ ins). specialize (has' _ sub). + now rewrite eqs. + Qed. + + Lemma premise_min_spec_aux s k : + premise_min s = k -> + (forall x, LevelExprSet.In x s -> (k <= x)%Z) /\ + (exists x, LevelExprSet.In x s /\ k = x). + Proof. + unfold premise_min. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. reflexivity. + now exists t0; split => //. + - destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [t0]) in H as [<-|inih]. + cbn. rewrite fold_left_comm. unfold level_expr_elt in *; lia. unfold level_expr_elt in *; lia. + specialize (ha _ inih). + cbn. rewrite fold_left_comm. lia. lia. + destruct hex as [minval [inmin ih]]. + cbn. rewrite fold_left_comm. lia. + destruct (Z.leb_spec a minval). + exists a. split; [intuition|]. rewrite -ih in H. unfold level_expr_elt in *; lia. + exists minval. + cbn in inmin; split; [intuition auto|]. lia. + Qed. + + Lemma premise_min_spec (s : nonEmptyLevelExprSet) : + (forall x, LevelExprSet.In x s -> premise_min s <= x) /\ + (exists x, LevelExprSet.In x s /\ premise_min s = x). + Proof. + now apply premise_min_spec_aux. + Qed. + + Lemma premise_max_spec_aux s k : + premise_max s = k -> + (forall x, LevelExprSet.In x s -> x <= k) /\ + (exists x, LevelExprSet.In x s /\ k = x). + Proof. + unfold premise_max. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. reflexivity. + now exists t0; split => //. + - destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [t0]) in H as [<-|inih]. + cbn. rewrite fold_left_comm. unfold level_expr_elt in *; lia. unfold level_expr_elt in *; lia. + specialize (ha _ inih). + cbn. rewrite fold_left_comm. lia. lia. + destruct hex as [maxval [inmin ih]]. + cbn. rewrite fold_left_comm. lia. + destruct (Z.leb_spec a maxval). + exists maxval. cbn in inmin; split; [intuition auto|]. lia. + exists a. split; [intuition|]. rewrite -ih in H. cbn in inmin. + unfold level_expr_elt in *; lia. + Qed. + + Lemma premise_max_spec (s : nonEmptyLevelExprSet) : + (forall x, LevelExprSet.In x s -> x <= premise_max s) /\ + (exists x, LevelExprSet.In x s /\ premise_max s = x). + Proof. + now apply premise_max_spec_aux. + Qed. + + Lemma premise_min_subset (s s' : nonEmptyLevelExprSet) : + LevelExprSet.Subset s s' -> + (premise_min s' <= premise_min s). + Proof. + intros sub. + have [has [mins [ins eqs]]] := premise_min_spec s. + have [has' [mins' [ins' eqs']]] := premise_min_spec s'. + specialize (sub _ ins). specialize (has' _ sub). + lia. + Qed. + + Lemma fold_comm_assoc_nat x y z : option_map2 Nat.max x (option_map2 Nat.max y z) = + option_map2 Nat.max y (option_map2 Nat.max x z). + Proof. + now rewrite (assoc (f := option_map2 Nat.max)) (comm (f := option_map2 Nat.max) x y) -assoc. + Qed. + + Lemma fold_comm_assoc x y z : option_map2 Z.max x (option_map2 Z.max y z) = + option_map2 Z.max y (option_map2 Z.max x z). + Proof. + now rewrite (assoc (f := option_map2 Z.max)) (comm (f := option_map2 Z.max) x y) -assoc. + Qed. + + Notation max_opt := (option_map2 Z.max). + + Lemma max_opt_spec x y z : max_opt x y = Some z -> exists x' y', x = Some x' /\ y = Some y' /\ z = Z.max x' y'. + Proof. + destruct x as [x|], y as [y|]; cbn; intuition eauto; try noconf H. + exists x, y. auto. + Qed. + + Lemma max_premise_value_spec_aux (m : model) s k : + max_premise_value m s = Some k -> + (forall x, LevelExprSet.In x s -> exists k', levelexpr_value m x = Some k' /\ Some k' ≤ Some k) /\ + (exists x, LevelExprSet.In x s /\ Some k = levelexpr_value m x). + Proof. + unfold max_premise_value. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + induction l in k |- *. + - cbn. + intros eq. + split. intros x [->|] => //. exists k. split => //. reflexivity. + now exists t0; split => //. + - cbn. rewrite fold_left_comm. intros; apply fold_comm_assoc. + intros heq. apply max_opt_spec in heq as [y' [z' [eqa [eqf ->]]]]. + specialize (IHl _ eqf). destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [t0]) in H as [<-|inih]. + { exists y'; intuition eauto. constructor; lia. } + { specialize (ha _ inih) as [k' []]. exists k'; intuition eauto. constructor. depelim H0; lia. } + destruct hex as [maxval [inmax ih]]. + cbn. + destruct (Z.leb_spec z' y'). + exists a. split; [intuition|]. rewrite eqa. f_equal. lia. + exists maxval. cbn in inmax; split; [intuition auto|]. rewrite -ih. f_equal; lia. + Qed. + + Lemma max_premise_value_spec (m : model) (s : nonEmptyLevelExprSet) k : + max_premise_value m s = Some k -> + (forall x, LevelExprSet.In x s -> exists k', levelexpr_value m x = Some k' /\ Some k' ≤ Some k) /\ + (exists x, LevelExprSet.In x s /\ Some k = levelexpr_value m x). + Proof. + apply (max_premise_value_spec_aux m s). + Qed. +End MoreNonEmpty. + +Lemma min_premise_pos_spec {m prem k} : + min_premise m prem = Some k -> + forall x, LevelExprSet.In x prem -> Some (levelexpr_k x + k)%Z ≤Z levelexpr_value m x. +Proof. + pose proof (min_premise_spec m prem) as [amin [exmin [inminpre eqminpre]]]. + intros hprem x hin. + specialize (amin _ hin). + unfold min_atom_value in amin. + destruct x as [l k']; cbn in *. unfold levelexpr_value; cbn. + destruct (level_value m l) eqn:he. + - depelim amin. + rewrite H0 in hprem. depelim hprem. constructor. lia. + constructor. + rewrite H in hprem; depelim hprem. + - depelim amin. rewrite H in hprem. depelim hprem. +Qed. + +Lemma v_minus_w_bound_spec W m : + forall x, ~ LevelSet.In x W -> level_value m x ≤ Some (v_minus_w_bound W m). +Proof. + intros x him. + unfold v_minus_w_bound. + set (fm := LevelMapFact.filter _ _). + replace (level_value m x) with (level_value fm x). + 2:{ unfold level_value. + destruct LevelMap.find eqn:hl => //. + eapply LevelMap.find_2 in hl. + subst fm. cbn in hl. + eapply LevelMapFact.filter_iff in hl as []. 2:tc. + rewrite (LevelMap.find_1 H) //. + destruct (LevelMap.find _ m) eqn:hl' => //. + eapply LevelMap.find_2 in hl'. + assert (LevelMap.MapsTo x z fm). + eapply LevelMapFact.filter_iff. tc. + split => //. now rewrite [_ = true]not_mem. + now rewrite (LevelMap.find_1 H) in hl. } + clearbody fm. + eapply LevelMapFact.fold_rec. + - intros m' em. unfold level_value. + destruct LevelMap.find eqn:hl => //. + eapply LevelMap.find_2 in hl. + now apply em in hl. constructor. + - intros k e a m' m'' map nin hadd. + red in hadd. + unfold level_value. cbn. + rewrite hadd LevelMapFact.F.add_o. + destruct LevelMap.OT.eq_dec. do 2 red in e0. subst x. + intros hf. constructor. lia. + destruct LevelMap.find => hf; depelim hf; constructor; lia. +Qed. + +Lemma clauses_levels_restrict_clauses cls W : + clauses_levels (cls ⇂ W) ⊂_lset W. +Proof. + intros x [cl []] % clauses_levels_spec. + eapply in_restrict_clauses in H as [hconc hprem incl]. + eapply clause_levels_spec in H0 as []. apply hprem, H. now subst x. +Qed. + +Lemma clauses_conclusions_levels cls : + clauses_conclusions cls ⊂_lset clauses_levels cls. +Proof. + intros x. + rewrite clauses_conclusions_spec clauses_levels_spec. + setoid_rewrite clause_levels_spec. + firstorder auto. +Qed. + +Record model_extension W m m' := + { model_ext_le : m ⩽ m'; + model_ext_same_domain : model_same_domain m m'; + model_ext_same_outside : model_map_outside W m m' }. + +#[local] Instance model_ext_reflexive W : Reflexive (model_extension W). +Proof. + intros m; split; reflexivity. +Qed. + +#[local] Instance model_ext_transitive W : Transitive (model_extension W). +Proof. + intros m m' m'' h h'; split; (etransitivity; [apply h|apply h']). +Qed. + +Lemma model_extension_weaken W W' m m' : + W ⊂_lset W' -> + model_extension W m m' -> + model_extension W' m m'. +Proof. + intros leW []; split => //. + eapply model_map_outside_weaken; tea. +Qed. + +Lemma model_ext_trans_weaken W W' m m' m'' : + W ⊂_lset W' -> + model_extension W m m' -> + model_extension W' m' m'' -> + model_extension W' m m''. +Proof. + intros leW mext mext'. eapply model_extension_weaken in mext; tea. + now etransitivity; tea. +Qed. + +Definition model_of V (m : model) := + forall k, LevelSet.In k V -> LevelMap.In k m. + +Definition only_model_of V (m : model) := + forall k, LevelSet.In k V <-> exists x, LevelMap.MapsTo k x m. + +Definition check_model_invariants cls w m w' m' (modified : bool) := + if modified then + [/\ w ⊂_lset w', + w' ⊂_lset (LevelSet.union w (clauses_conclusions cls)), + exists cl, + let cll := (levelexpr_level (concl cl)) in + [/\ Clauses.In cl cls, ~~ valid_clause m cl, + LevelSet.In cll w' & + opt_le Z.lt (level_value m cll) (level_value m' cll)], + model_extension w' m m' & + model_of w' m'] + else (w, m) = (w', m') /\ model_of w m. + +Lemma nEmpty_exists ls : ~ (LevelSet.Empty ls) -> exists l, LevelSet.In l ls. +Proof. + intros ne. + destruct (LevelSet.choose ls) eqn:isempty. exists e. + now apply LevelSet.choose_spec1 in isempty. + now apply LevelSet.choose_spec2 in isempty. +Qed. + +Lemma inLevelSet (ls : LevelSet.t) l : LevelSet.In l ls \/ ~ (LevelSet.In l ls). +Proof. + lsets. +Qed. + +Lemma level_value_above_MapsTo m l k : level_value_above m l k -> exists k', LevelMap.MapsTo l k' m /\ (k <= k'). +Proof. + unfold level_value_above. + destruct level_value eqn:hl => //. + move/Z.leb_le => hle; exists z. + eapply level_value_MapsTo' in hl. split => //. +Qed. + +Lemma level_value_above_MapsTo' m l k k' : LevelMap.MapsTo l k' m -> (k <= k') -> level_value_above m l k. +Proof. + unfold level_value_above. + intros H; apply LevelMap.find_1 in H. rewrite /level_value H. + now apply Z.leb_le. +Qed. + +Lemma level_value_add m l k : level_value (LevelMap.add l k m) l = Some k. +Proof. + rewrite /level_value LevelMapFact.F.add_eq_o //. +Qed. + +#[local] Instance clauses_conclusions_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_conclusions. +Proof. + intros cls cls' eq x. + rewrite !clauses_conclusions_spec. now setoid_rewrite eq. +Qed. + +#[local] Instance And3P_proper : Proper (iff ==> iff ==> iff ==> iff) ssrbool.and3. +Proof. + repeat intro. split; intros []; split; intuition auto. +Qed. + +#[local] Instance And4P_proper : Proper (iff ==> iff ==> iff ==> iff ==> iff) ssrbool.and4. +Proof. + repeat intro. split; intros []; split; intuition auto. +Qed. + +#[local] Instance And5P_proper : Proper (iff ==> iff ==> iff ==> iff ==> iff ==> iff) ssrbool.and5. +Proof. + repeat intro. split; intros []; split; intuition auto. +Qed. + +#[local] Instance check_model_invariants_proper : + Proper (Clauses.Equal ==> eq ==> eq ==> eq ==> eq ==> eq ==> iff) check_model_invariants. +Proof. + intros cls cls' eqcls. + repeat intro; subst. + unfold check_model_invariants. + destruct y3 => //. + now setoid_rewrite <-eqcls. +Qed. + +Lemma min_atom_value_levelexpr_value m l a lv : min_atom_value m l = Some a -> levelexpr_value m l = Some lv -> + (a <= lv - l). +Proof. + destruct l as [l k]; cbn. unfold levelexpr_value. cbn. destruct level_value => //. + intros [= <-] [= <-]. lia. +Qed. + +Lemma clauses_conclusions_add cl cls : + clauses_conclusions (Clauses.add cl cls) =_lset + (LevelSet.singleton (level (concl cl)) ∪ + clauses_conclusions cls). +Proof. + intros x. + rewrite LevelSet.union_spec !clauses_conclusions_spec. + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.singleton_spec. + firstorder eauto. subst. now left. +Qed. + +Definition declared_model_level (m : model) l := LevelMap.In l m. + +Definition update_model_same_domain {m l k} : + declared_model_level m l -> + model_same_domain m (update_model m l k). +Proof. + unfold update_model, declared_model_level. + intros hin x. + rewrite LevelMapFact.F.add_in_iff. intuition auto. now subst. +Qed. + +Definition update_model_outside {m w l k} : + model_map_outside (LevelSet.add l w) m (update_model m l k). +Proof. + unfold update_model, model_map_outside. + intros l'. rewrite LevelSet.add_spec. + intros hin k'. + rewrite LevelMapFact.F.add_neq_mapsto_iff //. + intros heq. red in heq; subst l'. apply hin. now left. +Qed. + +Lemma opt_lt_le_trans x y z : + opt_le Z.lt x y -> + opt_le Z.le y z -> + opt_le Z.lt x z. +Proof. + intros [] H'; depelim H'; constructor. lia. +Qed. + +Lemma model_of_update w m l k : model_of w m -> model_of (LevelSet.add l w) (update_model m l k). +Proof. + rewrite /model_of => hint l'. rewrite LevelSet.add_spec. + intros [->|hadd]. + - exists k. now apply LevelMap.add_1. + - specialize (hint _ hadd). unfold update_model. + destruct hint as [x hx]. + destruct (eqb_spec l l'). subst. + now exists k; apply LevelMap.add_1. + now exists x; eapply LevelMap.add_2. +Qed. + +Definition levelset_m_eq : list Level.t × model -> list Level.t × model -> Prop := + fun x y => x.1 = y.1 /\ LevelMap.Equal x.2 y.2. + +#[local] Instance lmeq_eq : Equivalence levelset_m_eq. +Proof. + split. intros x. split => //. + intros x y []; split => //. + intros x y z [] []; split => //. + all:etransitivity; tea. +Qed. + +(* Definition optm := optm *) + +(* #[local] Instance update_value_proper : Proper (LevelMap.Equal ==> eq ==> opt ) update_value. *) + +#[local] Instance check_clause_model_proper : Proper (eq ==> levelset_m_eq ==> levelset_m_eq) check_clause_model. +Proof. + intros x y eq [] [] []; cbn in *; subst. + unfold levelset_m_eq. + replace (update_value m y) with (update_value m0 y). split => //; destruct update_value => //. + unfold update_value. setoid_rewrite H0. +Abort. + +Instance model_map_outside_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) model_map_outside. +Proof. + intros ? ? eqcl ? ? eqm ? ? eqs. + unfold model_map_outside. + setoid_rewrite eqcl. now setoid_rewrite eqm; setoid_rewrite eqs. +Qed. + +#[local] Instance proper_levelexprset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) + levels. +Proof. + intros s s' eq l. + rewrite !levelexprset_levels_spec. + firstorder eauto. +Qed. + +Lemma min_premise_spec' {m prems z} : min_premise m prems = Some z -> + (forall l k, LevelExprSet.In (l, k) prems -> + exists v, level_value m l = Some v /\ z <= (v - k))%Z. +Proof. + intros hmin. + have [hall hhmin'] := min_premise_spec m prems. + intros l k hin; specialize (hall _ hin). rewrite hmin in hall. + depelim hall. destruct level_value => //. noconf H0. exists z0. split => //. +Qed. + +Lemma nonEmptyLevelExprSet_elim {P : nonEmptyLevelExprSet -> Prop} : + (forall le, P (singleton le)) -> + (forall le prems, P prems -> ~ LevelExprSet.In le prems -> P (add le prems)) -> + forall prems, P prems. +Proof. + intros hs ha. + intros []. + revert t_set0 t_ne0. + apply: LevelExprSetProp.set_induction; eauto. + - move=> s /LevelExprSetFact.is_empty_1 he ne; exfalso => //. congruence. + - intros s s' IH x nin hadd hne. + destruct (LevelExprSet.is_empty s) eqn:hem in |- . + eapply LevelExprSetFact.is_empty_2 in hem. + assert (singleton x = {| t_set := s'; t_ne := hne |}) as <- => //. + unfold singleton. apply eq_univ_equal. cbn. + intros a. specialize (hadd a). rewrite hadd. + rewrite LevelExprSet.singleton_spec. firstorder. subst. reflexivity. + specialize (IH hem). + specialize (ha x _ IH). + assert (LevelExprSet.Equal (add x {| t_set := s; t_ne := hem|}) {| t_set := s'; t_ne := hne |}). + 2:{ apply eq_univ_equal in H. now rewrite -H. } + intros x'. specialize (hadd x'). rewrite LevelExprSet.add_spec. + cbn. firstorder. subst x'. now left. +Qed. + +Lemma min_premise_pres {m m'} prems : m ⩽ m' -> min_premise m prems ≤Z min_premise m' prems. +Proof. + intros ext. + destruct (min_premise m prems) eqn:hmin. + have leq := min_premise_spec' hmin. 2:constructor. + have [leq' e'] := min_premise_spec m' prems. + destruct (min_premise_spec m prems) as [_ [minz [inminz eqminz]]]. + rewrite hmin in eqminz. + rewrite eqminz. destruct e' as [min' []]. rewrite H0. + transitivity (min_atom_value m min'). + 2:{ unfold min_atom_value. destruct min'. + unfold level_value. destruct (LevelMap.find t m) eqn:hfind. 2:constructor. + apply LevelMap.find_2 in hfind. apply ext in hfind as [k' [hfind hle]]. + apply LevelMap.find_1 in hfind. rewrite hfind. constructor. lia. + } + destruct min'. specialize (leq _ _ H) as [? []]. + unfold min_atom_value at 2. rewrite H1. rewrite -eqminz. constructor. lia. +Qed. + +Lemma level_value_above_mon m m' l k : m ⩽ m' -> level_value_above m l k -> level_value_above m' l k. +Proof. + intros ext; move/level_value_above_MapsTo => [v [hm hleq]]. + eapply ext in hm. destruct hm as [v' [hm' leq']]. + eapply level_value_above_MapsTo'; tea. lia. +Qed. + +Lemma model_of_subset V V' m : + model_of V m -> V' ⊂_lset V -> model_of V' m. +Proof. + intros ih hv k. specialize (ih k). + now move/hv. +Qed. + +Instance only_model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) only_model_of. +Proof. + intros ? ? eq ? ? eq'. + rewrite /only_model_of. now setoid_rewrite eq; setoid_rewrite eq'. +Qed. + +Lemma only_model_of_eq V V' m : + only_model_of V m -> V' =_lset V -> only_model_of V' m. +Proof. + intros ih hv k. now rewrite hv. +Qed. + +Lemma clauses_conclusions_subset {cls cls'} : + Clauses.Subset cls cls' -> + clauses_conclusions cls ⊂_lset clauses_conclusions cls'. +Proof. + intros hsub x. rewrite !clauses_conclusions_spec. + intuition eauto. destruct H as [cl []]; exists cl; split; try clsets; auto. +Qed. + +Lemma check_model_ext {cls w init_model m w' m'} : + check_model cls (w, m) = Some (w', m') -> + strictly_updates cls w init_model m -> + strictly_updates cls w' init_model m' /\ w ⊂_lset w'. +Proof. + move/check_model_updates_spec. + intros ih cls'. eapply ih in cls' as [su incl]. split => //. + eapply strictly_updates_weaken; tea. clsets. +Qed. + +Lemma check_model_updates_spec_empty {cls m w m'} : + check_model cls (LevelSet.empty, m) = Some (w, m') -> + strictly_updates cls w m m'. +Proof. + move/check_model_spec => [w' [su ->]]. + replace (LevelSet.union LevelSet.empty w') with w' => //. + eapply LevelSet.eq_leibniz. intros x; lsets. +Qed. + +Lemma check_model_is_model {W cls m} : + check_model cls (W, m) = None <-> is_model cls m. +Proof. + now rewrite check_model_None. +Qed. + +Lemma check_model_update {W cls m wm'} : + model_of (clauses_conclusions cls) m -> + model_of W m -> + check_model cls (W, m) = Some wm' -> ~~ is_model cls m /\ m ⩽ wm'.2. +Proof. + intros mof tot. + destruct wm'. + move/check_model_spec => [w'' [su ->]]. cbn. split. + now eapply strictly_updates_invalid. + now eapply strictly_updates_ext. +Qed. + +Definition level_value_default m l := + match level_value m l with Some x => x | None => 0 end%Z. + +Definition measure_w W cls m w := + let bound := v_minus_w_bound W m in + let maxgain := max_gain (cls_diff cls W) in + (bound + Z.of_nat maxgain - (level_value_default m w))%Z. + +Lemma min_premise_max_premise m prem k : + min_premise m prem = Some k -> + exists k', max_premise_value m prem = Some k'. +Proof. + unfold min_premise, max_premise_value. + destruct to_nonempty_list. + assert (forall l k, fold_left + (fun (min : option Z) (atom : LevelExpr.t) => + option_map2 Z.min (let '(l0, k0) := atom in match level_value m l0 with + | Some val => Some (val - k0)%Z + | None => None + end) min) + l None = + Some k -> False). + { clear. induction l; cbn => //. cbn in *. + destruct a, level_value; cbn; auto. } + assert + (forall x y, fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (Some x) = Some k -> +exists k', + fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.max (levelexpr_value m atom) min) l (Some y) = Some k'). + { induction l; cbn. + - intros x y [= <-]. now eexists. + - intros x y. + unfold min_atom_value, levelexpr_value, levelexpr_level. destruct a; cbn. + destruct level_value => //=. eapply IHl. cbn. intros H'. exfalso. + eapply H; eauto. } + - unfold min_atom_value, levelexpr_value, levelexpr_level. destruct t; cbn. + destruct level_value => //=. apply H0. + intros; exfalso. now eapply H. +Qed. + +Lemma model_of_value_None W m l : + model_of W m -> + LevelSet.In l W -> + level_value m l = None -> False. +Proof. + intros tm inw. specialize (tm l inw) as [v hm]. + rewrite /level_value. + now rewrite (LevelMap.find_1 hm). +Qed. + +Lemma invalid_clause_measure W cls cl m : + model_of W m -> + ~~ valid_clause m cl -> + Clauses.In cl (cls_diff cls W) -> + (0 < measure_w W cls m (concl cl))%Z. +Proof. + intros hwv. unfold valid_clause. + (* case: Z.ltb_spec => // hprem. *) + destruct cl as [prem [l k]]; cbn. + destruct min_premise eqn:hmin => //. + move/negbTE/level_value_not_above_spec => hlt hin. + have hne := (non_W_atoms_ne _ _ _ hin). + cbn. unfold measure_w. unfold gain. + set (clsdiff := Clauses.diff _ _). + set (bound := v_minus_w_bound W m). + enough ((level_value_default m l) < bound + Z.of_nat (max_gain clsdiff))%Z. lia. + set (prem' := non_W_atoms W prem). + set (preml := {| t_set := prem'; t_ne := hne |}). + assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff)%nat. + { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. + unfold gain. cbn. + pose proof (premise_min_subset preml prem). + forward H. eapply non_W_atoms_subset. lia. } + eapply Z.lt_le_trans with (bound + Z.of_nat (Z.to_nat (gain (preml, (l, k)))))%Z; try lia. + unfold gain; cbn. + enough ((level_value_default m l) < (v_minus_w_bound W m) + (k - premise_min preml))%Z. lia. + unfold level_value_default. destruct (level_value m l) as [vl|] eqn:hl; revgoals. + { eapply model_of_value_None in hl; tea => //. + eapply Clauses.diff_spec in hin as [hin _]. + now apply in_clauses_with_concl in hin as [hin _]. } + depelim hlt. + enough (k + z <= (v_minus_w_bound W m) + k - premise_min preml)%Z. lia. + assert (min_premise m prem ≤Z min_premise m preml)%Z. + { eapply min_premise_subset. eapply non_W_atoms_subset. } + rewrite hmin in H1. depelim H1. + transitivity (k + y)%Z. lia. + pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. + have [maxpreml eqmax] := min_premise_max_premise m preml _ H2. + pose proof (max_premise_value_spec m preml _ eqmax) as [amax [exmax [inmaxpre eqmaxpre]]]. + pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. + assert (premise_min prem <= premise_min preml). + { eapply premise_min_subset. eapply non_W_atoms_subset. } + (* transitivity (v_minus_w_bound W m + (k - premise_min preml)). 2:lia. *) + assert (y <= maxpreml - (premise_min preml))%Z. + { rewrite eqpminpre. rewrite H2 in eqminpre; symmetry in eqminpre. + (* eqmaxpre eqminpre. *) + pose proof (min_atom_value_levelexpr_value m exmin). + specialize (amax _ inminpre) as amax'. rewrite eqmaxpre in amax'. + destruct amax' as [vexmin [eqexmin ltexmin]]. + assert (expmin <= exmin). specialize (apmin _ inminpre). lia. + specialize (H4 _ _ eqminpre eqexmin). depelim ltexmin. etransitivity; tea. + rewrite -eqmaxpre in H6. noconf H6. + unfold level_expr_elt in *. lia. } + transitivity (k + (maxpreml - (premise_min preml)))%Z. lia. + (* assert (Z.of_nat (premise_min preml) <= maxpreml)%Z. + { rewrite eqmaxpre. + move/min_premise_pos_spec: hprem => hprem. + transitivity exmax. apply apmin => //. eapply hprem. + now apply (non_W_atoms_subset W prem). } *) + assert (k + (maxpreml - (premise_min preml)) = + (maxpreml + k - (premise_min preml)))%Z as ->. lia. + enough (maxpreml <= (v_minus_w_bound W m))%Z. lia. + { have vm := v_minus_w_bound_spec W m exmax. unfold levelexpr_value in eqmaxpre. + rewrite -eqmaxpre in vm. + have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). + rewrite levelexprset_levels_spec in hlevels. + forward hlevels. + exists exmax.2. now destruct exmax. + rewrite LevelSet.diff_spec in hlevels. + destruct hlevels as [_ nw]. specialize (vm nw). depelim vm. lia. } +Qed. + +Module ClausesOrd := OrdProperties Clauses. + + +#[local] Instance check_model_aux_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model_aux. +Proof. + intros cls cls' eq. + intros wm wm' eq'. subst wm'. + unfold check_model_aux. + now eapply ClausesOrd.fold_equal; tc. +Qed. + +(* #[local] Instance check_model_aux_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> modified_levelset_m_eq) check_model_aux. +Proof. + intros cls cls' eq. + intros wm wm' eq'. + transitivity (check_model_aux cls' wm). + 2:{ unfold check_model_aux. + eapply (ClausesProp.fold_init (eqA := modified_levelset_m_eq)); tc. + red. cbn => //. } + unfold check_model_aux. + now eapply ClausesOrd.fold_equal; tc. +Qed. *) + +(* +#[local] Instance check_model_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model. +Proof. + intros cls cls' eq. + intros wm wm' eq'. + unfold check_model. + now subst wm'; rewrite eq. +Qed. *) + +Definition is_update_of cls upd minit m := + if LevelSet.is_empty upd then minit =m m + else strictly_updates cls upd minit m. + +Record valid_model_def (V W : LevelSet.t) (m : model) (cls : clauses) := + { model_model : model; + model_of_V :> model_of V model_model; + model_updates : is_update_of cls W m model_model; + model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; + model_ok :> is_model cls model_model; + }. +Arguments model_model {V W m cls}. +Arguments model_of_V {V W m cls}. +Arguments model_updates {V W m cls}. +Arguments model_clauses_conclusions {V W m cls}. +Arguments model_ok {V W m cls}. +Extraction Inline model_model. + +Definition valid_model := valid_model_def. + +Definition add_expr n '((l, k) : LevelExpr.t) := (l, k + n). + +Lemma add_expr_add_expr n n' lk : add_expr n (add_expr n' lk) = add_expr (n + n') lk. +Proof. destruct lk; unfold add_expr. f_equal; lia. Qed. +Definition add_prems n s := map (add_expr n) s. + +Lemma In_add_prems k (prems : nonEmptyLevelExprSet): + forall le, LevelExprSet.In le (add_prems k prems) <-> + exists le', LevelExprSet.In le' prems /\ le = add_expr k le'. +Proof. + intros [l k']. + now rewrite /add_prems map_spec. +Qed. + + +Lemma map_map f g x : map f (map g x) = map (f ∘ g) x. +Proof. + apply eq_univ_equal. + intros lk. + rewrite !map_spec. setoid_rewrite map_spec. + firstorder eauto. subst. firstorder. +Qed. + +Lemma add_expr_inj {n e e'} : add_expr n e = add_expr n e' -> e = e'. +Proof. + destruct e, e'; cbn; intros [=]. + have eq: z = z0 by lia. + now subst z0. +Qed. + +Lemma add_prems_inj n prems prems' : add_prems n prems = add_prems n prems' -> prems = prems'. +Proof. + rewrite /add_prems => /eq_univ_equal hm. + apply eq_univ_equal. + intros [l k]. specialize (hm (l, k + n)). + rewrite !map_spec in hm. destruct hm as [hl hr]. + split; intros hin. + - forward hl. exists (l, k); split => //. + destruct hl as [[] [hin' eq]]. + apply (@add_expr_inj n (l, k)) in eq. now noconf eq. + - forward hr. exists (l, k); split => //. + destruct hr as [[] [hin' eq]]. + apply (@add_expr_inj n (l, k)) in eq. now noconf eq. +Qed. + +Lemma add_prems_add_prems n n' lk : add_prems n (add_prems n' lk) = add_prems (n + n') lk. +Proof. destruct lk; unfold add_prems. + rewrite map_map. apply eq_univ_equal. + intros x. rewrite !map_spec. cbn in *. + firstorder eauto. subst. exists x0. + firstorder eauto. now rewrite add_expr_add_expr. + subst. exists x0. + firstorder eauto. now rewrite add_expr_add_expr. +Qed. + +Definition add_clause n '((prems, concl) : clause) := (add_prems n prems, add_expr n concl). + +Lemma add_clause_add_clause n n' cl : add_clause n (add_clause n' cl) = add_clause (n + n') cl. +Proof. + destruct cl. + unfold add_clause. + now rewrite add_prems_add_prems add_expr_add_expr. +Qed. + +Notation succ_expr := (add_expr 1). +Notation succ_prems := (add_prems 1). +Notation succ_clause := (add_clause 1). + +Arguments add_prems : simpl never. + +Lemma pair_inj {A B} (x x' : A) (y y' : B) P : + (x = x' -> y = y' -> P) -> + ((x, y) = (x', y') -> P). +Proof. + now intros h [=]. +Qed. + +Lemma add_clause_inj {n x y} : add_clause n x = add_clause n y -> x = y. +Proof. + destruct x as [prems concl], y as [prems' concl']. cbn. + apply: pair_inj. now move=> /add_prems_inj -> /add_expr_inj ->. +Qed. +Definition add_clauses n cls := ClausesProp.of_list (List.map (fun cl => add_clause n cl) (ClausesProp.to_list cls)). +Notation succ_clauses := (add_clauses 1). +Import SetoidList. + +Lemma add_clauses_spec {cl cls} n : Clauses.In cl cls <-> Clauses.In (add_clause n cl) (add_clauses n cls). +Proof. + unfold succ_clauses. + rewrite ClausesProp.of_list_1 InA_In_eq in_map_iff. + firstorder eauto. + - exists cl; split => //. unfold ClausesProp.to_list. now eapply Clauses_In_elements. + - eapply Clauses_In_elements in H0. apply add_clause_inj in H. now subst. +Qed. + +Lemma in_add_clauses {cl cls} n : Clauses.In cl (add_clauses n cls) -> exists cl', Clauses.In cl' cls /\ cl = add_clause n cl'. +Proof. + unfold succ_clauses. + rewrite ClausesProp.of_list_1 InA_In_eq in_map_iff. + firstorder eauto. + exists x; split => //. unfold ClausesProp.to_list. now eapply Clauses_In_elements. +Qed. + +Variant in_pred_closure cls : clause -> Prop := +| incls cl n : Clauses.In cl cls -> in_pred_closure cls (add_clause n cl) +| predcl x k : in_pred_closure cls (singleton (x, k + 1), (x, k)). +Derive Signature for in_pred_closure. + +Inductive entails (cls : clauses) : clause -> Prop := +| clause_in (prems : nonEmptyLevelExprSet) (concl : LevelExpr.t) : LevelExprSet.In concl prems -> entails cls (prems, concl) +| clause_cut prems' concl' prems concl : + in_pred_closure cls (prems', concl') -> + entails cls (add concl' prems, concl) -> + LevelExprSet.Subset prems' prems -> + entails cls (prems, concl). + +Definition entails_all cls (prems concls : nonEmptyLevelExprSet) := + LevelExprSet.For_all (fun le => entails cls (prems, le)) concls. + +Notation " cls ⊢ prems → concl " := (entails cls (prems, concl)) (at level 20). +Notation " cls ⊢a prems → concl " := (entails_all cls prems concl) (at level 20). + +Lemma in_pred_closure_equal cls (prems prems' : nonEmptyLevelExprSet) concl : + LevelExprSet.Equal prems prems' -> + in_pred_closure cls (prems, concl) -> in_pred_closure cls (prems', concl). +Proof. + intros eq. apply NonEmptySetFacts.eq_univ_equal in eq. now subst prems. +Qed. + +Lemma entails_equal cls (prems prems' : nonEmptyLevelExprSet) concl : + LevelExprSet.Equal prems prems' -> + entails cls (prems, concl) -> entails cls (prems', concl). +Proof. + intros he en. + replace prems' with prems => //. + now apply eq_univ_equal. +Qed. + +Lemma entails_plus cls c : entails cls c -> entails (succ_clauses cls) (succ_clause c). +Proof. + induction 1. + - constructor. apply map_spec. exists concl0. split => //. + - eapply clause_cut with (succ_prems prems') (succ_expr concl'). + + depelim H. + * have -> : (succ_prems prems', succ_expr concl') = add_clause n (succ_clause cl). + { destruct cl as [prems'' concl'']. cbn in H0. noconf H0. + rewrite add_prems_add_prems add_expr_add_expr add_clause_add_clause. + now rewrite Z.add_1_r Z.add_1_l. } + constructor. now rewrite -add_clauses_spec. + * have eq : (succ_prems (singleton (x, (k + 1)))) = (singleton (x, k + 1 + 1)). + { apply eq_univ_equal. unfold succ_prems. + intros le. rewrite map_spec LevelExprSet.singleton_spec. + split. + { intros [? [hin ->]]. + rewrite LevelExprSet.singleton_spec in hin. red in hin; subst x0. + reflexivity. } + { unfold LevelExprSet.E.eq. intros ->. + exists (x, k + 1). split. + now rewrite LevelExprSet.singleton_spec. reflexivity. } } + rewrite eq. constructor 2. + + unfold succ_clause in IHentails. + eapply entails_equal; tea. + intros x. rewrite /succ_prems. rewrite map_spec add_spec. + setoid_rewrite add_spec. rewrite map_spec. + firstorder eauto. subst. now left. + + intros x. rewrite /succ_prems !map_spec. + intros [e [hin ->]]. exists e. firstorder. +Qed. + + +Derive Signature for entails. + +Lemma entails_pred_closure {cls prems concl k} : + cls ⊢ prems → (concl, 1 + k) -> cls ⊢ prems → (concl, k). +Proof. + intros he. + Opaque Z.add. + depind he. + - eapply clause_cut. + constructor. + 2:{ intros l hin. rewrite LevelExprSet.singleton_spec in hin. red in hin; subst l. + rewrite Z.add_comm; exact H. } + constructor. + rewrite LevelExprSet.add_spec. lesets. + - eapply clause_cut; tea. +Qed. + +Lemma entails_pred_closure_n {cls prems concl k n} : + entails cls (prems, (concl, k + Z.of_nat n)) -> entails cls (prems, (concl, k)). +Proof. + induction n in k |- *. + - rewrite Z.add_0_r. tauto. + - intros hen. rewrite Nat2Z.inj_succ in hen. rewrite Z.add_succ_r in hen. + eapply IHn. move: hen. + have -> : Z.succ (k + Z.of_nat n) = 1 + (k + Z.of_nat n) by lia. + eapply entails_pred_closure. +Qed. + +Lemma add_clause_0 cl : add_clause 0 cl = cl. +Proof. + destruct cl as [prems [concl k]]; cbn. + f_equal. 2:now rewrite Z.add_0_r. + unfold add_prems. + eapply eq_univ_equal. intros [l k']. + rewrite NonEmptySetFacts.map_spec. + unfold add_expr. split. + - intros [[] [hin heq]]. noconf heq. now rewrite Z.add_0_r. + - exists (l, k'); split => //. now rewrite Z.add_0_r. +Qed. + +Lemma incls0 {cls cl} : Clauses.In cl cls -> in_pred_closure cls cl. +Proof. + intros hin. + have hcl := incls _ _ 0 hin. + now rewrite add_clause_0 in hcl. +Qed. + +Lemma entails_in {cls cl} : Clauses.In cl cls -> entails cls cl. +Proof. + intros hin. + destruct cl as [prems concl]. + eapply clause_cut. + - now eapply incls0. + - constructor. eapply LevelExprSet.add_spec. now left. + - reflexivity. +Qed. + + + +Lemma in_pred_closure_shift {cls cl} n : in_pred_closure cls cl -> in_pred_closure cls (add_clause n cl). +Proof. + destruct 1. + - rewrite add_clause_add_clause. now constructor. + - cbn. eapply in_pred_closure_equal with (singleton (x, k + 1 + n)). + { intros le. rewrite In_add_prems; rewrite_strat (topdown LevelExprSet.singleton_spec). + intuition auto. exists (x, k + 1). split => //. + now destruct H as [le' [-> ->]]. } + have -> : k + 1 + n = (k + n) + 1 by lia. + constructor. +Qed. + +Lemma add_clause_singleton n le concl k : add_clause n (singleton le, (concl, k)) = (singleton (add_expr n le), (concl, k + n)). +Proof. + rewrite /add_clause //=. f_equal. + apply eq_univ_equal. intros le'. rewrite In_add_prems. + rewrite_strat (topdown LevelExprSet.singleton_spec). + unfold LevelExprSet.E.eq. firstorder. subst. reflexivity. +Qed. + +Lemma entails_shift {cls cl} n : entails cls cl -> entails cls (add_clause n cl). +Proof. + induction 1. + - unfold add_clause. constructor. + rewrite In_add_prems. exists concl0. split => //. + - eapply (clause_cut _ (add_prems n prems') (add_expr n concl')). + 2:{ unfold add_clause in *. eapply entails_equal; tea. + intros le. setoid_rewrite In_add_prems. setoid_rewrite LevelExprSet.add_spec. + setoid_rewrite In_add_prems. + unfold LevelExprSet.E.eq. firstorder. subst. now left. } + 2:{ intros x. rewrite !In_add_prems. firstorder. } + eapply (in_pred_closure_shift _ H). +Qed. + +Lemma entails_subset cls (prems prems' : nonEmptyLevelExprSet) concl : LevelExprSet.Subset prems prems' -> + entails cls (prems, concl) -> + entails cls (prems', concl). +Proof. + intros hsubt. + intros H; revert prems' hsubt; depind H. + - constructor. eapply hsubt, H. + - intros prems'' hsub. + eapply clause_cut. 2:eapply IHentails. tea. + 2:lesets. intros x; rewrite !LevelExprSet.add_spec. firstorder. +Qed. + +Lemma entails_trans {cls prems concl concl'} : + entails cls (prems, concl) -> + entails cls (singleton concl, concl') -> + entails cls (prems, concl'). +Proof. + intros H; depind H. + - intros he. + depelim he. + * rewrite LevelExprSet.singleton_spec in H0. red in H0; subst concl0. + now constructor. + * eapply (clause_cut _ prems'). tea. + eapply entails_subset; tea. + intros ?; rewrite !LevelExprSet.add_spec LevelExprSet.singleton_spec; firstorder. + red in H2; subst a. now right. intros x. firstorder. apply H1 in H2. + rewrite LevelExprSet.singleton_spec in H2. now red in H2; subst x. + - intros he. + specialize (IHentails concl'0 he). + eapply clause_cut; tea. +Qed. + +Lemma entails_weak {cls prem concl concl'} : + entails cls (prem, concl) -> + entails cls (add concl' prem, concl). +Proof. + intros H. depind H. + - constructor. apply LevelExprSet.add_spec. now right. + - eapply (clause_cut _ _ concl'); tea. + rewrite add_comm. apply IHentails. + intros x; rewrite LevelExprSet.add_spec. firstorder. +Qed. + +Lemma entails_weak_union {cls prem concl concl'} : + entails cls (prem, concl) -> + entails cls (univ_union concl' prem, concl). +Proof. + intros hyp. + move: concl'. + apply: nonEmptyLevelExprSet_elim. + - intros le. rewrite univ_union_comm univ_union_add_singleton. + now apply entails_weak. + - intros le prems ih. + rewrite univ_union_add_distr. intros _. + now eapply entails_weak. +Qed. + +Lemma entails_all_weak {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (add concl' prem) concl. +Proof. + intros hcl x hin. + specialize (hcl _ hin). cbn in hcl. + now apply entails_weak. +Qed. + +Lemma entails_all_weak_union {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (univ_union concl' prem) concl. +Proof. + intros hcl x hin. + specialize (hcl _ hin). cbn in hcl. + now apply entails_weak_union. +Qed. + +Lemma entails_all_weak' {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (add concl' prem) (add concl' concl). +Proof. + intros hcl x hin. + eapply LevelExprSet.add_spec in hin as []. red in H; subst. + - constructor. eapply LevelExprSet.add_spec. now left. + - specialize (hcl _ H). cbn in hcl. + now apply entails_weak. +Qed. + +Lemma entails_cut_all {cls prems' concl' prems concls} : + in_pred_closure cls (prems', concl') -> + cls ⊢a add concl' prems → concls -> + prems' ⊂_leset prems -> + cls ⊢a prems → concls. +Proof. + intros inp he hp x hin. + eapply clause_cut; tea. + now apply he in hin. +Qed. + +Lemma entails_all_subset {cls} {prems prems' prems'' : nonEmptyLevelExprSet} : + prems'' ⊂_leset prems' -> + cls ⊢a prems → prems' -> + cls ⊢a prems → prems''. +Proof. + intros incl ha x hin. + eapply incl in hin. now apply ha in hin. +Qed. + +(* Lemma entails_all_one {cls prems concl concl'} : + entails_all cls prems concl -> + entails cls (univ_union concl prems, concl') -> + entails cls (prems, concl'). +Proof. + intros hall he; depind he. + - eapply LevelExprSet.union_spec in H as []. + 2:now constructor. + now eapply hall in H. + - eapply clause_cut in he; tea. 3:reflexivity. specialize (IHhe _ _ concl0 hall). *) + +Lemma entails_all_add cls prem l prems' : + cls ⊢a prem → add l prems' <-> + cls ⊢ prem → l /\ cls ⊢a prem → prems'. +Proof. + rewrite /entails_all /LevelExprSet.For_all. + setoid_rewrite LevelExprSet.add_spec; rewrite /LevelExprSet.E.eq. + firstorder. now subst. +Qed. + +Lemma entails_add {cls prems cl concl} : + entails cls (prems, cl) -> + entails cls (add cl prems, concl) -> + entails cls (prems, concl). +Proof. + intros H; depind H. + - intros he. + depelim he. + * rewrite LevelExprSet.add_spec in H0. destruct H0 as []. + { red in H0; subst concl0. now constructor. } + { now constructor. } + * have eq : prems = add concl0 prems. + { eapply eq_univ_equal. intros x; rewrite LevelExprSet.add_spec. firstorder. now red in H2; subst. } + rewrite -eq in H1. + eapply (clause_cut _ prems' _ prems). tea. 2:tea. + now rewrite -eq in he. + - intros he. + eapply clause_cut. tea. eapply IHentails. + rewrite add_comm. now eapply entails_weak. + exact H1. +Qed. + +Lemma entails_cumul_one {cls prems prems' concl} : + entails_all cls prems prems' -> + entails cls (univ_union prems prems', concl) -> + entails cls (prems, concl). +Proof. + revert prems' prems concl. + apply: nonEmptyLevelExprSet_elim. + - intros. specialize (H le). forward H by now apply LevelExprSet.singleton_spec. + cbn in H. + eapply entails_add; tea. + now rewrite -univ_union_add_singleton. + - intros le prems ih _ prem concl' hadd hadd'. + rewrite univ_union_comm univ_union_add_distr -univ_union_comm -univ_union_add_distr in hadd'. + eapply ih in hadd'. 2:{ apply entails_all_weak. apply entails_all_add in hadd as []. exact H0. } + apply entails_all_add in hadd as []. + eapply entails_add; tea. +Qed. + +Lemma entails_all_cumul {cls prems prems' concl} : + entails_all cls prems prems' -> + entails_all cls (univ_union prems prems') concl -> + entails_all cls prems concl. +Proof. + intros hp hc. + intros x hin. apply hc in hin. + eapply entails_cumul_one; tea. +Qed. + +Lemma entails_all_one {cls prem concl concl'} : + entails_all cls prem concl -> + entails cls (concl, concl') -> + entails cls (prem, concl'). +Proof. + intros ha he. + eapply entails_cumul_one; tea. + now eapply entails_weak_union. +Qed. + +Lemma entails_all_trans {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls concl concl' -> + entails_all cls prem concl'. +Proof. + intros ha he cl hin. + apply he in hin. + eapply entails_all_one; tea. +Qed. + +Lemma entails_incr_shift cls concl k n : + entails cls (singleton (concl, k), (concl, k + 1)) -> + entails cls (singleton (concl, k), (concl, k + 1 + Z.of_nat n)). +Proof. + induction n in k |- *; auto. + - now rewrite Z.add_0_r. + - intros en. + have hs := entails_shift 1 en. rewrite add_clause_singleton /= in hs. + apply IHn in hs. + eapply entails_trans; tea. + now have -> : k + 1 + Z.of_nat (S n) = k + 1 + 1 + Z.of_nat n by lia. +Qed. + +Lemma entails_incr_all cls concl k : + entails cls (singleton (concl, k), (concl, k + 1)) -> + forall k', entails cls (singleton (concl, k), (concl, k')). +Proof. + intros en k'. + destruct (Z.lt_trichotomy k k') as [|[]]; subst; auto. + - have ispos : 0 <= k' - k - 1 by lia. + eapply (entails_incr_shift _ _ _ (Z.to_nat (k' - k - 1))) in en. + assert (k + 1 + Z.of_nat (Z.to_nat (k' - k - 1)) = k') by lia. now rewrite H0 in en. + - constructor. now rewrite LevelExprSet.singleton_spec. + - have [k0 ->] : (exists kd : nat, k = k' + Z.of_nat kd). { exists (Z.to_nat (k - k')). lia. } + eapply (entails_pred_closure_n (n:=k0)). constructor. now apply LevelExprSet.singleton_spec. +Qed. + +Lemma entails_all_concl_union {cls prems concl concl'} : + cls ⊢a prems → concl -> + cls ⊢a prems → concl' -> + cls ⊢a prems → univ_union concl concl'. +Proof. + intros l r. + rewrite /entails_all. + intros x. rewrite univ_union_spec. intros []. now apply l. now apply r. +Qed. + +Lemma entails_all_union {cls prems concl prems' concl'} : + cls ⊢a prems → concl -> + cls ⊢a prems' → concl' -> + cls ⊢a univ_union prems prems' → univ_union concl concl'. +Proof. + intros l r. + apply entails_all_concl_union. + rewrite univ_union_comm. + now eapply entails_all_weak_union. + now eapply entails_all_weak_union. +Qed. + + +Lemma entails_all_shift {cls : clauses} {prems concl : univ} (n : Z) : + cls ⊢a prems → concl -> + cls ⊢a add_prems n prems → add_prems n concl. +Proof. + intros cla cl. + rewrite In_add_prems => [[le' [hin ->]]]. + eapply (entails_shift (cl := (prems, le'))). + now apply cla in hin. +Qed. + +Lemma in_pred_closure_subset {cls cls' prems concl} : + in_pred_closure cls (prems, concl) -> + cls ⊂_clset cls' -> + in_pred_closure cls' (prems, concl). +Proof. + induction 1. + - move/(_ _ H). now constructor. + - constructor. +Qed. + +Lemma entails_clauses_subset cls cls' prems concl : + cls ⊢ prems → concl -> + cls ⊂_clset cls' -> + cls' ⊢ prems → concl. +Proof. + induction 1 in cls' |- * => incl. + - now constructor. + - eapply clause_cut. + + eapply in_pred_closure_subset; tea. + + now apply IHentails. + + assumption. +Qed. + +Lemma entails_all_clauses_subset cls cls' prems concl : + cls ⊢a prems → concl -> + cls ⊂_clset cls' -> + cls' ⊢a prems → concl. +Proof. + intros d incl [l k]. + now move/d/entails_clauses_subset. +Qed. + + +Definition to_clauses (prems : nonEmptyLevelExprSet) (concl : nonEmptyLevelExprSet) : clauses := + LevelExprSet.fold (fun lk cls => Clauses.add (prems, lk) cls) concl Clauses.empty. + +Definition is_loop (cls : clauses) (t : nonEmptyLevelExprSet) := + let cls' := to_clauses t (succ_prems t) in + Clauses.For_all (fun cl' => entails cls cl') cls'. + +(* Definition is_looping (w : LevelSet.t) n (cls : clauses) := + let preml := LevelSet.elements w in + let prem := List.map (fun e => (e, n)) preml in + is_loop cls prem. *) + +Definition levelexprset_of_levels (ls : LevelSet.t) n : LevelExprSet.t := + LevelSet.fold (fun x => LevelExprSet.add (x, n)) ls LevelExprSet.empty. + +Lemma levelexprset_of_levels_spec {ls : LevelSet.t} {l k n} : + LevelExprSet.In (l, k) (levelexprset_of_levels ls n) <-> LevelSet.In l ls /\ k = n. +Proof. + rewrite /levelexprset_of_levels. + eapply LevelSetProp.fold_rec. + - intros s' he. rewrite LevelExprSetFact.empty_iff. firstorder. + - intros x a s' s'' hin hnin hadd ih. + rewrite LevelExprSet.add_spec; unfold LevelExprSet.E.eq. + firstorder eauto; try noconf H1 => //. + apply hadd in H1. firstorder. subst. now left. +Qed. + +#[program] +Definition of_level_set (ls : LevelSet.t) n (hne : ~ LevelSet.Empty ls) : nonEmptyLevelExprSet := + {| t_set := levelexprset_of_levels ls n |}. +Next Obligation. + apply not_Empty_is_empty => he. apply hne. + intros l nin. specialize (he (l,n)). apply he. + now rewrite levelexprset_of_levels_spec. +Qed. + +Definition loop_on_univ cls u := cls ⊢a u → succ_prems u. + +(* Definition loop_on W (hne : ~ LevelSet.Empty W) n cls := + cls ⊢a of_level_set W n hne → of_level_set W (n + 1) hne. + +Lemma loop_on_proper W W' n hne' cls : W =_lset W' -> exists hne, loop_on W hne n cls -> loop_on W' hne' n cls. +Proof. + intros eq; rewrite /loop_on /loop_on_univ. + assert (hne : ~ LevelSet.Empty W). now rewrite eq. + exists hne. + assert (of_level_set W n hne = of_level_set W' n hne') as ->. + apply eq_univ_equal. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. + assert (of_level_set W (n + 1) hne = of_level_set W' (n + 1) hne') as ->. + apply eq_univ_equal. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. + by []. +Qed. *) + +Lemma loop_on_subset {cls cls' u} : Clauses.Subset cls cls' -> loop_on_univ cls u -> loop_on_univ cls' u. +Proof. + intros sub; rewrite /loop_on_univ => hyp. + now eapply entails_all_clauses_subset. +Qed. + +Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := + | Loop (v : univ) (islooping : loop_on_univ cls v) + | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). +Arguments Loop {V U cls m}. +Arguments Model {V U cls m}. +Arguments lexprod {A B}. + +Definition option_of_result {V U m cls} (r : result V U m cls) : option model := + match r with + | Model w m _ => Some m.(model_model) + | Loop v _ => None + end. + +Notation "#| V |" := (LevelSet.cardinal V). + +Notation loop_measure V W := (#|V|, #|V| - #|W|)%nat. + +Definition lexprod_rel := lexprod lt lt. + +#[local] Instance lexprod_rel_wf : WellFounded lexprod_rel. +Proof. + eapply (Acc_intro_generator 1000). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. +Defined. + +Lemma strictly_updates_trans {cls cls' W W' m m' m''} : + strictly_updates cls W m m' -> + strictly_updates cls' W' m' m'' -> + strictly_updates (Clauses.union cls cls') (LevelSet.union W W') m m''. + Proof. + intros su su'. + eapply update_trans; eapply strictly_updates_weaken; tea; clsets. + Qed. + +Lemma check_model_is_update_of {cls cls' U W minit m m'} : is_update_of cls U minit m -> check_model cls' (U, m) = Some (W, m') -> + strictly_updates (Clauses.union cls cls') W minit m' /\ U ⊂_lset W. +Proof. + rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros ->. eapply LevelSetFact.is_empty_2 in he. + eapply LevelSetProp.empty_is_empty_1 in he. + eapply LevelSet.eq_leibniz in he. rewrite he. + move/check_model_updates_spec_empty. intros H; split => //. 2:lsets. + eapply strictly_updates_weaken; tea. clsets. + - intros hs. move/check_model_spec => [w'' [su ->]]. split; [|lsets]. + eapply strictly_updates_trans; tea. +Qed. + +Lemma is_update_of_case cls W m m' : + is_update_of cls W m m' -> + (LevelSet.Empty W /\ m =m m') \/ strictly_updates cls W m m'. +Proof. + rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros ->. left => //. now eapply LevelSetFact.is_empty_2 in he. + - intros H; now right. +Qed. + + +Lemma model_incl {V W m cls} : valid_model V W m cls -> W ⊂_lset V. +Proof. + intros vm; have upd := model_updates vm. + move/is_update_of_case: upd => []. + - intros [ne eq]. lsets. + - move/strictly_updates_incl. have hv := model_clauses_conclusions vm. lsets. +Qed. + +(* + model_of_W : model_of W model_model; + model_incl : ; +model_extends : model_extension V m model_model; + +Arguments model_of_W {V W m cls}. +Arguments model_incl {V W m cls}. +Arguments model_extends {V W m cls}. + *) + +Lemma model_of_ext {W m m'} : + model_of W m -> m ⩽ m' -> model_of W m'. +Proof. + intros mof ext. + intros k hin. destruct (mof k hin). specialize (ext _ _ H) as [k' []]. now exists k'. +Qed. + +Lemma valid_model_total W W' m cls : + forall vm : valid_model W W' m cls, model_of W m -> model_of W (model_model vm). +Proof. + intros []; cbn => htot. + move/is_update_of_case: model_updates0 => []. + - intros [ne eq] => //. + - intros su. eapply strictly_updates_ext in su. + eapply model_of_ext; tea. +Qed. + +Lemma is_update_of_ext {cls W m m'} : is_update_of cls W m m' -> m ⩽ m'. +Proof. + move/is_update_of_case => []. + - intros [he%LevelSetProp.empty_is_empty_1]. red. setoid_rewrite H. + move=> l k hm; exists k; split => //. reflexivity. + - apply strictly_updates_ext. +Qed. + +Lemma model_of_union {U V cls} : model_of U cls -> model_of V cls -> model_of (LevelSet.union U V) cls. +Proof. + intros hu hv x. + rewrite LevelSet.union_spec; move => [] hin. + now apply hu. now apply hv. +Qed. + +Lemma model_of_union_inv U V cls : model_of (LevelSet.union U V) cls -> model_of U cls /\ model_of V cls. +Proof. + rewrite /model_of. + setoid_rewrite LevelSet.union_spec. firstorder. +Qed. + +Lemma strictly_updates_model_of_gen cls W m m' : + strictly_updates cls W m m' -> + forall W', model_of W' m -> model_of (LevelSet.union W' W) m'. +Proof. + clear. + induction 1. + - intros W' tot x. + destruct cl as [prems [concl cl]]. + destruct H0 as [minv [hmin ? heq]]. setoid_rewrite heq. + setoid_rewrite LevelMapFact.F.add_in_iff. cbn. + destruct (Level.eq_dec concl x). + { now left. } + { rewrite LevelSet.union_spec; intros [hin|hin]. + { eapply tot in hin as [wit mt]. right; exists wit. assumption. } + { eapply LevelSet.singleton_spec in hin. red in hin; subst. congruence. } } + - intros W' tot. + eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. + eapply model_of_subset; tea. intros x; lsets. +Qed. + + +Lemma model_of_empty m : model_of LevelSet.empty m. +Proof. intros x; now move/LevelSet.empty_spec. Qed. + +Instance model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) model_of. +Proof. + intros ? ? H ? ? H'. unfold model_of. setoid_rewrite H. + now setoid_rewrite H'. +Qed. + +Lemma strictly_updates_total_model {cls W m m'} : + strictly_updates cls W m m' -> + model_of W m'. +Proof. + move/strictly_updates_model_of_gen/(_ LevelSet.empty). + intros H. forward H. apply model_of_empty. + rewrite LevelSetProp.empty_union_1 in H => //. lsets. +Qed. + +Lemma strictly_updates_only_model_gen cls W m m' : + strictly_updates cls W m m' -> + forall W', only_model_of W' m -> only_model_of (LevelSet.union W' W) m'. +Proof. + clear. + induction 1. + - intros W' tot x. + destruct cl as [prems [concl cl]]. + destruct H0 as [minv [hmin ? heq]]. setoid_rewrite heq. + setoid_rewrite LevelMapFact.F.add_mapsto_iff. cbn. + destruct (Level.eq_dec concl x). + { subst. rewrite LevelSet.union_spec LevelSet.singleton_spec. + firstorder; exists (cl + minv); left; split => //. } + { rewrite LevelSet.union_spec LevelSet.singleton_spec /LevelSet.E.eq. + firstorder. subst x. congruence. } + - intros W' tot. + eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. + eapply only_model_of_eq; tea. intros x; lsets. +Qed. + +Lemma is_update_of_total_model cls W m m' : is_update_of cls W m m' -> model_of W m'. +Proof. + move/is_update_of_case => []. + - intros [he eq]. + rewrite /model_of. lsets. + - eapply strictly_updates_total_model. +Qed. + +Lemma strict_update_modify m cl m' : strict_update m cl m' -> + exists k, LevelMap.Equal m' (LevelMap.add (clause_conclusion cl) k m). +Proof. + rewrite /strict_update. + destruct cl as [prems [concl k]]. + intros [v [hmin hab eq]]. now exists (k + v). +Qed. + +Lemma strictly_updates_model_of {cls W m m'} : + strictly_updates cls W m m' -> model_of W m'. +Proof. + move/strictly_updates_model_of_gen/(_ LevelSet.empty). + rewrite LevelSetProp.empty_union_1. lsets. + intros H; apply H. apply model_of_empty. +Qed. + +Lemma strictly_updates_modify {cls W m m'} : + strictly_updates cls W m m' -> + forall l k, LevelMap.MapsTo l k m' -> LevelSet.In l W \/ LevelMap.MapsTo l k m. +Proof. + induction 1. + + eapply strict_update_modify in H0 as [k eq]. + intros l k'. rewrite LevelSet.singleton_spec. + rewrite eq. + rewrite LevelMapFact.F.add_mapsto_iff. + intros [[]|] => //. red in H0; subst. + left. lsets. now right. + + intros. eapply IHstrictly_updates2 in H1. + destruct H1. left; lsets. + eapply IHstrictly_updates1 in H1 as []. left; lsets. + now right. +Qed. + +Lemma strictly_updates_modify_inv {cls W m m'} : + strictly_updates cls W m m' -> + forall l k, LevelMap.MapsTo l k m -> LevelSet.In l W \/ LevelMap.MapsTo l k m'. +Proof. + induction 1. + + eapply strict_update_modify in H0 as [k eq]. + intros l k'. rewrite LevelSet.singleton_spec. + rewrite eq. + rewrite LevelMapFact.F.add_mapsto_iff. + intros hm. unfold Level.eq. + destruct (eq_dec l (clause_conclusion cl)). subst. now left. + right. right. auto. + + intros. eapply IHstrictly_updates1 in H1 as []. + left; lsets. + eapply IHstrictly_updates2 in H1 as []. left; lsets. + now right. +Qed. + +Lemma strictly_updates_outside cls W m m' : + strictly_updates cls W m m' -> model_map_outside W m m'. +Proof. + move=> su. + have lr := strictly_updates_modify su. + have rl := strictly_updates_modify_inv su. + intros l nin k. + split; intros. + - apply rl in H as [] => //. + - apply lr in H as [] => //. +Qed. + +Lemma valid_model_model_map_outside {W W' m cls} (vm : valid_model W W' m cls) : model_map_outside W m (model_model vm). +Proof. + destruct vm as [m' mV mupd mcls mok]; cbn. + - move/is_update_of_case: mupd => []. + * intros [ne <-]. red. intros. reflexivity. + * intros su. eapply (model_map_outside_weaken (W:=W')). + 2:{ eapply strictly_updates_incl in su. lsets. } + clear -su. revert su. + eapply strictly_updates_outside. +Qed. + + +Lemma check_model_has_invariants {cls w m w' m'} : + model_of (clauses_conclusions cls) m -> + model_of w m -> + check_model cls (w, m) = Some (w', m') -> + check_model_invariants cls w m w' m' true. +Proof. + intros mof tot. + move/check_model_spec => [w'' [su ->]]. + cbn. split. + - lsets. + - apply strictly_updates_incl in su. lsets. + - clear -su. induction su. + * exists cl. split => //. now eapply strict_update_invalid. + unfold clause_conclusion. lsets. + destruct cl as [prems [concl k]]. + destruct H0 as [minp [hin hnabove habove]]. + move: hnabove habove. rewrite /level_value_above. + cbn. destruct level_value eqn:hv => //; try constructor. + intros hle. intros ->. rewrite level_value_add. constructor. + move/negbTE: hle. lia. + * destruct IHsu1 as [cl []]. + exists cl. split => //. lsets. + apply strictly_updates_ext in su2. + depelim H2; rewrite ?H3. 2:{ rewrite H2; constructor. } + eapply level_value_MapsTo', su2 in H4 as [k' [map le]]. + eapply level_value_MapsTo in map. rewrite map. constructor; lia. + - constructor. now eapply strictly_updates_ext. + clear -mof su. + induction su. + * move: H0; unfold strict_update. destruct cl as [prems [concl k]]. + intros [v [hmi nabove eqm]]. intros l. rewrite eqm. + rewrite LevelMapFact.F.add_in_iff. specialize (mof l). + rewrite clauses_conclusions_spec in mof. firstorder. + * specialize (IHsu1 mof). transitivity m' => //. + apply IHsu2. intros l hin. specialize (mof _ hin). now apply IHsu1 in mof. + * eapply model_map_outside_weaken. now eapply strictly_updates_outside. lsets. + - eapply strictly_updates_model_of_gen in su; tea. +Qed. + +Lemma clauses_levels_conclusions cls V : clauses_levels cls ⊂_lset V -> + clauses_conclusions cls ⊂_lset V. +Proof. + intros hin x; rewrite clauses_conclusions_spec; move => [cl [hin' eq]]; apply hin. + rewrite clauses_levels_spec. exists cl. split => //. subst x. + rewrite clause_levels_spec. now right. +Qed. +Definition clauses_premises_levels (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls LevelSet.empty. + +Lemma clauses_premises_levels_spec_aux l cls acc : + LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls acc) <-> + (exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl))) \/ LevelSet.In l acc. +Proof. + eapply ClausesProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k [hin hl]]. clsets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.union_spec. + split. + * intros [hin'|]. + left. exists x. split => //. + apply hadd. now left. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. + * intros [[k [ins'' ?]]|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma clauses_premises_levels_spec l cls : + LevelSet.In l (clauses_premises_levels cls) <-> + exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl)). +Proof. + unfold clauses_premises_levels. + rewrite clauses_premises_levels_spec_aux. + intuition auto. lsets. +Qed. + +Lemma clauses_levels_premises cls V : clauses_levels cls ⊂_lset V -> + clauses_premises_levels cls ⊂_lset V. +Proof. + intros hin x; rewrite clauses_premises_levels_spec; move => [cl [hin' eq]]; apply hin. + rewrite clauses_levels_spec. exists cl. split => //. + rewrite clause_levels_spec. now left. +Qed. + +Lemma clauses_premises_levels_incl cls : clauses_premises_levels cls ⊂_lset clauses_levels cls. +Proof. + intros x; rewrite clauses_premises_levels_spec clauses_levels_spec; move => [cl [hin' eq]]. + exists cl; split => //. + rewrite clause_levels_spec. now left. +Qed. + +Lemma clauses_premises_levels_mon {cls cls'} : cls ⊂_clset cls' -> + clauses_premises_levels cls ⊂_lset clauses_premises_levels cls'. +Proof. + intros hin x; rewrite !clauses_premises_levels_spec; move => [cl [hin' eq]]. + exists cl; split => //. now apply hin. +Qed. + +Definition monotone_selector sel := + forall cls' cls, cls' ⊂_clset cls -> sel cls' ⊂_lset sel cls. + +Lemma clauses_levels_mon : monotone_selector clauses_levels. +Proof. + intros cls' cls hin x; rewrite !clauses_levels_spec; move => [cl [hin' eq]]. + exists cl; split => //. now apply hin. +Qed. + +Definition infers_atom (m : model) (l : Level.t) (k : Z) := Some k ≤ level_value m l. + +Definition max_premise_model cls sel m := + (forall l, LevelSet.In l (sel cls) -> + LevelMap.MapsTo l (max_clause_premise cls) m) /\ + (forall l k, LevelMap.MapsTo l k m -> LevelSet.In l (sel cls) /\ k = max_clause_premise cls). + +Definition max_premise_map cls : model := + let max := max_clause_premise cls in + let ls := clauses_levels cls in + LevelSet.fold (fun l acc => LevelMap.add l max acc) ls (LevelMap.empty _). + +Definition above_max_premise_model cls m := + (exists V, strictly_updates cls V (max_premise_map cls) m) \/ m = max_premise_map cls. + +Lemma max_premise_model_exists cls : max_premise_model cls clauses_levels (max_premise_map cls). +Proof. + rewrite /max_premise_map; split. + - intros l. + eapply LevelSetProp.fold_rec. + { intros s he hin. now apply he in hin. } + intros. + destruct (Level.eq_dec l x). subst. + * eapply LevelMapFact.F.add_mapsto_iff. left; split => //. + * eapply LevelMapFact.F.add_mapsto_iff. right. split => //. now unfold Level.eq. apply H2. + specialize (H1 l). apply H1 in H3. destruct H3 => //. congruence. + - intros l k. + eapply LevelSetProp.fold_rec. + { intros s' he hm. now eapply LevelMapFact.F.empty_mapsto_iff in hm. } + intros. + eapply LevelMapFact.F.add_mapsto_iff in H3 as []. + * destruct H3. noconf H4. split => //. apply H1. now left. + * destruct H3. firstorder. +Qed. + +Lemma infer_atom_downward {m l k k'} : + infers_atom m l k -> + (k' <= k) -> + infers_atom m l k'. +Proof. + rewrite /infers_atom. + intros infa le. + transitivity (Some k) => //. now constructor. +Qed. + +Lemma infers_atom_le {m m' l k} : + infers_atom m l k -> + m ⩽ m' -> + infers_atom m' l k. +Proof. + rewrite /infers_atom. + intros infa le. + depelim infa. eapply level_value_MapsTo' in H0. eapply le in H0 as [k' [hm hle]]. + rewrite (level_value_MapsTo hm). constructor; lia. +Qed. + +Lemma infers_atom_mapsto m l k : infers_atom m l k <-> + exists k', LevelMap.MapsTo l k' m /\ (k <= k'). +Proof. + rewrite /infers_atom; split. + - intros hle; depelim hle. + eapply level_value_MapsTo' in H0. exists y. split => //. + - intros [k' [hm hle]]. + eapply level_value_MapsTo in hm. rewrite hm. now constructor. +Qed. + +Lemma above_max_premise_model_infers {cls m} : + above_max_premise_model cls m -> + (forall l, LevelSet.In l (clauses_levels cls) -> infers_atom m l (max_clause_premise cls)). +Proof. + intros ha l hl. + have hm := max_premise_model_exists cls. + destruct ha as [[V su]|eq]. + * eapply strictly_updates_ext in su. + eapply infers_atom_le; tea. + eapply infers_atom_mapsto. + destruct hm. exists (max_clause_premise cls). split => //. + now eapply H. reflexivity. + * subst m. eapply infers_atom_mapsto. destruct hm. + specialize (H l hl). eexists; split. exact H. lia. +Qed. + +Lemma clauses_with_concl_union cls W W' : + Clauses.Equal (clauses_with_concl cls (LevelSet.union W W')) + (Clauses.union (clauses_with_concl cls W) (clauses_with_concl cls W')). +Proof. + intros x. rewrite Clauses.union_spec !in_clauses_with_concl LevelSet.union_spec. + firstorder. +Qed. + +Lemma strictly_updates_strenghten {cls W m m'} : + strictly_updates cls W m m' -> + strictly_updates (cls ↓ W) W m m'. +Proof. + induction 1. + - constructor. rewrite in_clauses_with_concl. split => //. + eapply LevelSet.singleton_spec; reflexivity. exact H0. + - rewrite clauses_with_concl_union. econstructor 2. + eapply strictly_updates_weaken; tea. intros x; clsets. + eapply strictly_updates_weaken; tea. intros x; clsets. +Qed. + +Lemma clauses_with_concl_subset cls W : (cls ↓ W) ⊂_clset cls. +Proof. now intros ?; rewrite in_clauses_with_concl. Qed. + +Section InnerLoop. + Definition sum_W W (f : LevelSet.elt -> nat) : nat := + LevelSet.fold (fun w acc => acc + f w)%nat W 0%nat. + + Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := + sum_W W (fun w => Z.to_nat (measure_w W cls m w)). + + Lemma maps_to_value_default {x k m} : LevelMap.MapsTo x k m -> level_value m x = Some k. + Proof. + intros h; apply LevelMap.find_1 in h. + now rewrite /level_value h. + Qed. + + Lemma measure_model W cls m : + model_of W m -> + let clsdiff := cls_diff cls W in + measure W cls m = 0%nat -> is_model clsdiff m. + Proof using. + unfold measure, sum_W, measure_w, is_model. + set (clsdiff := Clauses.diff _ _). + intros hv hm. + assert (LevelSet.For_all (fun w => Some (v_minus_w_bound W m + Z.of_nat (max_gain clsdiff)) ≤ level_value m w) W). + { move: hm. + generalize (v_minus_w_bound W m) => vbound. + eapply LevelSetProp.fold_rec. + intros. intros x hin. firstorder eauto. + intros x a s' s'' inw nins' hadd ih heq. + forward ih by lia. + intros l hin. + specialize (hv _ inw) as [k lv]. rewrite /level_value_default (maps_to_value_default lv) in heq. + apply hadd in hin as []. + * subst x. rewrite (maps_to_value_default lv). constructor. lia. + * now apply ih. } + clear hm. + eapply ClausesFact.for_all_iff. tc. + intros cl hl. + unfold valid_clause. + destruct min_premise as [k0|] eqn:hk0 => //. + destruct cl as [prem [l k]] => /=. cbn in hk0. + rewrite /clsdiff in hl. + destruct (proj1 (Clauses.diff_spec _ _ _) hl) as [hlcls hl']. + eapply in_clauses_with_concl in hlcls as [lW incls]. + specialize (H _ lW). cbn -[clsdiff] in H. cbn in lW. + specialize (hv _ lW) as [vl hvl]. rewrite /level_value_above (maps_to_value_default hvl). + rewrite (maps_to_value_default hvl) in H; depelim H. + (* etransitivity; tea. *) + set (prem' := non_W_atoms W prem). + assert (ne : LevelExprSet.is_empty prem' = false). + { now eapply (non_W_atoms_ne W (prem, (l, k)) cls). } + set (preml := {| t_set := prem'; t_ne := ne |}). + assert (min_premise m prem ≤Z min_premise m preml). + { eapply min_premise_subset. eapply non_W_atoms_subset. } + (* min_i (f(x_i)-k_i) <= max_i(f(x_i)) - min(k_i) *) + pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. + rewrite hk0 in H0. depelim H0. rename y into minpreml. + pose proof (min_premise_max_premise _ _ _ H1) as [maxpreml eqmaxp]. + pose proof (max_premise_value_spec m preml _ eqmaxp) as [amax [exmax [inmaxpre eqmaxpre]]]. + rewrite -eqmaxp in eqmaxpre. + pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. + assert (min_premise m preml ≤Z Some (maxpreml - premise_min preml))%Z. + { rewrite eqminpre in H1. + specialize (amax _ inminpre). destruct amax as [k' [lk' hk']]. + depelim hk'. + pose proof (min_atom_value_levelexpr_value m exmin _ _ H2 lk'). + rewrite eqminpre H2. constructor. etransitivity; tea. + rewrite eqmaxpre in eqmaxp. + assert (expmin <= exmin). specialize (apmin _ inminpre). lia. + unfold level_expr_elt in *. lia. } + apply Z.leb_le. rewrite H1 in H2. depelim H2. + transitivity (k + (maxpreml - premise_min preml)). lia. + assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff)%nat. + { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. + unfold gain. cbn. + pose proof (premise_min_subset preml prem). + enough (premise_min prem <= premise_min preml) by lia. + forward H3. eapply non_W_atoms_subset. lia. } + transitivity (v_minus_w_bound W m + (gain (preml, (l, k)))). + 2:lia. + unfold gain. cbn -[max_premise_value premise_min]. + assert (k + (maxpreml - premise_min preml) = + (maxpreml + k - premise_min preml)) as ->. lia. + assert (maxpreml <= v_minus_w_bound W m). + { pose proof (v_minus_w_bound_spec W m exmax). + have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). + rewrite levelexprset_levels_spec in hlevels. + forward hlevels. + exists exmax.2. now destruct exmax. + rewrite LevelSet.diff_spec in hlevels. + destruct hlevels. + forward H4 by auto. + rewrite eqmaxp in eqmaxpre. unfold levelexpr_value in eqmaxpre. rewrite -eqmaxpre in H4. + now depelim H4. + } + lia. + Qed. + + Lemma level_value_default_def {m x v} : level_value m x = Some v -> level_value_default m x = v. + Proof. unfold level_value_default. now intros ->. Qed. + + Lemma w_values_ext m m' W : + m ⩽ m' -> model_of W m -> model_of W m'. + Proof. + intros ext hf x hin. + specialize (hf x hin) as [k hl]. + specialize (ext _ _ hl) as [? []]. + now exists x0. + Qed. + + Lemma level_values_in_W m m' W x : + model_of W m -> + m ⩽ m' -> + LevelSet.In x W -> level_value m x ≤ level_value m' x -> + exists k k', level_value m x = Some k /\ level_value m' x = Some k' /\ (k <= k'). + Proof. + intros hwv ext hin hleq. + specialize (hwv _ hin) as x'. destruct x' as [k hl]. rewrite (maps_to_value_default hl) in hleq. + eapply w_values_ext in hwv; tea. + specialize (hwv _ hin) as [k' hl']. + rewrite (maps_to_value_default hl') in hleq. depelim hleq. + do 2 eexists. intuition eauto. + now rewrite (maps_to_value_default hl). + now rewrite (maps_to_value_default hl'). + Qed. + + Lemma measure_le {W cls m m'} : + model_of W m -> + model_map_outside W m m' -> + m ⩽ m' -> + (measure W cls m' <= measure W cls m)%nat. + Proof. + intros hwv hout hle. + unfold measure, measure_w, sum_W. + rewrite (v_minus_w_bound_irrel _ _ hout). + rewrite !LevelSet.fold_spec. unfold flip. + eapply fold_left_le; unfold flip. 2:lia. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. + erewrite !level_value_default_def; tea. lia. + Qed. + + Lemma measure_lt {W cls m m'} : + model_of W m -> + model_map_outside W m m' -> + m ⩽ m' -> + (exists l, [/\ LevelSet.In l W, (0 < measure_w W cls m l)%Z & + opt_le Z.lt (level_value m l) (level_value m' l)])%Z -> + (measure W cls m' < measure W cls m)%nat. + Proof. + intros hwv hout hle. + unfold measure, measure_w, sum_W. + rewrite (v_minus_w_bound_irrel _ _ hout). + intros hlt. + rewrite !LevelSet.fold_spec. unfold flip. + eapply fold_left_ne_lt; unfold flip. + - unfold flip. intros; lia. + - unfold flip; intros; lia. + - destruct hlt as [l [hin _]]. intros he. rewrite -LevelSetProp.elements_Empty in he. lsets. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. + erewrite !level_value_default_def; tea. lia. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. + erewrite !level_value_default_def; tea. lia. + - destruct hlt as [l [hinl hbound hlev]]. + exists l. rewrite LevelSet_In_elements. split => //. + intros acc acc' accle. + eapply Nat.add_le_lt_mono => //. + depelim hlev. rewrite /level_value_default ?H0 ?H1 in hbound |- *. + lia. now eapply model_of_value_None in H; tea. + Qed. + + Lemma is_model_equal {cls cls' m} : Clauses.Equal cls cls' -> is_model cls m -> is_model cls' m. + Proof. now intros ->. Qed. + + Lemma union_diff_eq {cls cls'} : Clauses.Equal (Clauses.union cls (Clauses.diff cls' cls)) + (Clauses.union cls cls'). + Proof. clsets. Qed. + + Lemma union_restrict_with_concl {cls W} : + Clauses.Equal (Clauses.union (cls ⇂ W) (cls ↓ W)) (cls ↓ W). + Proof. + intros cl. rewrite Clauses.union_spec. + intuition auto. + eapply in_clauses_with_concl. + now eapply in_restrict_clauses in H0 as []. + Qed. + + Lemma union_diff {cls W} : + Clauses.Equal (Clauses.union (Clauses.diff (cls ↓ W) (cls ⇂ W)) (cls ⇂ W)) (cls ↓ W). + Proof. + now rewrite ClausesProp.union_sym union_diff_eq union_restrict_with_concl. + Qed. + + Lemma union_diff_cls {cls W} : + Clauses.Equal (Clauses.union (Clauses.diff (cls ↓ W) (cls ⇂ W)) cls) cls. + Proof. + intros ?. rewrite Clauses.union_spec Clauses.diff_spec in_restrict_clauses in_clauses_with_concl. + firstorder. + Qed. + + Lemma maps_to_level_value x (m m' : model) : + (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> + level_value m x = level_value m' x. + Proof. + intros heq. + unfold level_value. + destruct LevelMap.find eqn:hl. + apply LevelMap.find_2 in hl. rewrite heq in hl. + rewrite (LevelMap.find_1 hl) //. + destruct (LevelMap.find x m') eqn:hl' => //. + apply LevelMap.find_2 in hl'. rewrite -heq in hl'. + now rewrite (LevelMap.find_1 hl') in hl. + Qed. + + Lemma measure_Z_lt x y : + (x < y)%Z -> + (0 < y)%Z -> + (Z.to_nat x < Z.to_nat y)%nat. + Proof. intros. lia. Qed. + + Lemma sum_pos W f : + (0 < sum_W W f)%nat -> + exists w, LevelSet.In w W /\ (0 < f w)%nat. + Proof. + unfold sum_W. + eapply LevelSetProp.fold_rec => //. + intros. lia. + intros. + destruct (Nat.ltb_spec 0 a). + - destruct (H2 H4) as [w [hin hlt]]. exists w. split => //. apply H1. now right. + - exists x. split => //. apply H1. now left. lia. + Qed. + + Lemma measure_pos {W cls m} : + (0 < measure W cls m)%nat -> + exists l, LevelSet.In l W /\ (0 < measure_w W cls m l)%Z. + Proof. + unfold measure. + move/sum_pos => [w [hin hlt]]. + exists w. split => //. lia. + Qed. + + Lemma model_of_diff cls W m : + model_of W m -> model_of (clauses_conclusions (cls_diff cls W)) m. + Proof. + intros; eapply model_of_subset; tea. + eapply clauses_conclusions_diff_left. + Qed. + Hint Resolve model_of_diff : core. + + Lemma check_model_spec_diff {cls w m w' m' w''} : + model_of w m -> + model_of w'' m -> + let cls := (cls_diff cls w) in + check_model cls (w'', m) = Some (w', m') -> + [/\ w'' ⊂_lset w', w' ⊂_lset (w'' ∪ w), + exists cl : clause, + let cll := levelexpr_level (concl cl) in + [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' + & (opt_le Z.lt (level_value m cll) (level_value m' cll))%Z] + & model_extension w' m m']. + Proof. + cbn; intros mof tot cm. + pose proof (clauses_conclusions_diff_left cls w (cls ⇂ w)). + apply check_model_has_invariants in cm as []. + split => //. lsets. + eapply model_of_subset. exact mof. tea. exact tot. + Qed. + + Lemma model_of_extension {W W' m m'} : + model_of W m -> model_extension W' m m' -> model_of W m'. + Proof. + intros mof [_ dom _]. + intros k hin. apply dom. now apply mof. + Qed. + + Lemma clauses_partition_spec {cls W allW conclW} : + clauses_conclusions cls ⊂_lset W -> + Clauses.partition (premise_restricted_to W) cls = (allW, conclW) -> + (Clauses.Equal allW (cls ⇂ W)) /\ + (Clauses.Equal conclW (Clauses.diff cls (cls ⇂ W))). + Proof. + intros clW. + destruct Clauses.partition eqn:eqp. + intros [= <- <-]. + change t with (t, t0).1. + change t0 with (t, t0).2 at 2. + rewrite -eqp. clear t t0 eqp. + split. + - intros cl. rewrite Clauses.partition_spec1. + rewrite in_restrict_clauses Clauses.filter_spec. + rewrite /premise_restricted_to LevelSet.subset_spec. firstorder eauto. + apply clW, clauses_conclusions_spec. now exists cl. + - intros cl. rewrite Clauses.partition_spec2. + rewrite Clauses.filter_spec Clauses.diff_spec. + rewrite /premise_restricted_to. intuition auto. + move/negbTE: H1. eapply eq_true_false_abs. + eapply LevelSet.subset_spec. + now eapply in_restrict_clauses in H as []. + apply eq_true_not_negb. move/LevelSet.subset_spec => he. + apply H1. apply in_restrict_clauses. split => //. + apply clW, clauses_conclusions_spec. now exists cl. + Qed. + + Lemma clauses_conclusions_eq cls W : + clauses_conclusions cls ⊂_lset W -> + Clauses.Equal cls (cls ↓ W). + Proof. + intros cl x. + rewrite in_clauses_with_concl. intuition auto. + apply cl, clauses_conclusions_spec. now exists x. + Qed. + + (* Inductive inner_result (V U : LevelSet.t) (cls : clauses) (m : model) := + | InLoop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne cls) + | InModel (w : LevelSet.t) (m : valid_model V w m cls). + (* (prf : U ⊂_lset w /\ w ⊂_lset V). *) + Arguments InLoop {V U cls m}. + Arguments InModel {V U cls m}. *) + + Lemma is_update_of_empty cls m : + is_update_of cls LevelSet.empty m m. + Proof. + unfold is_update_of. + rewrite LevelSetFact.is_empty_1 //. lsets. + Qed. + + Lemma strictly_updates_W_eq cls W init m W' : + LevelSet.Equal W W' -> + strictly_updates cls W init m -> + strictly_updates cls W' init m. + Proof. now intros ->. Qed. + + Lemma strictly_updates_clauses_W cls cls' W init m W' : + Clauses.Subset cls cls' -> + LevelSet.Equal W W' -> + strictly_updates cls W init m -> + strictly_updates cls' W' init m. + Proof. intros hsub ->. now apply strictly_updates_weaken. Qed. + + Lemma strictly_updates_is_update_of cls W init m cls' W' m' : + strictly_updates cls W init m -> + is_update_of cls' W' m m' -> + strictly_updates (Clauses.union cls cls') (LevelSet.union W W') init m'. + Proof. + move=> su /is_update_of_case; intros [[empw eq]|su']. + rewrite <- eq. eapply (strictly_updates_weaken cls). clsets. + eapply strictly_updates_W_eq; tea. lsets. + eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. + Qed. + + Definition restrict_model W (m : model) := + LevelMapFact.filter (fun l k => LevelSet.mem l W) m. + + Lemma restrict_model_spec W m : + forall l k, LevelMap.MapsTo l k (restrict_model W m) <-> LevelMap.MapsTo l k m /\ LevelSet.In l W. + Proof. + intros l k; rewrite /restrict_model. + now rewrite LevelMapFact.filter_iff LevelSet.mem_spec. + Qed. + + (* Updates the entries in m with the values in m' if any *) + Definition model_update (m m' : model) : model := + LevelMap.mapi (fun l k => + match LevelMap.find l m' with + | Some k' => k' + | None => k + end) m. + + Instance model_update_proper : Proper (LevelMap.Equal ==> LevelMap.Equal ==> LevelMap.Equal) model_update. + Proof. + intros ? ? eq ? ? eq'. + rewrite /model_update. + apply LevelMapFact.F.Equal_mapsto_iff. + intros k e. + rewrite LevelMapFact.F.mapi_mapsto_iff. now intros ? ? ? ->. + rewrite LevelMapFact.F.mapi_mapsto_iff. now intros ? ? ? ->. + firstorder. exists x1. rewrite H. now rewrite -eq eq'. + rewrite H. exists x1. now rewrite eq -eq'. + Qed. + + Inductive findSpec l m : option Z -> Prop := + | inm k : LevelMap.MapsTo l k m -> findSpec l m (Some k) + | ninm : ~ LevelMap.In l m -> findSpec l m None. + + Lemma find_spec l m : findSpec l m (LevelMap.find l m). + Proof. + destruct (LevelMap.find l m) eqn:heq; constructor. + now apply LevelMap.find_2. + now apply LevelMapFact.F.not_find_in_iff in heq. + Qed. + + Lemma model_update_spec m m' : + forall l k, LevelMap.MapsTo l k (model_update m m') <-> + (~ LevelMap.In l m' /\ LevelMap.MapsTo l k m) \/ + (LevelMap.MapsTo l k m' /\ LevelMap.In l m). + Proof. + intros l k; split. + - unfold model_update => hl. + eapply LevelMapFact.F.mapi_inv in hl as [a [k' [-> [eqk mt]]]]. + move: eqk; elim: (find_spec l m'). + + intros ? hm <-. right; split => //. now exists a. + + intros nin ->. left. split => //. + - intros [[nin hm]|[inm' inm]]. + * eapply LevelMapFact.F.mapi_mapsto_iff. now intros x y e ->. + elim: (find_spec l m'). + + intros k0 hm'. elim nin. now exists k0. + + intros _. exists k. split => //. + * eapply LevelMapFact.F.mapi_mapsto_iff. now intros x y e ->. + elim: (find_spec l m'). + + intros k0 hm'. destruct inm as [a inm]. exists a. split => //. + now eapply LevelMapFact.F.MapsTo_fun in inm'; tea. + + intros nin; elim nin. now exists k. + Qed. + + Lemma model_update_restrict m W : model_update m (restrict_model W m) =m m. + Proof. + apply LevelMapFact.F.Equal_mapsto_iff. intros l k. + rewrite model_update_spec. + split => //. + - intros [[nin hk]|[hr inm]] => //. + now eapply restrict_model_spec in hr. + - intros hm. + destruct (find_spec l (restrict_model W m)). + + right. apply restrict_model_spec in H as [hm' hw]. + split. eapply LevelMapFact.F.MapsTo_fun in hm; tea. subst. apply restrict_model_spec; split => //. + now exists k. + + left. split => //. + Qed. + + + Lemma min_premise_preserved {m m'} {prems : univ} : + (forall x, LevelSet.In x (levels prems) -> level_value m x = level_value m' x) -> + min_premise m prems = min_premise m' prems. + Proof. + intros hcl. + unfold min_premise. + funelim (to_nonempty_list prems). bang. clear H. + rw_in levelexprset_levels_spec hcl. + have -> : min_atom_value m e = min_atom_value m' e. + { destruct e as [k l']. + rewrite /min_atom_value. rewrite -hcl //. + exists l'. + apply LevelExprSet.elements_spec1. rewrite e0. now left. } + have cl' : forall x, (exists k, InA eq (x, k) l) -> level_value m x = level_value m' x. + { intros x [k ina]. apply hcl. exists k. apply LevelExprSet.elements_spec1. rewrite e0. now right. } + clear hcl Heqcall e0. + generalize (min_atom_value m' e). + induction l; cbn; auto. + have -> : min_atom_value m a = min_atom_value m' a. + { destruct a as [k l']. + rewrite /min_atom_value. rewrite cl' //. + exists l'. now left. } + intros o. + apply IHl. + intros x [k l']. apply cl'. exists k. now right. + Qed. + + + Lemma levelmap_find_eq {A} x (m m' : LevelMap.t A) : + (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> + LevelMap.find x m = LevelMap.find x m'. + Proof. + intros hm. + destruct (LevelMap.find x m) eqn:he; + destruct (LevelMap.find x m') eqn:he'. + all:try apply LevelMap.find_2 in he. all:try apply LevelMap.find_2 in he'. + apply hm in he. eapply LevelMapFact.F.MapsTo_fun in he; tea. congruence. + apply hm in he. apply LevelMapFact.F.not_find_in_iff in he'. firstorder. + apply LevelMapFact.F.not_find_in_iff in he. firstorder. congruence. + Qed. + + Lemma levelmap_find_eq_inv {A} x (m m' : LevelMap.t A) : + LevelMap.find x m = LevelMap.find x m' -> + (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m'). + Proof. + intros hfind. + destruct (LevelMap.find x m) eqn:he; + destruct (LevelMap.find x m') eqn:he'. + all:try apply LevelMap.find_2 in he. all:try apply LevelMap.find_2 in he'. all:try congruence. + noconf hfind. intros k; split; intros. + eapply LevelMapFact.F.MapsTo_fun in he; tea. now subst. + eapply LevelMapFact.F.MapsTo_fun in he'; tea. now subst. + intros k; split; intros. + apply LevelMapFact.F.not_find_in_iff in he. firstorder. + apply LevelMapFact.F.not_find_in_iff in he'. firstorder. + Qed. + + Lemma min_premise_restrict m W (prems : univ) v : + (forall l k, LevelExprSet.In (l, k) prems -> LevelSet.In l W) -> + min_premise (restrict_model W m) prems = Some v -> + min_premise m prems = Some v. + Proof. + intros hin. + rewrite (@min_premise_preserved _ m) //. + move=> x. rewrite levelexprset_levels_spec => [] [k] /hin inW. + apply levelmap_find_eq => k'. + rewrite restrict_model_spec. firstorder. + Qed. + + Lemma model_of_model_update W m m' : + model_of W m -> + model_of W (model_update m m'). + Proof. + intros hm l hin. + move/hm: hin => [k hin]. + red. rw model_update_spec. + destruct (LevelMapFact.F.In_dec m' l). + - destruct i as [k' hin']. exists k'. right; split => //. now exists k. + - exists k; left; split => //. + Qed. + + Lemma strictly_updates_restrict_only_model {cls W m m'} : strictly_updates cls W m m' -> + only_model_of W (restrict_model W m'). + Proof. + intros su. red. rw restrict_model_spec. + split => //. 2:clear; firstorder. + eapply strictly_updates_total_model in su. move/[dup]/su. clear; firstorder. + Qed. + + Lemma only_model_of_restrict W m : + model_of W m -> only_model_of W (restrict_model W m). + Proof. + intros mof x. rw restrict_model_spec. firstorder. + Qed. + + Lemma strictly_updates_from_restrict {cls W W' m m'} : + clauses_conclusions cls ⊂_lset W -> + model_of W m -> + strictly_updates cls W' (restrict_model W m) m' -> + only_model_of W m'. + Proof. + intros hcls mof su. + have om := strictly_updates_only_model_gen _ _ _ _ su W. + apply strictly_updates_incl in su. + have hu : ((W ∪ W') =_lset W). intros x; lsets. + rewrite hu in om. apply om. + now apply only_model_of_restrict. + Qed. + + Lemma restrict_model_update W m m' : + model_of W m' -> + only_model_of W m -> + restrict_model W (model_update m' m) =m m. + Proof. + intros mof om. + intro l. apply levelmap_find_eq => k. + rewrite restrict_model_spec model_update_spec. split. + - move=> [] [[hnin hm] hin|hm hin]. + specialize (proj1 (om l) hin) as [x hm']. elim hnin. now exists x. + apply hm. + - move=> hm. split => //. 2:now apply om; exists k. + right; firstorder. + Qed. + + Lemma model_update_trans m upd upd' : + (forall l, LevelMap.In l upd -> LevelMap.In l upd') -> + model_update (model_update m upd) upd' =m model_update m upd'. + Proof. + intros hl l. apply levelmap_find_eq => k. + rewrite !model_update_spec /LevelMap.In. + rw model_update_spec. firstorder. + right. split => //. + destruct (LevelMapFact.F.In_dec upd l). + - destruct i as [updv hk]. + exists updv. firstorder. + - exists x; left; firstorder. + Qed. + + (* If we can update starting from a restricted model with no values outside [W], + this can be lifted to the unrestricted model, applying the same updates *) + Lemma strictly_updates_restrict_model_gen cls W W' m' : + forall cls' mr, + strictly_updates cls' W' mr m' -> + forall m, model_of W m -> + cls' = (cls ⇂ W) -> + mr =m (restrict_model W m) -> + strictly_updates (cls ⇂ W) W' m (model_update m m'). + Proof. + intros cls' mr. induction 1. + - intros mi mofW -> hm. + constructor. auto. + destruct cl as [prems [concl k]]. + destruct H0 as [v [hmin above heq]]. + rewrite hm in hmin, above. + exists v. split => //. + eapply min_premise_restrict with W => //. + { intros l k' hp. move/in_restrict_clauses: H => [] //= _ hsub _. apply hsub. + rewrite levelexprset_levels_spec. now exists k'. } + move: above. + rewrite /level_value_above /level_value. + elim: find_spec => //. + + intros kr hkr. + apply restrict_model_spec in hkr as [hkr hcl]. + now rewrite (LevelMap.find_1 hkr). + + move=> ncl _. + elim: find_spec => // => k' inm. + apply in_restrict_clauses in H as [inconcl inprems incls]. cbn in *. + elim ncl. exists k'. eapply restrict_model_spec. split => //. + + apply in_restrict_clauses in H as [inconcl inprems incls]. cbn in *. + rewrite heq. intro. apply levelmap_find_eq => k'. + rewrite hm. + rewrite model_update_spec !LevelMapFact.F.add_mapsto_iff restrict_model_spec. + rewrite LevelMapFact.F.add_in_iff /Level.eq. firstorder; subst. + right. split => //. left => //. now apply mofW. + destruct (inLevelSet W y). + * right. split. right => //. now exists k'. + * left. split => //. intros []. congruence. + destruct H2 as [yrest hin]. eapply restrict_model_spec in hin as []. contradiction. + - intros mtot mof -> hm. specialize (IHstrictly_updates1 mtot mof eq_refl hm). + specialize (IHstrictly_updates2 (model_update mtot m')). + have model_of : model_of W (model_update mtot m'). + by apply model_of_model_update. + specialize (IHstrictly_updates2 model_of eq_refl). + forward IHstrictly_updates2. + { rewrite hm in H. eapply strictly_updates_from_restrict in H; tea. + 2:eapply clauses_conclusions_restrict_clauses. + now rewrite restrict_model_update. } + eapply update_trans; tea. + have eqm : (model_update (model_update mtot m') m'') =m model_update mtot m''. + { eapply model_update_trans. eapply strictly_updates_ext in H0. + intros l [k hin]. apply H0 in hin as [k' []]. now exists k'. } + now rewrite eqm in IHstrictly_updates2. + Qed. + + Lemma strictly_updates_restrict_model cls W W' m' : + forall m, model_of W m -> + strictly_updates (cls ⇂ W) W' (restrict_model W m) m' -> + strictly_updates (cls ⇂ W) W' m (model_update m m'). + Proof. + intros m mof su. + eapply strictly_updates_restrict_model_gen; tea; reflexivity. + Qed. + + Lemma strictly_updates_is_update_of_restrict cls W init m W' m' : + strictly_updates cls W init m -> + is_update_of (cls ⇂ W) W' (restrict_model W m) m' -> + strictly_updates cls (LevelSet.union W W') init (model_update m m'). + Proof. + move=> su /is_update_of_case; intros [[empw eq]|su']. + - rewrite <- eq. eapply (strictly_updates_weaken cls). clsets. + rewrite model_update_restrict. + eapply strictly_updates_W_eq; tea. lsets. + - eapply strictly_updates_restrict_model in su'. + eapply strictly_updates_weaken in su'. 2:eapply restrict_clauses_subset. + eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. + now apply strictly_updates_total_model in su. + Qed. + + Lemma union_with_concl cls W : Clauses.Equal (Clauses.union cls (cls ↓ W)) cls. + Proof. + intros x. rewrite Clauses.union_spec in_clauses_with_concl. firstorder. + Qed. + + Instance is_update_of_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) is_update_of. + Proof. + intros ?? H ?? H' ?? H'' ?? H'''. + unfold is_update_of. setoid_rewrite H'. destruct LevelSet.is_empty. + rewrite H'' H'''. reflexivity. + firstorder. now rewrite -H -H' -H'' -H'''. + subst. now rewrite H H' H'' H'''. + Qed. + + Lemma empty_union l : LevelSet.Equal (LevelSet.union LevelSet.empty l) l. + Proof. intros ?. lsets. Qed. + + Lemma is_update_of_strictly_updates cls W m m' : + strictly_updates cls W m m' -> + is_update_of cls W m m'. + Proof. + intros su. have ne := strictly_updates_non_empty su. + rewrite /is_update_of. now rewrite (proj2 (levelset_not_Empty_is_empty _) ne). + Qed. + + Lemma is_update_of_weaken {cls cls' W m m'} : + Clauses.Subset cls cls' -> + is_update_of cls W m m' -> is_update_of cls' W m m'. + Proof. + intros hsub. + move/is_update_of_case => []. + - intros []. subst. rewrite /is_update_of. + now rewrite (LevelSetFact.is_empty_1 H). + - intros su. have ne := strictly_updates_non_empty su. + unfold is_update_of. rewrite (proj2 (levelset_not_Empty_is_empty _) ne). + eapply strictly_updates_weaken; tea. + Qed. + + Lemma is_update_of_trans {cls cls' W W' m m' m''} : + is_update_of cls W m m' -> is_update_of cls' W' m' m'' -> + is_update_of (Clauses.union cls cls') (LevelSet.union W W') m m''. + Proof. + move/is_update_of_case => []. + - move=> [he eq]. intro. rewrite eq. rewrite (LevelSetProp.empty_is_empty_1 he) empty_union. + move: H. eapply is_update_of_weaken. clsets. + - intros su isu. + eapply strictly_updates_is_update_of in isu; tea. + have ne := strictly_updates_non_empty isu. + rewrite /is_update_of. now rewrite (proj2 (levelset_not_Empty_is_empty _) ne). + Qed. + + Lemma is_update_of_trans_eq {cls cls' W W' cltr Wtr m m' m''} : + is_update_of cls W m m' -> is_update_of cls' W' m' m'' -> + Clauses.Subset (Clauses.union cls cls') cltr -> + LevelSet.Equal Wtr (LevelSet.union W W') -> + is_update_of cltr Wtr m m''. + Proof. + intros hi hi' hcl hw. rewrite hw. + eapply is_update_of_weaken; tea. + eapply is_update_of_trans; tea. + Qed. + + Lemma union_idem cls : Clauses.Equal (Clauses.union cls cls) cls. + Proof. intros ?; rewrite Clauses.union_spec. firstorder. Qed. + + Lemma above_max_premise_model_trans {cls V' m m'} : + above_max_premise_model cls m -> + strictly_updates cls V' m m' -> + above_max_premise_model cls m'. + Proof. + move=> [[V'' ab]|eq] su. + * have tr := strictly_updates_trans ab su. + rewrite union_idem in tr. + now left; eexists. + * left; exists V'. now subst. + Qed. + + Lemma max_clause_premise_spec2 cls : + (exists cl, Clauses.In cl cls /\ max_clause_premise cls = Z.max (premise_max (premise cl)) 0) \/ + (Clauses.Empty cls /\ max_clause_premise cls = 0). + Proof. + unfold max_clause_premise. + eapply ClausesProp.fold_rec. + - firstorder. + - intros x a s' s'' incls ins' hadd [ih|ih]. + left. + * destruct ih as [cl [incl ->]]. + destruct (Z.max_spec (premise_max (premise x)) (Z.max (premise_max (premise cl)) 0)) as [[hlt ->]|[hge ->]]. + { exists cl. split => //. apply hadd. now right. } + { exists x. firstorder. lia. } + * destruct ih. left. exists x. split; firstorder. subst. + lia. + Qed. + + Lemma max_clause_premise_mon {cls cls'} : + cls ⊂_clset cls' -> + (max_clause_premise cls <= max_clause_premise cls'). + Proof using Type. + intros hincl. + have [[cl [hin hs]]|[he hs]] := max_clause_premise_spec2 cls; + have [[cl' [hin' hs']]|[he' hs']] := max_clause_premise_spec2 cls'. + - apply hincl in hin. + have hm := max_clause_premise_spec _ _ hin. + have hm' := max_clause_premise_spec _ _ hin'. lia. + - rewrite hs'. apply hincl in hin. now eapply he' in hin. + - rewrite hs. lia. + - lia. + Qed. + + + Lemma update_total_model W m m' : + model_of W m -> + model_of W (model_update m m'). + Proof. + intros mof k inW. + apply mof in inW as [v inW]. + destruct (LevelMapFact.F.In_dec m' k). + - destruct i as [v' inm']. exists v'. + rewrite model_update_spec. right; firstorder. + - exists v. rewrite model_update_spec. left. split => //. + Qed. + + Lemma model_map_outside_update W m m' : + only_model_of W m' -> + model_map_outside W m (model_update m m'). + Proof. + intros om l nin k. + rewrite model_update_spec. + firstorder. + Qed. + + Lemma valid_model_only_model W W' m cls : + forall vm : valid_model W W' m cls, + only_model_of W m -> only_model_of W (model_model vm). + Proof. + intros vm. + have incl := model_incl vm. + destruct vm as [m' mof isupd clsincl ism]. cbn. + move: isupd; rewrite /is_update_of. + destruct LevelSet.is_empty eqn:heq. now intros ->. + intros su om. + eapply strictly_updates_only_model_gen in su; tea. + eapply only_model_of_eq; tea. intro. lsets. + Qed. + + Lemma valid_model_is_update_of W W' m cls : + model_of W m -> + forall vm : valid_model W W' (restrict_model W m) (cls ⇂ W), + is_update_of (cls ⇂ W) W' m (model_update m (model_model vm)). + Proof. + intros mofW vm. + have incl := model_incl vm. + destruct vm as [m' mof isupd clsincl ism]. cbn. + move: isupd. rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros <-. now rewrite model_update_restrict. + - intros su. eapply strictly_updates_restrict_model in su; tea. + Qed. + + Infix "=_clset" := Clauses.Equal (at level 90). + + Lemma valid_model_is_update_of_eq W W' m cls cls' : + model_of W m -> + forall vm : valid_model W W' (restrict_model W m) cls, + cls =_clset (cls' ⇂ W) -> + is_update_of cls W' m (model_update m (model_model vm)). + Proof. + intros mofW vm. + have incl := model_incl vm. + destruct vm as [m' mof isupd clsincl ism]. cbn. + move: isupd. rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros <-. now rewrite model_update_restrict. + - intros su eq. rewrite eq in su. eapply strictly_updates_restrict_model in su; tea. + now rewrite eq. + Qed. + + Lemma valid_clause_preserved {m m' cl} : + (forall x, LevelSet.In x (clause_levels cl) -> level_value m x = level_value m' x) -> + valid_clause m cl -> + valid_clause m' cl. + Proof. + intros hcl. destruct cl as [prems [concl k]]. + rewrite /valid_clause //=. + rewrite (@min_premise_preserved m m' prems). + { intros x inp. apply hcl. rewrite clause_levels_spec. now left. } + destruct (min_premise m' prems) => //. + rewrite /level_value_above. rewrite hcl //. + rewrite clause_levels_spec. now right. + Qed. + + Lemma is_model_update W m m' cls : + model_of W m -> + only_model_of W m' -> + is_model (cls ⇂ W) m' -> + is_model (cls ⇂ W) (model_update m m'). + Proof. + intros mW om. + rewrite /is_model. + move/Clauses.for_all_spec. intros h. + apply Clauses.for_all_spec. tc. + intros cl hin. + specialize (h cl hin). cbn in h. + eapply valid_clause_preserved; tea. + move=>x; move: hin. rewrite in_restrict_clauses. + intros [incl inprems incls]. + rewrite clause_levels_spec. move=> [] hin. + - apply inprems in hin. + rewrite /level_value. + apply levelmap_find_eq => k. + rewrite model_update_spec. clear -mW om hin. firstorder. + - subst x. apply levelmap_find_eq => k. + rewrite model_update_spec. cbn in *. firstorder. cbn in H. + apply om in incl as [x hm]. now apply H in hm. + Qed. + + Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) + (loop : forall (V' U' : LevelSet.t) (cls' : clauses) (minit m : model) + (prf : [/\ clauses_levels cls' ⊂_lset V', only_model_of V' minit & + is_update_of cls' U' minit m]), + lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls' minit). + + Section innerloop_partition. + Context (W : LevelSet.t) (cls : clauses). + Context (premconclW conclW : clauses). + Context (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W, + Clauses.Equal premconclW (cls ⇂ W) & Clauses.Equal conclW (Clauses.diff (cls ↓ W) (cls ⇂ W))]). + + #[tactic="idtac"] + Equations? inner_loop_partition (m : model) (upd : strictly_updates cls W init_model m) : + result W LevelSet.empty cls m + by wf (measure W cls m) lt := + inner_loop_partition m upd with loop W LevelSet.empty premconclW (restrict_model W m) (restrict_model W m) _ _ := { + (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) + | Loop u isl => Loop u (loop_on_subset _ isl) + (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). + By invariant Wr ⊂ W *) + | Model Wr mr empWr with inspect (check_model conclW (Wr, model_update m (model_model mr))) := { + | exist None eqm => Model Wr {| model_model := model_update m (model_model mr) |} _ + | exist (Some (Wconcl, mconcl)) eqm with inner_loop_partition mconcl _ := { + (* Here Wr ⊂ Wconcl by invariant *) + | Loop u isl => Loop u isl + | Model Wr' mr' UWconcl => Model (LevelSet.union Wconcl Wr') {| model_model := model_model mr' |} _ } + (* Here Wr' ⊂ W by invariant *) + (* We check if the new model [mr] for (cls ⇂ W) extends to a model of (cls ↓ W). *) + (* We're entitled to recursively compute a better model starting with mconcl, + as we have made the measure decrease: + some atom in W has been strictly updated in Wconcl. *) + } }. + Proof. + all:try solve [try apply LevelSet.subset_spec; try reflexivity]. + all:cbn [model_model]; clear loop inner_loop_partition. + all:try apply LevelSet.subset_spec in hsub. + all:auto. + all:try destruct prf as [WV neW UW clsW eqprem eqconcl]. + all:try solve [intuition auto]. + all:try rewrite eqconcl in eqm. + - split => //. + * rewrite eqprem. apply clauses_levels_restrict_clauses. + * now eapply strictly_updates_restrict_only_model. + (* * eapply (strictly_updates_total_model upd). *) + (* * rewrite eqprem. transitivity cls => //. apply restrict_clauses_subset. *) + (* * eapply strictly_updates_weaken in upd; tea. eapply above_max_premise_model_trans in maxp; tea. *) + * eapply is_update_of_empty. + - left. now eapply strict_subset_cardinal. + - rewrite eqprem. eapply restrict_clauses_subset. + (* - destruct prf. transitivity (cls ⇂ W) => //. now rewrite H3. eapply restrict_clauses_subset. *) + - have mu := model_updates mr. + setoid_rewrite eqprem at 1 in mu. + eapply strictly_updates_is_update_of_restrict in upd; tea. + apply check_model_spec in eqm as [Wconcl' [sumr ->]]. + have tr := strictly_updates_trans upd sumr. + eapply strictly_updates_clauses_W; tea. + { intros ?. now rewrite ClausesProp.union_sym union_diff_cls. } + { have incl := model_incl mr. apply strictly_updates_incl in sumr. + have hdiff := clauses_conclusions_diff_left cls W (cls ⇂ W). lsets. } + - have tmr : model_of W (model_model mr). + { eapply valid_model_total. eapply strictly_updates_restrict_only_model in upd. + intro. apply upd. } + have tmr' : model_of W (model_update m (model_model mr)). + { eapply update_total_model; tea. now apply strictly_updates_total_model in upd. } + eapply (check_model_spec_diff tmr') in eqm as [subwwconcl subwconcl hm hext] => //. + pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). + destruct hm as [cll [hind nvalid inwconcl hl]]. + eapply Nat.lt_le_trans with (measure W cls (model_update m (model_model mr))). + 2:{ eapply measure_le; eauto; try eapply mr; tea. + - now eapply strictly_updates_total_model in upd. + - apply model_map_outside_update. eapply valid_model_only_model. + now eapply strictly_updates_restrict_only_model. + - eapply is_update_of_ext. + have mof := strictly_updates_model_of upd. + apply: valid_model_is_update_of_eq _ _ _ _ cls mof mr eqprem. } + eapply measure_lt; tea. + { eapply model_map_outside_weaken. eapply hext. have incl := model_incl mr. lsets. } + { apply hext. } + eapply invalid_clause_measure in nvalid; tea. + exists (levelexpr_level (concl cll)). + split => //. + eapply clauses_conclusions_diff_left; tea. + eapply clauses_conclusions_spec. exists cll; split => //. exact hind. + have incl := model_incl mr. eapply model_of_subset; tea. + - apply mr'. + - have updm : is_update_of premconclW Wr m (model_update m (model_model mr)). + { exact: valid_model_is_update_of_eq _ _ _ _ cls (strictly_updates_model_of upd) mr eqprem. } + eapply check_model_is_update_of in eqm as [eqm incl]. 2:eapply updm. + eapply strictly_updates_is_update_of in eqm. 2:eapply mr'. + eapply is_update_of_strictly_updates in eqm. + eapply is_update_of_weaken; tea. + now rewrite eqprem (ClausesProp.union_sym (cls ⇂ W)) union_diff ClausesProp.union_sym union_with_concl. + - apply mr'. + - lsets. + - have updm : is_update_of premconclW Wr m (model_update m (model_model mr)). + { exact: valid_model_is_update_of_eq _ _ _ _ cls (strictly_updates_model_of upd) mr eqprem. } + eapply update_total_model. now apply strictly_updates_model_of in upd. + - have updm : is_update_of premconclW Wr m (model_update m (model_model mr)). + { exact: valid_model_is_update_of_eq _ _ _ _ cls (strictly_updates_model_of upd) mr eqprem. } + eapply is_update_of_weaken. 2:apply updm. rewrite eqprem. apply restrict_clauses_subset. + - rewrite check_model_is_model in eqm. + have okm := (model_ok mr). + have okupdm : is_model premconclW (model_update m (model_model mr)). + { setoid_rewrite eqprem at 1. apply is_model_update. apply strictly_updates_model_of in upd; tea. + eapply valid_model_only_model. now eapply strictly_updates_restrict_only_model. + now setoid_rewrite <- eqprem at 1. } + have mu := is_model_union okupdm eqm. + rewrite {1}eqprem in mu. + rewrite union_diff_eq in mu. + rewrite union_restrict_with_concl in mu. + now rewrite (clauses_conclusions_eq _ _ clsW). + Qed. + End innerloop_partition. + + (* We first partition the clauses among those that mention only W and the ones that can mention other atoms. + We then call the loop on these two sets of clauses, which not need to change during the recursive calls. + *) + #[tactic="idtac"] + Equations? inner_loop (W : LevelSet.t) (cls : clauses) (m : model) + (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & + strictly_updates cls W init_model m]) : result W LevelSet.empty cls m := + inner_loop W cls m prf with inspect (Clauses.partition (premise_restricted_to W) cls) := + | exist (premconclW, conclW) eqp => inner_loop_partition W cls premconclW conclW _ m _. + Proof. + - destruct prf as [subWV neW UW clsW mW]. + eapply (clauses_partition_spec clsW) in eqp as [eqprem eqconcl]. + split => //. now rewrite -(clauses_conclusions_eq _ _ clsW). + - apply prf. + Qed. + +End InnerLoop. + +Local Open Scope nat_scope. +Lemma diff_cardinal_inter V W : #|LevelSet.diff V W| = #|V| - #|LevelSet.inter V W|. +Proof. + pose proof (LevelSetProp.diff_inter_cardinal V W). lia. +Qed. + +Lemma diff_cardinal V W : W ⊂_lset V -> #|LevelSet.diff V W| = #|V| - #|W|. +Proof. + intros hsub. + rewrite diff_cardinal_inter LevelSetProp.inter_sym LevelSetProp.inter_subset_equal //. +Qed. + +Lemma is_modelP m cls : reflect (Clauses.For_all (valid_clause m) cls) (is_model cls m). +Proof. + case E: is_model; constructor. + - now move: E; rewrite /is_model -ClausesFact.for_all_iff. + - intros hf. apply ClausesFact.for_all_iff in hf; tc. unfold is_model in E; congruence. +Qed. + +Lemma is_model_invalid_clause cl cls m : is_model cls m -> ~~ valid_clause m cl -> ~ Clauses.In cl cls. +Proof. + move/is_modelP => ism /negP valid hin. + now specialize (ism _ hin). +Qed. + +Lemma strict_subset_leq_right U V W : + strict_subset U V -> V ⊂_lset W -> strict_subset U W. +Proof. + intros [] le. split. lsets. intros eq. rewrite -eq in le. + apply H0. lsets. +Qed. + +Lemma strict_subset_leq_left U V W : + U ⊂_lset V -> strict_subset V W -> strict_subset U W. +Proof. + intros le []. split. lsets. intros eq. rewrite eq in le. + apply H0. lsets. +Qed. + +(* Lemma strict_subset_union_right U U' V W : + strict_subset V W -> U ⊂_lset U' -> + strict_subset (LevelSet.union U V) (LevelSet.union U' W). +Proof. + rewrite /strict_subset. + intros [] hu. split. lsets. intros he. + apply H0. + intros x. split. apply H. + specialize (he x). intros inW. + rewrite !LevelSet.union_spec in he. + destruct he as [he he']. + forward he'. now right. destruct he' => //. + forward he. apply he in + red in he. *) + +Lemma strict_subset_diff_incl V W W' : + strict_subset W' W -> + W ⊂_lset V -> + W' ⊂_lset V -> + strict_subset (LevelSet.diff V W) (LevelSet.diff V W'). +Proof. + intros [] lew lew'. + split. lsets. + intros eq. + apply H0. lsets. +Qed. + +(* To help equations *) +Opaque lexprod_rel_wf. + +Lemma check_model_spec_V {V cls w m w' m'} : + model_of V m -> clauses_conclusions cls ⊂_lset V -> + model_of w m -> + check_model cls (w, m) = Some (w', m') -> + check_model_invariants cls w m w' m' true. +Proof. + cbn; intros mof incl tot cm. + apply check_model_has_invariants in cm => //. + eapply model_of_subset. exact mof. tea. +Qed. + +Section Semantics. + + Section Interpretation. + Context (V : LevelMap.t nat). + + Definition interp_level l := + match LevelMap.find l V with + | Some x => x + | None => 0%nat + end. + + Definition interp_expr '(l, k) := (Z.of_nat (interp_level l) + k)%Z. + Definition interp_prems prems := + let '(hd, tl) := to_nonempty_list prems in + fold_right (fun lk acc => Z.max (interp_expr lk) acc) (interp_expr hd) tl. + + Definition clause_sem (cl : clause) : Prop := + let '(prems, concl) := cl in + (interp_prems prems >= interp_expr concl)%Z. + + Definition clauses_sem (cls : clauses) : Prop := + Clauses.For_all clause_sem cls. + End Interpretation. + + (* There exists a valuation making all clauses true in the natural numbers *) + Definition satisfiable (cls : clauses) := + exists V, clauses_sem V cls. + + (* Any valuation making all clauses valid in the natural numbers also satisfies the clause cl *) + Definition entails_sem (cls : clauses) (cl : clause) := + forall V, clauses_sem V cls -> clause_sem V cl. +End Semantics. + + +Local Open Scope Z_scope. + +Lemma max_min max min k : min <= 0 -> max >= 0 -> k <= max -> k >= min -> (max - k - min) >= 0. +Proof. lia. Qed. + +Definition model_min m := + LevelMap.fold (fun l k acc => Z.min acc k) m 0. + +Lemma model_min_spec m : forall l k, LevelMap.MapsTo l k m -> (model_min m <= k)%Z. +Proof. + intros l k hm. + rewrite /model_min. + move: hm; eapply LevelMapFact.fold_rec. + - move=> m0 he hm. now apply he in hm. + - intros k' e a m' m'' hm nin hadd hle hm''. + specialize (hadd l). + eapply levelmap_find_eq_inv in hadd. eapply hadd in hm''. + rewrite LevelMapFact.F.add_mapsto_iff in hm''. + move: hm''=> [] [h h']. + * subst k. lia. + * move/hle: h'. lia. +Qed. + + +Lemma model_min_spec2 m : (model_min m <= 0)%Z. +Proof. + rewrite /model_min. + eapply LevelMapFact.fold_rec. + - intros; reflexivity. + - intros k' e a m' m'' hm nin hadd hle. lia. +Qed. + +Definition model_max m := + LevelMap.fold (fun l k acc => Z.max acc k) m 0. + +Lemma model_max_spec m : forall l k, LevelMap.MapsTo l k m -> (k <= model_max m)%Z. +Proof. + intros l k hm. + rewrite /model_max. + move: hm; eapply LevelMapFact.fold_rec. + - move=> m0 he hm. now apply he in hm. + - intros k' e a m' m'' hm nin hadd hle hm''. + specialize (hadd l). + eapply levelmap_find_eq_inv in hadd. eapply hadd in hm''. + rewrite LevelMapFact.F.add_mapsto_iff in hm''. + move: hm''=> [] [h h']. + * subst k. lia. + * move/hle: h'. lia. +Qed. + +Lemma model_max_spec2 m : (0 <= model_max m)%Z. +Proof. + rewrite /model_max. + eapply LevelMapFact.fold_rec. + - intros; reflexivity. + - intros k' e a m' m'' hm nin hadd hle. lia. +Qed. + +Definition valuation_of_model (m : model) : LevelMap.t nat := + let max := model_max m in + let min := model_min m in + LevelMap.fold (fun l k acc => LevelMap.add l (Z.to_nat (max - k - min)) acc) m (LevelMap.empty _). + +Lemma valuation_of_model_spec m : + forall l k, LevelMap.MapsTo l k m -> + let v := (model_max m - k - model_min m)%Z in + LevelMap.MapsTo l (Z.to_nat v) (valuation_of_model m). +Proof. + intros l k hm v. + unfold valuation_of_model. subst v. + move: hm. generalize (model_max m) (model_min m) => n n'. + eapply LevelMapFact.fold_rec. + - intros v he hm. + now eapply he in hm. + - intros. + specialize (H1 l). eapply levelmap_find_eq_inv in H1. eapply H1 in hm. + rewrite LevelMapFact.F.add_mapsto_iff in hm. destruct hm as [[-> ->]|[neq hm]]. + * eapply LevelMapFact.F.add_mapsto_iff. left. split => //. + * eapply LevelMapFact.F.add_mapsto_iff. right. split => //. now apply H2. +Qed. + +Lemma strictly_updates_valid_model {W W' m m' cls} : + is_model (cls ↓ W) m -> + strictly_updates cls W' m m' -> + exists l, LevelSet.In l W' /\ ~ LevelSet.In l W. +Proof. + intros vm. induction 1. + - exists (clause_conclusion cl). split => //. lsets. intros hin. + eapply strict_update_invalid in H0. + eapply is_model_invalid_clause in vm; tea. apply vm. + eapply in_clauses_with_concl. split => //. + - destruct (IHstrictly_updates1 vm). exists x. + rewrite LevelSet.union_spec. firstorder. +Qed. + +Lemma model_of_strictly_updates cls W V m m' : + strictly_updates cls W m m' -> model_of V m -> model_of V m'. +Proof. + intros su. + induction su. + - intros mv l hin. apply mv in hin. + destruct cl as [prems [concl k]]. + destruct H0 as [minv [eqmin nabove eqm]]. rewrite eqm. + rewrite LevelMapFact.F.add_in_iff. now right. + - eauto. +Qed. + +Lemma check_model_ne {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> ~ LevelSet.Empty W. +Proof. + move/check_model_spec => [w'' [su ->]]. + apply strictly_updates_non_empty in su. + intros he. apply su. lsets. +Qed. + +Lemma check_model_update_of {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> + exists W', is_update_of cls W' m m' /\ W = LevelSet.union U W'. +Proof. + move/check_model_spec => [w'' [su ->]]. exists w''. split => //. + now eapply is_update_of_strictly_updates. +Qed. + +Lemma opt_le_lt_trans {x y z} : opt_le Z.le x y -> opt_le Z.lt y z -> opt_le Z.lt x z. +Proof. + destruct 1; intros H'; depelim H'; constructor. lia. +Qed. + +Lemma strictly_updates_all cls V minit m : strictly_updates cls V minit m -> + (forall l k, LevelSet.In l V -> LevelMap.MapsTo l k minit -> exists k', LevelMap.MapsTo l k' m /\ Z.lt k k'). +Proof. + induction 1. + - intros l k hin hm. + move: H0; rewrite /strict_update. + destruct cl as [prems [concl gain]]. + move=> [] v [] minp hlt. cbn in hin. eapply LevelSet.singleton_spec in hin. red in hin; subst l. + move/negbTE: hlt; rewrite /level_value_above. + intros hle eq. setoid_rewrite eq. + eexists. setoid_rewrite LevelMapFact.F.add_mapsto_iff. split; [left;split;eauto|] => //. + destruct level_value eqn:hl => //. + * rewrite (level_value_MapsTo hm) in hl. noconf hl. lia. + * rewrite (level_value_MapsTo hm) in hl. noconf hl. + - intros l k; rewrite LevelSet.union_spec; move=> [] hin hm. + apply IHstrictly_updates1 in hm as [k' [hle hm']]; tea. + eapply strictly_updates_ext in H0. apply H0 in hle as [k'' [hm'' lek'']]. + exists k''. split => //. lia. + eapply strictly_updates_ext in H. eapply H in hm as [k' [hm' lek']]. + eapply IHstrictly_updates2 in hm' as [k'' [hm'' lek'']]; tea. + exists k''. split => //. lia. +Qed. + +Lemma strictly_updates_zero_model cls V mzero m : + (forall l, LevelSet.In l V -> LevelMap.MapsTo l 0%Z mzero) -> + strictly_updates cls V mzero m -> + forall l, LevelSet.In l V -> exists k, LevelMap.MapsTo l k m /\ (0 < k)%Z. +Proof. + intros ho. + move/strictly_updates_all => ha l hin. + eapply ha in hin; revgoals. now apply ho. + destruct hin as [k' [hm hle]]. + now exists k'. +Qed. + +Lemma of_level_set_union_spec {ls ls' n hne} hne' hne'' : + of_level_set (ls ∪ ls') n hne = + univ_union (of_level_set ls n hne') (of_level_set ls' n hne''). +Proof. + apply eq_univ_equal. + intros [l k]. rewrite /of_level_set //= !levelexprset_of_levels_spec LevelExprSet.union_spec. + rewrite !levelexprset_of_levels_spec LevelSet.union_spec. clear. firstorder. +Qed. + +Lemma in_singleton l : LevelSet.In l (LevelSet.singleton l). +Proof. lsets. Qed. + +Definition app {A B} (f : A -> B) (x : A) := f x. + +Notation "f $ x" := (app f x) (at level 20). + +Definition model_domain (m : model) V := + forall x, LevelSet.In x V <-> LevelMap.In x m. + +Definition model_rel_partial R V (m m' : model) := + forall l, + (LevelSet.In l V -> forall k, LevelMap.MapsTo l k m -> + exists k', LevelMap.MapsTo l k' m' /\ R k k') /\ + (~ LevelSet.In l V -> forall k, LevelMap.MapsTo l k m <-> LevelMap.MapsTo l k m'). + +Lemma model_of_sext {R W W' m m'} : + model_of W m -> + model_of W' m -> + model_rel_partial R W m m' -> model_of W' m'. +Proof. + intros mof mof' ext. + intros l hin. + destruct (mof' l hin). specialize (ext l) as [lin lout]. + destruct (inLevelSet W l) as [hin'|hout]. + - specialize (lin hin' _ H). firstorder. + - specialize (lout hout x). + exists x. now apply lout. +Qed. + +Lemma not_in_union_inv l ls ls' : + ~ LevelSet.In l (LevelSet.union ls ls') -> + ~ LevelSet.In l ls /\ ~ LevelSet.In l ls'. +Proof. + rewrite LevelSet.union_spec. firstorder. +Qed. + +Lemma model_rel_partial_trans {R W W' m m' m''} (HR : Transitive R) : + model_rel_partial R W m m' -> + model_rel_partial R W' m' m'' -> + model_rel_partial R (LevelSet.union W W') m m''. +Proof. + intros mr mr' l. + specialize (mr l) as [inWmr outWmr]. + specialize (mr' l) as [inWmr' outWmr']. + split. + { rewrite LevelSet.union_spec. move=> [] hin k hm. + - specialize (inWmr hin k hm) as [k' [hk' rk']]. + destruct (inLevelSet W' l). + + specialize (inWmr' H k' hk') as [k'' [hk'' rk'']]. + exists k''. split => //. now transitivity k'. + + specialize (outWmr' H k'). exists k'. split => //. now apply outWmr'. + - destruct (inLevelSet W l). + + specialize (inWmr H k hm) as [k'' [hk'' rk'']]. + specialize (inWmr' hin k'' hk'') as [km' [hkm' rkm']]. + exists km'. split => //. now transitivity k''. + + specialize (outWmr H k) as eq. + apply eq in hm. + specialize (inWmr' hin k hm) as [m''k [hm'' rm'']]. + exists m''k. split => //. } + { move/not_in_union_inv => [] ninW ninW' k. + rewrite (outWmr ninW k). + rewrite (outWmr' ninW' k). reflexivity. } +Qed. + +Lemma strictly_updates_model_lt {cls V} {m m'} : + strictly_updates cls V m m' -> + model_of V m -> + model_rel_partial Z.lt V m m'. +Proof. + intros su; induction su. + - intros htot l. split; revgoals. + { intros nin k. destruct cl as [prems [concl conclk]]; cbn in *. + destruct H0 as [minp [hmin nabove hm']]. + rewrite hm'. rewrite LevelMapFact.F.add_mapsto_iff. + assert (concl <> l). intros ->. + apply nin, in_singleton. + firstorder. } + intros inv k hin. + red in htot. + specialize (htot (clause_conclusion cl) (in_singleton _)) as [mconcl mt]. + destruct cl as [prems [concl conclk]]; cbn in *. + destruct H0 as [minp [hmin nabove hm']]. + eapply LevelSet.singleton_spec in inv; red in inv; subst l. + eapply LevelMapFact.F.MapsTo_fun in hin; tea. noconf hin. + exists (conclk + minp). split => //. + rewrite hm'. + rewrite LevelMapFact.F.add_mapsto_iff. left. split => //. + move/negbTE: nabove; move/level_value_not_above_spec. + rewrite (level_value_MapsTo mt). now intros x; depelim x. + - move/model_of_union_inv => [] totls totls'. + forward IHsu1 by auto. + forward IHsu2. + { eapply model_of_sext. exact totls. assumption. eassumption. } + now eapply model_rel_partial_trans. +Qed. + +Lemma intro_sing {P : Level.t -> Prop} {cl} : + P cl -> (forall l, LevelSet.In l (LevelSet.singleton cl) -> P l). +Proof. + intros H l ins. rewrite LevelSet.singleton_spec in ins. now red in ins; subst. +Qed. + +Lemma elim_sing {P : Level.t -> Prop} {cl} : (forall l, LevelSet.In l (LevelSet.singleton cl) -> P l) -> P cl. +Proof. + intros H. apply H, in_singleton. +Qed. + +#[program] +Definition of_level_map (m : LevelMap.t Z) (hne : ~ LevelMap.Empty m) : nonEmptyLevelExprSet := + {| t_set := LevelMap.fold (fun l k acc => LevelExprSet.add (l, k) acc) m LevelExprSet.empty |}. +Next Obligation. apply not_Empty_is_empty. + move: hne. eapply LevelMapFact.fold_rec. firstorder. + intros. rewrite /LevelExprSet.Empty. + rw LevelExprSet.add_spec. intros ha. apply (ha (k, e)). now left. +Qed. + +Lemma of_level_map_spec m hne : + forall l k, LevelExprSet.In (l, k) (of_level_map m hne) <-> LevelMap.MapsTo l k m. +Proof. + intros l k; rewrite /of_level_map //=. + clear hne. + have : forall acc, + LevelExprSet.In (l, k) + (LevelMap.fold (fun (l0 : LevelMap.key) k0 (acc : LevelExprSet.t) => LevelExprSet.add (l0, k0) acc) m acc) <-> + LevelMap.MapsTo l k m \/ LevelExprSet.In (l, k) acc. + move=> acc; eapply LevelMapFact.fold_rec. + - firstorder. + - intros. rewrite LevelExprSet.add_spec H2. + split. + * intros [eq|hm]. + + noconf eq. specialize (H1 l). eapply levelmap_find_eq_inv in H1. + erewrite H1. left. apply LevelMapFact.F.add_mapsto_iff. left => //. + + specialize (H1 l). eapply levelmap_find_eq_inv in H1; erewrite H1. + rewrite LevelMapFact.F.add_mapsto_iff. + destruct (eq_dec l k0); subst; firstorder. + * intros hm'. destruct hm'. + + specialize (H1 l). eapply levelmap_find_eq_inv in H1. eapply H1 in H3. + apply LevelMapFact.F.add_mapsto_iff in H3. destruct H3. firstorder; subst. left. red. red in H3. subst. reflexivity. + unfold LevelExprSet.E.eq. destruct H3. now right; left. + + unfold LevelExprSet.E.eq. now right. + - intros. rewrite H. firstorder. lesets. +Qed. + +Definition premise_values (prems : univ) m := + NonEmptySetFacts.map (fun '(l, k) => (l, option_get 0 (level_value m l))) prems. + +Lemma premise_values_spec prems m : + forall l k, LevelExprSet.In (l, k) (premise_values prems m) <-> + (exists k', LevelExprSet.In (l, k') prems /\ k = option_get 0 (level_value m l)). +Proof. + rewrite /premise_values. + intros l k. rewrite NonEmptySetFacts.map_spec. + firstorder. destruct x. noconf H0. + exists z. split => //. exists(l, x); split => //. now rewrite -H0. +Qed. + +Definition hyps_map (hyps : univ) m := + (forall (l : Level.t) k, LevelExprSet.In (l, k) hyps <-> LevelMap.MapsTo l k m). + +Lemma model_hyps_entails cls m hyps (prems : univ) concl : + Clauses.In (prems, concl) cls -> + (forall l k, LevelExprSet.In (l,k) prems -> exists z, Some z ≤ level_value m l) -> + hyps_map hyps m -> + cls ⊢a hyps → premise_values prems m. +Proof. + intros incls hmx hm. + intros [l k] hin. + rewrite premise_values_spec in hin. destruct hin as [k' [inp ->]]. + red in hm. + constructor. rewrite hm. + specialize (hmx l _ inp). + depelim hmx. depelim H. rewrite H0 //=. + now eapply level_value_MapsTo'. +Qed. + +Lemma entails_succ cls (u v : univ) : + (forall l k, LevelExprSet.In (l, k) v -> exists k', LevelExprSet.In (l, k') u /\ k <= k') -> + cls ⊢a u → v. +Proof. + intros hk [l k] hin. + specialize (hk _ _ hin) as [k' [hin' le]]. + assert (exists n, k' = k + n) as [n ->] by (exists (k' - k); lia). + eapply (entails_pred_closure_n (n := Z.to_nat n)). + constructor. rewrite Z2Nat.id. lia. assumption. +Qed. + +Lemma hyps_entails (hyps : univ) m cls : + hyps_map hyps m -> + forall prems conclk, Clauses.In (prems, conclk) cls -> + forall v, min_premise m prems = Some v -> + cls ⊢a hyps → add_prems v prems. +Proof. + intros H prems conclk H0 v H1. + have [minsleq mineq] := min_premise_spec m prems. + destruct mineq as [[minprem minpremk] [inprems eqminp]]. cbn. + have hmz' : forall l k, LevelExprSet.In (l, k) prems -> exists z, Some z ≤ level_value m l. + { intros l k hin. specialize (minsleq _ hin). rewrite H1 in minsleq. cbn in minsleq. destruct level_value => //. + depelim minsleq. exists (v + k). constructor. lia. depelim minsleq. } + move: eqminp. rewrite /min_atom_value. + destruct level_value eqn:hl. intros hminp. + 2:{ now rewrite H1. } + rewrite H1 in hminp. noconf hminp. + have entails_prems : cls ⊢a hyps → premise_values prems m. + by eapply model_hyps_entails with conclk; auto. + eapply entails_all_trans; tea. + eapply entails_succ. + intros l k. rewrite In_add_prems. + intros [[prem premk] [inprem [= -> ->]]]. + rw premise_values_spec. eexists. + split. exists premk. split => //. + have hmz'' := hmz' prem _ inprem. + depelim hmz''. depelim H2. rewrite H3 //=. + specialize (minsleq _ inprem). cbn in minsleq. rewrite H3 in minsleq. + rewrite H1 in minsleq. depelim minsleq. lia. +Qed. + +Lemma strictly_updates_entails {cls V mzero m} (hne : ~ LevelMap.Empty mzero) (hne' : ~ LevelMap.Empty m) : + strictly_updates cls V mzero m -> + entails_all cls (of_level_map mzero hne) (of_level_map m hne'). +Proof. + intros su; induction su. + - destruct cl as [prems [concl k]]. + destruct H0 as [minp [hmin nabove eqm']]. + have [minsleq mineq] := min_premise_spec m prems. + destruct mineq as [minprem [inprems eqminp]]. cbn. + move: eqminp. rewrite /min_atom_value. + move/negbTE/level_value_not_above_spec: nabove => nabove. + destruct minprem as [minprem mink]. + destruct (level_value m minprem) eqn:hminprem; rewrite hmin //; intros [= ->]. + intros [l k'] hin. + eapply of_level_map_spec in hin. rewrite eqm' in hin. + rewrite LevelMapFact.F.add_mapsto_iff in hin. + destruct hin as [[eq heq]|[neq hm]]. subst k'. + have hypss := of_level_map_spec m hne. + set (hyps := of_level_map m hne) in *. clearbody hyps. + have entailscl : entails cls (prems, (concl, k)) by exact: entails_in H. + move/(entails_shift (z - mink)): entailscl. cbn. move => entailscl. + eapply (entails_all_one (concl := add_prems (z - mink) prems)) => //. + eapply level_value_MapsTo' in hminprem. + rewrite -hypss in hminprem. + eapply hyps_entails; tea. red in eq; subst. exact entailscl. + (* rewrite hmin. lia_f_equal. *) + (* have -> : k + (z - mink) = k + (z - mink) by lia. now red in eq; subst concl. *) + constructor. now rewrite of_level_map_spec. + - have hnemid : ~ LevelMap.Empty m'. by exact: strictly_updates_non_empty_map su1. + specialize (IHsu1 hne hnemid). + specialize (IHsu2 hnemid hne'). + eapply entails_all_trans; tea. +Qed. + +Lemma not_empty_exists V : ~ LevelSet.Empty V -> exists l, LevelSet.In l V. +Proof. + intros ne. + destruct (LevelSet.choose V) eqn:ch. exists e. + now eapply LevelSet.choose_spec1 in ch. + now apply LevelSet.choose_spec2 in ch. +Qed. + +Lemma of_level_map_of_level_set cls sel V m hne hne' : + max_premise_model cls sel m -> + V =_lset sel cls -> + of_level_map m hne = of_level_set V (max_clause_premise cls) hne'. +Proof. + move=> mp hv. apply: (proj1 (eq_univ_equal _ _)) => [[l k]]. + rewrite of_level_map_spec levelexprset_of_levels_spec. + split. red in mp. + move/(proj2 mp l) => [hin eq]. split. 2:lia. lsets. + move=> [] inl ->. rewrite hv in inl. + now apply mp. +Qed. + +Lemma infers_atom_of_level_map {cls m hne l k} : + infers_atom m l k -> + cls ⊢ of_level_map m hne → (l, k). +Proof. + rewrite /infers_atom. intros hle. depelim hle. + have [y' eq] : exists y', y = (k + y'). exists (y - k). lia. + eapply (entails_trans (concl := (l, k + y'))). + - constructor. rewrite of_level_map_spec. + eapply level_value_MapsTo'. rewrite H0. f_equal. lia. + - eapply (entails_pred_closure_n (n := Z.to_nat y')). + constructor. eapply LevelExprSet.singleton_spec. + rewrite Z2Nat.id. lia. reflexivity. +Qed. + +Lemma of_level_map_entails_of_level_set cls V m hne hne' : + above_max_premise_model cls m -> + V ⊂_lset clauses_levels cls -> + cls ⊢a of_level_map m hne → of_level_set V (max_clause_premise cls) hne'. +Proof. + move=> mp hv. + intros [l k]. + rewrite levelexprset_of_levels_spec. + intros [hin ->]. + have hi := above_max_premise_model_infers mp. + move: (hi l (hv _ hin)). + eapply infers_atom_of_level_map. +Qed. + +(* The criterion for loops: + when a set of updates manages to strictly update all the levels it started with, + then we can deduce a looping constraint `x, ..., z -> x + 1, ... z + 1`. + + TODO: refine the premises, this should work also when some clauses cannot be considered, + so that it can be used for checking and not only inferrence. + + *) + +Lemma strictly_updates_entails_loop cls V (hne : ~ LevelSet.Empty V) mzero m : + max_premise_model cls clauses_levels mzero -> + V =_lset clauses_levels cls -> + model_of V mzero -> + strictly_updates cls V mzero m -> + entails_all cls (of_level_set V (max_clause_premise cls) hne) + (of_level_set V (max_clause_premise cls + 1) hne). +Proof. + intros maxp vincl tot su. + have mp := strictly_updates_model_lt su tot. + have nemzero : ~ LevelMap.Empty mzero. + { have := not_empty_exists V hne => [[l]]. + now move/tot => [v hm] /(_ _ _ hm). } + have nem := strictly_updates_non_empty_map su. + eapply (strictly_updates_entails nemzero nem) in su; tea. + unshelve erewrite of_level_map_of_level_set in su; tea. + move/entails_all_trans: su; apply. + apply: entails_succ => l k. + rewrite levelexprset_of_levels_spec => [[hin ->]]. + rw of_level_map_spec. + move: (mp l) => [] /(_ hin). + move: (tot _ hin) => [x hm]. + move/(_ _ hm) => [k' [hm' lt]]. + intros _. + exists k'. + unfold max_premise_model in maxp. + move: (proj1 maxp l) => hl. + forward hl. apply vincl, hin. + eapply LevelMapFact.F.MapsTo_fun in hm; tea. noconf hm. + split => //. lia. +Qed. + +Lemma strictly_updates_entails_loop_above_max cls V (hne : ~ LevelSet.Empty V) mzero m : + above_max_premise_model cls mzero -> + V =_lset clauses_levels cls -> + model_of V mzero -> + strictly_updates cls V mzero m -> + entails_all cls (of_level_set V (max_clause_premise cls) hne) + (of_level_set V (max_clause_premise cls + 1) hne). +Proof. + move=> habove hv tot su. + destruct habove as [[V' ha]|eq]. + * apply (strictly_updates_entails_loop cls V hne (max_premise_map cls) m); tea. + - apply max_premise_model_exists. + - have [hs hs'] := max_premise_model_exists cls. red. + intros k hm. rewrite hv in hm. specialize (hs _ hm). now eexists. + - have tr := strictly_updates_trans ha su. rewrite union_idem in tr. + eapply strictly_updates_incl in ha. + assert (V' ∪ V = V). + { apply LevelSet.eq_leibniz. red. + rewrite hv. move: (clauses_conclusions_levels cls). lsets. } + now rewrite H in tr. + * subst mzero. + eapply strictly_updates_entails_loop; tea. + apply max_premise_model_exists. +Qed. + +Lemma entails_any_one V cls m nem m' nem' : + model_of V m -> + cls ⊢a of_level_map m nem → of_level_map m' nem' -> + model_rel_partial Z.lt V m m' -> + forall l k, LevelSet.In l V -> + LevelMap.MapsTo l k m -> cls ⊢ of_level_map m nem → (l, k + 1). +Proof. + intros tot cla mp l k hin hm. + eapply entails_all_one; tea. + move: (proj1 (mp l) hin). + move: (tot _ hin) => [x hm']. + move/(_ _ hm) => [k'' [hm'' lt]]. + apply infers_atom_of_level_map. red. rewrite (level_value_MapsTo hm''). constructor. lia. +Qed. + + +Lemma only_model_of_model_of {V m} : only_model_of V m -> model_of V m. +Proof. + intros om l. move/om. intros [k hm]; now exists k. +Qed. + +Coercion only_model_of_model_of : only_model_of >-> model_of. + +Lemma entails_any V cls m nem m' nem' : + only_model_of V m -> + cls ⊢a of_level_map m nem → of_level_map m' nem' -> + model_rel_partial Z.lt V m m' -> + cls ⊢a of_level_map m nem → succ_prems (of_level_map m nem). +Proof. + intros tot cla mp [l k]. + rewrite In_add_prems => [] [[l' k']] [] /of_level_map_spec hm [=] -> ->. + eapply entails_any_one; tea. exact tot. apply tot. now exists k'. +Qed. + +Lemma strictly_updates_entails_on_V cls V mzero hne m : + only_model_of V mzero -> + strictly_updates cls V mzero m -> + entails_all (cls ↓ V) (of_level_map mzero hne) (succ_prems (of_level_map mzero hne)). +Proof. + move=> tot su. + have mp := strictly_updates_model_lt su tot. + have nem := strictly_updates_non_empty_map su. + eapply strictly_updates_strenghten in su. + eapply (strictly_updates_entails hne nem) in su; tea. + eapply entails_any in su; tea. +Qed. + +Lemma add_prems_add {n lk prems} : add_prems n (add lk prems) = add (add_expr n lk) (add_prems n prems). +Proof. + apply eq_univ_equal. intros x. + rewrite In_add_prems LevelExprSet.add_spec In_add_prems /LevelExprSet.E.eq; rw LevelExprSet.add_spec. + firstorder. subst. red in H; subst x0. now left. +Qed. + +Lemma add_prems_of_level_set k W k' prf : + add_prems k (of_level_set W k' prf) = of_level_set W (k + k') prf. +Proof. + apply eq_univ_equal => [] [l n]. + rewrite In_add_prems /of_level_set //= levelexprset_of_levels_spec. + split. + - move=> [] [l' n']. rewrite levelexprset_of_levels_spec => [] [[inw eq] eq']. + subst n'. noconf eq'. split => //. lia. + - move=> [inW ->]. exists (l, k'). rewrite levelexprset_of_levels_spec. + split => //. cbn. f_equal; lia. +Qed. + +Lemma of_level_set_singleton l k hne : of_level_set (LevelSet.singleton l) k hne = singleton (l, k). +Proof. + apply eq_univ_equal. move=> [l' k']. + rewrite /of_level_set //= levelexprset_of_levels_spec !LevelExprSet.singleton_spec LevelSet.singleton_spec /LevelSet.E.eq /LevelExprSet.E.eq. + firstorder subst => //. now noconf H. now noconf H. +Qed. + +Lemma entails_of_level_set_strenghten cls W k' k prf : + k' <= k -> + cls ⊢a of_level_set W k' prf → of_level_set W (k' + 1) prf -> + cls ⊢a of_level_set W k prf → of_level_set W (k + 1) prf. +Proof. + intros le ea. + have := entails_all_shift (k - k') ea. + rewrite !add_prems_of_level_set. + have -> : k - k' + k' = k by lia. + now have -> : k - k' + (k' + 1) = k + 1 by lia. +Qed. + +Lemma strictly_updates_non_empty_init_map {cls W m m'} : + strictly_updates cls W m m' -> ~ LevelMap.Empty m. +Proof. + induction 1. + - destruct cl as [prems [concl k]]. + destruct H0 as [? [? ? heq]]. + eapply min_premise_spec_aux in H0 as [_ [[] [inprems heq']]]. + unfold min_atom_value in heq'. + destruct level_value eqn:hl => //. apply level_value_MapsTo' in hl. + now intros e; apply e in hl. + - auto. +Qed. + +Lemma check_model_ne_init_map {cls V U minit m W m'} : + [/\ clauses_levels cls ⊂_lset V, only_model_of V minit & is_update_of cls U minit m] -> + check_model cls (U, m) = Some (W, m') -> + ~ LevelMap.Empty minit. +Proof. + intros [_ _ isupd] check. + eapply check_model_is_update_of in check as [su incl]; tea. + rewrite union_idem in su. + now eapply strictly_updates_non_empty_init_map in su. +Qed. + +Lemma check_model_ne_map {cls U m W m'} : + check_model cls (U, m) = Some (W, m') -> + ~ LevelMap.Empty m'. +Proof. + intros check. + eapply check_model_spec in check as [W' [su incl]]; tea. + now eapply strictly_updates_non_empty_map in su. +Qed. + +#[tactic="idtac"] +Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) + (prf : [/\ clauses_levels cls ⊂_lset V, only_model_of V minit & is_update_of cls U minit m]) : result V U cls minit + by wf (loop_measure V U) lexprod_rel := + loop V U cls minit m prf with inspect (check_model cls (U, m)) := + | exist None eqm => Model U {| model_model := m |} _ + | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { + | exist true eq := Loop (of_level_map minit (check_model_ne_init_map prf eqm)) _ + (* Loop on cls ↓ W, with |W| < |V| *) + | exist false neq with inner_loop V U minit loop W (cls ↓ W) m' _ := + { | Loop u isloop := Loop u (loop_on_subset _ isloop) + | Model Wc mwc _ + (* We get a model for (cls ↓ W), we check if it extends to all clauses. + By invariant |Wc| cannot be larger than |W|. *) + with inspect (check_model cls (Wc, mwc.(model_model))) := + { | exist None eqm' => Model (LevelSet.union W Wc) {| model_model := mwc.(model_model) |} _ + | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { + | exist true _ := Loop (of_level_map m' (check_model_ne_map eqm)) _ + | exist false neq' with loop V (LevelSet.union W Wcls) cls minit mcls _ := { + (* Here Wcls < V, we've found a model for all of the clauses with conclusion + in W, which can now be fixed. We concentrate on the clauses whose + conclusion is different. Clearly |W| < |V|, but |Wcls| is not + necessarily < |V| *) + | Loop u isloop := Loop u isloop + | Model Wvw mcls' hsub := Model Wvw {| model_model := model_model mcls' |} _ } } } + } + } + . +Proof. + all:cbn -[cls_diff clauses_with_concl restrict_clauses]; clear loop. + all:try solve [intuition auto]. + all:try eapply levelset_neq in neq. + all:have cls_sub := clauses_conclusions_levels cls. + all:destruct prf as [clsV mof isupd]. + - red. eapply LevelSet.equal_spec in eq. + set (prf := check_model_ne_init_map _ _); clearbody prf. + eapply check_model_is_update_of in eqm; tea. rewrite eq in eqm. + destruct eqm as [eqm incl]. rewrite union_idem in eqm. + unshelve eapply strictly_updates_entails_on_V in eqm; tea. + eapply entails_all_clauses_subset; tea. apply clauses_with_concl_subset. + - eapply check_model_is_update_of in eqm as [eqm incl]; tea. + have hi := strictly_updates_incl eqm. + rewrite union_idem in hi, eqm. + split => //. + * split => //. lsets. + * now eapply strictly_updates_non_empty. + * apply clauses_conclusions_clauses_with_concl. + * eapply strictly_updates_strenghten. exact eqm. + + - now intros ?; rewrite in_clauses_with_concl. + - set (ne := check_model_ne_map _). clearbody ne. + have hu := model_updates mwc. + eapply check_model_is_update_of in eqm as [eqm incl]; tea. + have om : only_model_of V m'. + { rewrite union_idem in eqm. + have incl' := strictly_updates_incl eqm. + have hcl := clauses_conclusions_levels cls. + eapply strictly_updates_only_model_gen in eqm; tea. eapply only_model_of_eq; tea. intro; lsets. } + eapply strictly_updates_is_update_of in eqm; tea. + rewrite union_idem union_with_concl in eqm. + eapply check_model_is_update_of in eqm' as [eqm' incl']; tea. + rewrite ClausesProp.union_sym union_with_concl in eqm'. + eapply (strictly_updates_entails_on_V _ _ _ ne) in eqm'. red. + eapply entails_all_clauses_subset; tea. + eapply clauses_with_concl_subset. apply LevelSet.equal_spec in e. rewrite e. exact om. + - eapply check_model_is_update_of in eqm as [eqm incl]; tea. + have hu := model_updates mwc. + eapply strictly_updates_is_update_of in hu; tea. + rewrite union_idem union_with_concl in hu. + eapply check_model_update_of in eqm' as [wmcls [upd ->]]. + eapply is_update_of_strictly_updates in hu. + have tr := is_update_of_trans_eq hu upd. + split => //. apply tr. clsets. lsets. + - right. + eapply check_model_spec_V in eqm' as eqm''. 3:etransitivity; [apply clauses_conclusions_levels|exact clsV]. cbn in eqm''. + 2:{ + eapply check_model_is_update_of in eqm as [eqm incl]; tea. rewrite union_idem in eqm. + eapply strictly_updates_is_update_of in eqm; tea. 2:apply mwc. + eapply strictly_updates_model_of_gen in eqm; tea. 2:exact mof. + eapply model_of_subset; tea. lsets. } + 2:{ eapply is_update_of_total_model. apply mwc. } + destruct eqm'' as [Hwc Hwcls H1 mext tot]. + eapply check_model_is_update_of in eqm as [eqm incl]; tea. + rewrite union_idem in eqm. + have hu := model_updates mwc. + eapply check_model_is_update_of in eqm' as [eqm' incl']; tea. + rewrite ClausesProp.union_sym union_with_concl in eqm'. + have WcW := model_incl mwc. + (* destruct hsub' as [UWc WcW]. *) + have w_incl := strictly_updates_incl eqm. + have wcls_incl := strictly_updates_incl eqm'. + assert (exists l, LevelSet.In l Wcls /\ ~ LevelSet.In l W). + { destruct H1 as [cl [clcls nvalid hcll hv]]. + pose proof (model_ok mwc). + eapply is_model_invalid_clause in H; tea. + assert (~ LevelSet.In (levelexpr_level (concl cl)) W). + { intros hin. rewrite in_clauses_with_concl in H. intuition auto. } + exists (concl cl). split => //. } + rewrite -!diff_cardinal //. clear -w_incl clsV incl wcls_incl. have hincl := clauses_conclusions_levels cls. lsets. lsets. + assert (Wcls ⊂_lset V). lsets. + eapply strict_subset_cardinal. + eapply (strict_subset_leq_right _ (LevelSet.diff V W)). 2:lsets. + apply strict_subset_diff_incl => //. + { red. split => //. lsets. intros heq. destruct H as [l' [hin hnin]]. + rewrite heq in hnin. apply hnin. lsets. } + lsets. lsets. + - eapply mcls'. + - apply mcls'. + - apply mcls'. + - apply mcls'. + - eapply check_model_is_update_of in eqm as []; tea. lsets. + - eapply check_model_is_update_of in eqm as [suinit incl]; tea. rewrite union_idem in suinit. + have hupd := model_updates mwc. + eapply (is_update_of_weaken (cls' := cls)) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. + eapply strictly_updates_is_update_of in suinit; tea. rewrite union_idem in suinit. + eapply model_of_strictly_updates; tea. exact mof. + - eapply check_model_is_update_of in eqm as [suinit incl]; tea. rewrite union_idem in suinit. + have hupd := model_updates mwc. + eapply (is_update_of_weaken (cls' := cls)) in hupd. 2:intros ? ; rewrite in_clauses_with_concl; clsets. + eapply is_update_of_trans_eq. eapply is_update_of_strictly_updates. tea. tea. clsets. lsets. + - eapply clauses_levels_conclusions; assumption. + - now apply check_model_None in eqm'. + - eapply check_model_is_update_of in eqm as [suinit incl]; tea. lsets. + - move: isupd. rewrite /is_update_of. + destruct LevelSet.is_empty. + * intros <-. exact mof. + * intros su. + eapply model_of_strictly_updates; tea. exact mof. + - exact isupd. + - apply clauses_levels_conclusions. assumption. + - now eapply check_model_None in eqm. + - lsets. +Qed. + +Transparent lexprod_rel_wf. + +Lemma add_prems_0 u : add_prems 0 u = u. +Proof. + rewrite /add_prems. + apply eq_univ_equal. + intros x. rewrite map_spec. + split. + - intros[e [hin ->]]. unfold add_expr. now destruct e; rewrite Z.add_0_r. + - intros inu; exists x. split => //. destruct x. now rewrite /add_expr Z.add_0_r. +Qed. + +Lemma entails_all_tauto cls u : cls ⊢a u → u. +Proof. + intros x hin. now constructor. +Qed. + +Lemma loop_any_successor cls u n : + cls ⊢a u → succ_prems u -> + cls ⊢a u → add_prems (Z.of_nat (S n)) u. +Proof. + induction n. + - auto. + - intros ass. + specialize (IHn ass). + have sh := entails_all_shift 1 IHn. + eapply entails_all_trans. tea. + rewrite add_prems_add_prems in sh. + have eq : 1 + Z.of_nat (S n) = Z.of_nat (S (S n)) by lia. + now rewrite eq in sh. +Qed. + +Lemma loop_any cls u n : + cls ⊢a u → succ_prems u -> + cls ⊢a u → add_prems n u. +Proof. + destruct n. + - rewrite add_prems_0. intros _. apply entails_all_tauto. + - assert (exists n, Z.pos p = Z.of_nat n). exists (Pos.to_nat p). now rewrite Z_of_pos_alt. + destruct H as [n ->]. destruct n. cbn. intros. rewrite add_prems_0. apply entails_all_tauto. + apply loop_any_successor. + - apply (todo "downward closure"). +Qed. + +Lemma univ_non_empty (u : univ) : ~ LevelSet.Empty (levels u). +Proof. intros he. have := t_ne u. move/not_Empty_is_empty. + intros he'. apply he'. intros [l k] hin. red in he. specialize (he l). apply he. + rewrite levelexprset_levels_spec. now exists k. +Qed. + +(* +Lemma loop_max cls (u : univ) : + cls ⊢a of_level_set (levels u) (premise_max u) (univ_non_empty u) → u. +Proof. + intros [l k] hin. + apply (entails_pred_closure_n (n := premise_max u - k)). + constructor. + rewrite levelexprset_of_levels_spec. split. + - apply levelexprset_levels_spec. now exists k. + - have [min _] := premise_max_spec u. + apply min in hin. cbn in hin. lia. +Qed. + +Lemma loop_any_max cls u n : + cls ⊢a u → add_prems n u -> + cls ⊢a of_level_set (levels u) (premise_max u) (univ_non_empty u) → add_prems n u. +Proof. + intros hl. eapply entails_all_trans; tea. now eapply loop_max. +Qed. + +Lemma loop_any_max_all cls u : + cls ⊢a u → succ_prems u -> + cls ⊢a of_level_set (levels u) (premise_max u) (univ_non_empty u) → + of_level_set (levels u) (premise_max u + 1) (univ_non_empty u). +Proof. + intros hl. eapply entails_all_trans; tea. + eapply (loop_any_max _ _ (premise_max u + 1)). now eapply loop_any. + intros [l k]. + rewrite levelexprset_of_levels_spec => [] []. + rewrite levelexprset_levels_spec => [] [k' hin] ->. + eapply (entails_pred_closure_n (n := k')). + constructor. rewrite In_add_prems. + exists (l, k'). split => //. rewrite /add_expr. lia_f_equal. +Qed. +*) + +(* To handle the constraint inference problem, + we must start with a model where all atoms [l + k] + appearing in premises are true. Otherwise the + [l := 0] model is minimal for [l+1-> l+2]. + Starting with [l := 1], we see that the minimal model above it + has [l := ∞]. + We also ensure that all levels in the conclusions are in the model. + *) + +Definition maximal_prem l n cls := + Clauses.For_all (fun cl => forall n', LevelExprSet.In (l, n') (premise cl) -> n' <= n) cls. + +Definition max_premise_of l (u : univ) : Z := + LevelExprSet.fold (fun '(l', k) acc => if eqb l l' then Z.max k acc else acc) u 0. + +Lemma max_premise_of_spec l k (u : univ) : LevelExprSet.In (l, k) u -> k <= max_premise_of l u. +Proof. + rewrite /max_premise_of. + eapply LevelExprSetProp.fold_rec. + - intros s' he hin. now apply he in hin. + - intros x a s' s'' hin nin hadd hle. + intros hs''. destruct x. + apply hadd in hs'' as []. + * noconf H. rewrite eqb_refl. lia. + * elim: eqb_spec; try intros ->; + specialize (hle H); lia. +Qed. + +Definition max_clause_premise_of l (cls : clauses) := + Clauses.fold (fun cl acc => Z.max (max_premise_of l (premise cl)) acc) cls 0. + +Lemma max_clause_premise_of_spec l k cls : + forall cl, Clauses.In cl cls -> LevelExprSet.In (l, k) (premise cl) -> k <= max_clause_premise_of l cls. +Proof. + rewrite /max_clause_premise_of => cl. + eapply ClausesProp.fold_rec. + - intros s' he hin. now apply he in hin. + - intros x a s' s'' hin nin hadd hle. + intros hs''. destruct x. + apply hadd in hs'' as []. + * noconf H. cbn. move/max_premise_of_spec. lia. + * specialize (hle H); lia. +Qed. + +Definition max_clause_premises cls : model := + let ls := clauses_levels cls in + let fn l m := LevelMap.add l (max_clause_premise_of l cls) m in + LevelSet.fold fn ls (LevelMap.empty _). + +Lemma max_clause_premises_spec l k cls : + LevelMap.MapsTo l k (max_clause_premises cls) -> LevelSet.In l (clauses_levels cls) /\ k = max_clause_premise_of l cls. +Proof. + unfold max_clause_premises. + eapply LevelSetProp.fold_rec. + - intros s' he hm. now rewrite LevelMapFact.F.empty_mapsto_iff in hm. + - intros x a s' s'' hin hnin hadd ih. + rewrite LevelMapFact.F.add_mapsto_iff. + intros [[-> <-]|[]] => //. + * split => //. apply hadd. now left. + * split => //. apply hadd; now right. now apply ih. +Qed. + +Lemma max_clause_premises_spec_inv cls : + forall l, LevelSet.In l (clauses_levels cls) -> LevelMap.MapsTo l (max_clause_premise_of l cls) (max_clause_premises cls). +Proof. + unfold max_clause_premises. + eapply LevelSetProp.fold_rec. + - intros s' he hm. now move/he. + - intros x a s' s'' hin hnin hadd ih l ls''. + rewrite LevelMapFact.F.add_mapsto_iff. + destruct (eq_dec x l). subst. + * now left. + * right. split => //. apply ih. eapply hadd in ls''. destruct ls''; auto. contradiction. +Qed. + +Definition init_model cls := max_clause_premises cls. + +Lemma init_model_levels cls k : + LevelMap.In k (init_model cls) <-> LevelSet.In k (clauses_levels cls). +Proof. + split. + now move => [] k' /max_clause_premises_spec. + move/max_clause_premises_spec_inv. now eexists. +Qed. + +Definition init_w (levels : LevelSet.t) : LevelSet.t := LevelSet.empty. + +(* We don't need predecessor clauses as they are trivially satisfied *) +(* Definition add_predecessors (V : LevelSet.t) cls := + LevelSet.fold (fun l acc => + Clauses.add (NonEmptySetFacts.singleton (l, 1), (l, 0)) acc) V cls. *) + +Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). + +Equations? infer (cls : clauses) : infer_result (clauses_levels cls) cls := + infer cls := loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (init_model cls) (And3 _ _ _). +Proof. + - reflexivity. + - intros k. now rewrite -init_model_levels. + - apply is_update_of_empty. +Qed. + +Local Open Scope string_scope2. + +Definition print_level_Z_map (m : LevelMap.t Z) := + let list := LevelMap.elements m in + print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_Z w) nl list. + +Definition print_result {V cls} (m : infer_result V cls) := + match m return string with + | Loop _ _ => "looping on " + | Model w m _ => "satisfiable with model: " ^ print_level_Z_map m.(model_model) ^ nl ^ " W = " ^ + print_lset w + ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model m.(model_model)) + end. + +Definition valuation_of_result {V cls} (m : infer_result V cls) := + match m with + | Loop _ _ => "looping" + | Model w m _ => print_level_nat_map (valuation_of_model m.(model_model)) + end. + +Definition to_string_expr (e : LevelExpr.t) : string := + let '(l, n) := e in Level.to_string l ^ (if n is Z0 then "" else "+" ^ string_of_Z n). + +Definition print_premise (l : nonEmptyLevelExprSet) : string := + let (e, exprs) := NonEmptySetFacts.to_nonempty_list l in + to_string_expr e ^ + match exprs with + | [] => "" + | l => ", " ^ print_list to_string_expr ", " exprs + end. + +Definition print_clauses (cls : clauses) := + let list := Clauses.elements cls in + print_list (fun '(l, r) => + print_premise l ^ " → " ^ to_string_expr r) nl list. + +Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) + (prf : clauses_levels cls ⊂_lset V /\ clauses_levels cls' ⊂_lset V /\ only_model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := + | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m m _. +Proof. + split. + - intros x. rewrite clauses_levels_spec. + move=> [] cl. rewrite Clauses.union_spec. + intros [[] incls]. apply H. apply clauses_levels_spec. exists cl. split => //. + apply H0. apply clauses_levels_spec. exists cl; split => //. + - exact H1. + - eapply is_update_of_empty. +Qed. + + +(* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by + setting a minimal value for the new atoms in [clauses_levels cls \ V] + such that the new clauses [cls] do not hold vacuously. +*) +(* Equations? infer_extension {V W init cls} (m : valid_model V W init cls) (cls' : clauses) : + result (LevelSet.union (clauses_levels cls') V) LevelSet.empty (Clauses.union cls cls') (min_model m.(model_model) cls') := + infer_extension m cls' := + infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model m.(model_model) cls') cls cls' _. +Proof. + repeat split. + - pose proof (model_clauses_conclusions m). intros x. lsets. + - pose proof (clauses_conclusions_levels cls'). lsets. + - red. intros. + unfold min_model. rewrite min_model_map_levels. + pose proof (model_of_V m k). + apply LevelSet.union_spec in H as []; auto. +Qed. + +Definition enforce_clauses {V W init cls} (m : valid_model V W init cls) cls' : option model := + match infer_extension m cls' with + | Loop _ _ _ => None + | Model w m _ => Some m.(model_model) + end. +*) +(* Definition enforce_clause {V W init cls} (m : valid_model V W init cls) cl : option model := + enforce_clauses m (Clauses.singleton cl). *) + +Inductive constraint_type := UnivEq | UnivLe. + +Notation constraint := (nonEmptyLevelExprSet * constraint_type * nonEmptyLevelExprSet)%type. + +Definition enforce_constraint (cstr : constraint) (cls : clauses) : clauses := + let '(l, d, r) := cstr in + match d with + | UnivLe => + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) l cls + | UnivEq => + let cls := + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) l cls + in + let cls' := + LevelExprSet.fold (fun rk acc => Clauses.add (l, rk) acc) r cls + in cls' + end. + +Definition clauses_of_list := ClausesProp.of_list. +Definition list_of_clauses := Clauses.elements. +Definition valuation := LevelMap.t nat. + +Definition add_max l k m := + match LevelMap.find l m with + | Some k' => + if (k' LevelMap.add l k m + end. + +Lemma In_add_max l l' k acc : + LevelMap.In (elt:=nat) l (add_max l' k acc) <-> + (l = l' \/ LevelMap.In l acc). +Proof. + unfold add_max. + destruct LevelMap.find eqn:hl. + - case: Nat.ltb_spec. + + rewrite LevelMapFact.F.add_in_iff /Level.eq. + firstorder eauto. + + intros. intuition auto. subst. + now rewrite LevelMapFact.F.in_find_iff hl. + - LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. +Qed. + +Definition premises_model_map (m : model) cls : model := + let levels := clauses_premises_levels cls in + LevelSet.fold (fun l acc => + LevelMap.add l (max_clause_premise_of l cls) acc) levels m. + +Variant checking_result (cls : clauses) (cl : clause) : Type := + | DoesNotHold : ~ entails cls cl -> checking_result cls cl + | Entails : entails cls cl -> checking_result cls cl. + +Definition zero_model levels : model := + LevelSet.fold (fun l acc => LevelMap.add l 0 acc) levels (LevelMap.empty _). + +Definition premises_model V cl : LevelSet.t * model := + let levels := LevelSet.union (clause_levels cl) V in + (levels, premises_model_map (zero_model levels) (Clauses.singleton cl)). + +Lemma premises_model_map_spec m cls : + forall l k, + LevelMap.MapsTo l k (premises_model_map m cls) -> + ((LevelSet.In l (clauses_premises_levels cls) /\ k = max_clause_premise_of l cls) \/ + (~ LevelSet.In l (clauses_premises_levels cls) /\ LevelMap.MapsTo l k m)). +Proof. + intros l k; rewrite /premises_model_map. + eapply LevelSetProp.fold_rec. + - intros s' he hm. right. split => //. + - intros x a s' s'' hin hnin hadd ih. + rewrite LevelMapFact.F.add_mapsto_iff. + firstorder. subst k. red in H; subst. firstorder. +Qed. + +Lemma premises_model_map_in m cls l : + LevelMap.In l (premises_model_map m cls) <-> (LevelSet.In l (clauses_premises_levels cls) \/ LevelMap.In l m). +Proof. + rewrite /premises_model_map. + eapply LevelSetProp.fold_rec. + - intros s' he. firstorder. + - intros x a s' s'' hin hnin hadd ih. + rewrite LevelMapFact.F.add_in_iff. + firstorder. +Qed. + +Lemma zero_model_spec {l ls n} : LevelMap.MapsTo l n (zero_model ls) <-> LevelSet.In l ls /\ n = 0. +Proof. + unfold zero_model. + eapply LevelSetProp.fold_rec. + - intros s' he. rewrite LevelMapFact.F.empty_mapsto_iff. firstorder. + - intros x a s s' hin hnin hadd eq. + rewrite LevelMapFact.F.add_mapsto_iff. firstorder. + destruct (eq_dec x l). + * subst. now left. + * right. split => //. apply hadd in H1. destruct H1; try congruence. now apply H0. +Qed. + +Lemma in_premises_model V cl : + forall l, + LevelMap.In l (premises_model V cl).2 <-> + LevelSet.In l V \/ LevelSet.In l (clause_levels cl). +Proof. + intros l. rewrite premises_model_map_in. + rewrite clauses_premises_levels_spec. + firstorder. + - right. apply Clauses.singleton_spec in H. + apply clause_levels_spec. left. now subst. + - apply zero_model_spec in H as [hin ->]. + apply LevelSet.union_spec in hin. firstorder. + - right. exists 0. apply zero_model_spec. split => //; lsets. + - eapply clause_levels_spec in H as [H|H]. + * left. exists cl. split => //. now apply Clauses.singleton_spec. + * subst. right. exists 0. apply zero_model_spec. split => //. + apply LevelSet.union_spec. left. apply clause_levels_spec. now right. +Qed. + +Lemma clauses_levels_add {n cls} : clauses_levels (add_clauses n cls) =_lset clauses_levels cls. +Proof. + rewrite /clauses_levels. + symmetry. + apply ClausesProp.fold_rec. + - intros s' he l. rewrite LevelSetFact.empty_iff. split => //. + move/clauses_levels_spec => [] cl []. + move/in_add_clauses => [] cl' [] hin ->. + now apply he in hin. + - intros x a s s' incls nins hadd -> l. + rewrite LevelSet.union_spec !clauses_levels_spec. + rewrite clause_levels_spec. + split. + * move => [[hin|->]|]. + { exists (add_clause n x). split => //. apply add_clauses_spec. apply hadd. now left. + rewrite clause_levels_spec. left. move: hin. rewrite !levelexprset_levels_spec. + intros [k hin]; exists (k + n). destruct x as [prems concl]. cbn. + apply In_add_prems. exists (l, k). split => //. } + { exists (add_clause n x). rewrite -add_clauses_spec. split => //. apply hadd. now left. + rewrite clause_levels_spec. right. + destruct x; cbn. destruct t => //. } + { intros [cl [hin hl]]; exists cl. split => //. + move/in_add_clauses: hin => [cl' [incl' ->]]. + apply add_clauses_spec. now apply hadd. } + * move=> [] cl [] /in_add_clauses [[prems concl] [incl' ->]] /clause_levels_spec. + apply hadd in incl' as [->|ins]. + { move=> [hin|->]. left. left. move/levelexprset_levels_spec: hin => [] k. cbn [premise add_clause]. cbn. + move/In_add_prems => [] [l' k'] [] hinle' [=] -> _. + apply levelexprset_levels_spec. now exists k'. + now left; right; destruct concl. } + { cbn. move=> [hin|->]. + { right. exists (add_clause n (prems, concl)). + split. now apply add_clauses_spec. + apply clause_levels_spec. left. apply levelexprset_levels_spec in hin as [k hin]. + apply In_add_prems in hin as [[l' k'] [hin eq]]. noconf eq. + apply levelexprset_levels_spec. exists (k' + n). eapply In_add_prems. + now exists (l, k'). } + { right. exists (add_clause n (prems, concl)). + split. now apply add_clauses_spec. + apply clause_levels_spec. now right. } } +Qed. + +Equations? infer_model (cls : clauses) : option model := +infer_model cls with loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (init_model cls) _ := + | Loop _ _ => None + | Model w vm heq => Some vm.(model_model). +Proof. + split. + - reflexivity. + - apply infer_obligation_2. + - apply is_update_of_empty. +Qed. + +Definition enabled_clause (m : model) (cl : clause) := + exists z, min_premise m (premise cl) = Some z. + +Definition enabled_clauses (m : model) (cls : clauses) := + Clauses.For_all (enabled_clause m) cls. + +Definition correct_model (cls : clauses) (m : model) := + enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. + +Definition infer_correctness cls := + match infer_model cls with + | Some m => correct_model cls m + | None => ~ exists v, clauses_sem v cls + end. + +Lemma enabled_clauses_ext m m' cls : m ⩽ m' -> enabled_clauses m cls -> enabled_clauses m' cls. +Proof. + intros hext. + rewrite /enabled_clauses. + intros ha cl; move/ha. + unfold enabled_clause. + intros [minp heq]. + have hp := min_premise_pres (premise cl) hext. + rewrite heq in hp. depelim hp. now exists y. +Qed. + +Lemma interp_prems_ge v (prems : nonEmptyLevelExprSet) : + forall prem, LevelExprSet.In prem prems -> + interp_expr v prem <= interp_prems v prems. +Proof. + intros. + unfold interp_prems. + have he := to_nonempty_list_spec prems. + destruct to_nonempty_list. + pose proof to_nonempty_list_spec'. + rewrite In_elements in H. rewrite -he in H. clear H0 he. clear -H. + destruct H. subst t. + - induction l. cbn. auto. + cbn. lia. cbn. lia. + - induction l in H |- *. + now cbn in H. + cbn in H. destruct H; subst; cbn. + * cbn. lia. + * specialize (IHl H). lia. +Qed. + +(** Enabled and valid clauses are satisfied by valuation *) +Lemma valid_clause_model model cl : + enabled_clause model cl -> + valid_clause model cl -> + clause_sem (valuation_of_model model) cl. +Proof. + unfold enabled_clause, valid_clause. + destruct min_premise eqn:hmin => //= => //. + 2:{ intros [k' eq]. congruence. } + intros [k' eq]. noconf eq. + destruct cl as [prems [concl k]]; cbn. + unfold level_value_above. + destruct level_value eqn:hl => //. + unfold interp_level. unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. + move/Z.leb_le => hrel. + eapply LevelMap.find_2 in hfind. + have conclm := valuation_of_model_spec _ _ _ hfind. + set (v := (model_max _ - _)) in *. + cbn in conclm. + eapply LevelMap.find_1 in conclm. rewrite conclm. + subst v. + pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. + rewrite hmin in premeq. + eapply Z.le_ge. + eapply Z.le_trans. 2:{ eapply interp_prems_ge; tea. } + unfold interp_expr. destruct prem as [prem k']. + symmetry in premeq. + move: premeq. unfold min_atom_value. + unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. + intros [= <-]. + eapply LevelMap.find_2 in findp. + have premm := valuation_of_model_spec _ _ _ findp. + unfold interp_level. + eapply LevelMap.find_1 in premm. rewrite premm. + assert (z1 - k' <= z0 - k). lia. + have hm : z0 <= model_max model. eapply model_max_spec; tea. + have hm' : z1 <= model_max model. eapply model_max_spec; tea. + have hmi : model_min model <= z0. eapply model_min_spec; tea. + have hmi' : model_min model <= z1. eapply model_min_spec; tea. + assert (0 <= model_max model)%Z by apply model_max_spec2. + assert (model_min model <= 0)%Z by apply model_min_spec2. + lia. +Qed. + +Lemma init_model_enabled cls : enabled_clauses (init_model cls) cls. +Proof. + unfold enabled_clauses. + intros x hin. unfold enabled_clause. + pose proof (@min_premise_spec (init_model cls) (premise x)) as [premmin [prem [premin premeq]]]. + have inV : LevelSet.In prem (clauses_levels cls). + { rewrite clauses_levels_spec. exists x; split => //. rewrite /clause_levels. + eapply LevelSet.union_spec; left. rewrite levelexprset_levels_spec. exists prem.2. + destruct prem. exact premin. } + unfold init_model. rewrite premeq. unfold min_atom_value. + destruct prem as [l k]. + have hm := max_clause_premises_spec_inv cls l inV. + rewrite (level_value_MapsTo hm). + have hs := max_clause_premise_of_spec l k _ _ hin premin. + eexists; split => //. +Qed. + +Lemma interp_add_expr V n e : interp_expr V (add_expr n e) = n + interp_expr V e. +Proof. + destruct e as [l k]; cbn. lia. +Qed. + +(* From Stdlib Require Import Structures.OrdersEx. + +Module Nat_as_OT. + Include OrdersEx.Nat_as_DT. + + Lemma eq_leibniz : forall x y, eq x y -> Logic.eq x y. + Proof. auto. Qed. + +End Nat_as_OT. + +Module NatSet := MSetList.MakeWithLeibniz Nat_as_OT. *) + +Lemma interp_prems_singleton V e : + interp_prems V (singleton e) = interp_expr V e. +Proof. + rewrite /interp_prems. + now rewrite singleton_to_nonempty_list /=. +Qed. + + (*have leq : (interp_expr V cl <= fold_right (fun x acc : nat => Nat.max x acc) 0 + (map (interp_expr V) (rev (LevelExprSet.elements u)))). + { eapply fold_right_max_in. + apply in_map_iff. exists cl. split => //. + rewrite -In_rev. apply InA_In_eq. + now apply LevelExprSet.elements_spec1. } + lia. + unshelve erewrite LevelExprSetProp.fold_add => //. 1-2:tc. red; lia. +Qed.*) + +Lemma fold_right_max_in {a l} n : In a l -> a <= fold_right Z.max n l. +Proof. + induction l. + - now cbn. + - intros [eq|inl]. subst a0. cbn. lia. + cbn. specialize (IHl inl). lia. +Qed. + +Lemma fold_right_max_acc {n l} : n <= fold_right Z.max n l. +Proof. + induction l. + - now cbn. + - cbn. lia. +Qed. + +Lemma fold_right_impl n l l' : + (forall x, In x l -> In x l') -> fold_right Z.max n l <= fold_right Z.max n l'. +Proof. + induction l in l' |- *. + - cbn. destruct l'; cbn. lia. + intros. have := @fold_right_max_acc n l'. lia. + - cbn; intros h. + have inal' := (h a (or_introl eq_refl)). + have := fold_right_max_in n inal'. + specialize (IHl l'). + forward IHl. + intros. apply h. now right. + lia. +Qed. + +Lemma fold_right_equivlist n l l' : + equivlistA eq l l' -> fold_right Z.max n l = fold_right Z.max n l'. +Proof. + intros eq. + have h := fold_right_impl n l l'. + forward h. intros x; rewrite -!InA_In_eq. apply eq. + have h' := fold_right_impl n l' l. + forward h'. intros x; rewrite -!InA_In_eq. apply eq. + lia. +Qed. + +Fixpoint max_list (l : list Z) : option Z := + match l with + | [] => None + | x :: xs => match max_list xs with + | Some m => Some (Z.max x m) + | None => Some x end + end. + +Lemma max_list_fold_right n l : max_list (n :: l) = Some (fold_right Z.max n l). +Proof. + induction l; cbn. + - reflexivity. + - cbn in IHl. destruct max_list. f_equal. noconf IHl. lia. + f_equal; noconf IHl. lia. +Qed. + +Lemma fold_right_max_spec n l : + let fn := fold_right Z.max in + (forall x, In x (n :: l) -> x <= fn n l) /\ + (exists x, In x (n :: l) /\ fn n l = x). +Proof. + induction l; cbn. + - split. intros x [] => //. now subst. + exists n. firstorder. + - cbn in IHl. destruct IHl as [h h']. + split. + intros x [|[]]; subst. + * specialize (h x). forward h by auto. lia. + * lia. + * specialize (h x). forward h by auto. lia. + * destruct h' as [x []]. exists (Z.max a x). rewrite -{4}H0. split => //. + destruct H; subst. + destruct (Z.max_spec a x) as [[]|[]]; firstorder; subst. + destruct (Z.max_spec a (fold_right Z.max n l)) as [[]|[]]; firstorder; subst. rewrite H1. + auto. +Qed. + +(* +Lemma maX_list_equivlist l l' : + equivlistA eq l l' -> max_list l = max_list l'. +Proof. + induction l in l' |- *; destruct l'; cbn; auto. + - move/(_ z) => [] _. rewrite InA_In_eq. move/(_ (or_introl eq_refl)). + intros ina; depelim ina. + - now move/(_ a) => []; rewrite !InA_In_eq => /(_ (or_introl eq_refl)). + - intros eql. + rewrite INa eqnc. intros [eqnc eqnc']. + *) + + +Lemma fold_right_equivlist_all n n' l l' : + equivlistA eq (n :: l) (n' :: l') -> fold_right Z.max n l = fold_right Z.max n' l'. +Proof. + intros eq. + have [hla [maxl [inmaxl eqmaxl]]] := fold_right_max_spec n l. + have [hra [maxr [inmaxr eqmaxr]]] := fold_right_max_spec n' l'. + rewrite eqmaxl eqmaxr. + red in eq; setoid_rewrite InA_In_eq in eq. + apply (eq _) in inmaxl. apply hra in inmaxl. + apply eq in inmaxr. apply hla in inmaxr. lia. +Qed. + +Lemma interp_prems_elements V u : + interp_prems V u = fold_right Z.max (interp_expr V (to_nonempty_list u).1) (map (interp_expr V) (to_nonempty_list u).2). +Proof. + rewrite /interp_prems. + have he := to_nonempty_list_spec u. + destruct to_nonempty_list. + now rewrite Universes.fold_right_map. +Qed. + +Lemma fold_right_interp {V x l x' l'} : + equivlistA eq (x :: l) (x' :: l') -> + fold_right Z.max (interp_expr V x) (map (interp_expr V) l) = fold_right Z.max (interp_expr V x') (map (interp_expr V) l'). +Proof. + intros eq. apply fold_right_equivlist_all. + intros a. rewrite !InA_In_eq. + rewrite !(in_map_iff (interp_expr V) (_ :: _)). + setoid_rewrite <-InA_In_eq. + split. + - move=> [b [<- ]]. + eexists; split; trea. now apply eq in b0. + - move=> [b [<- ]]. + eexists; split; trea. now apply eq in b0. +Qed. + +Lemma interp_prems_equiv V (u u' : univ) : + LevelExprSet.Equal u u' -> + interp_prems V u = interp_prems V u'. +Proof. + move=> eq. rewrite !interp_prems_elements. + apply fold_right_equivlist_all. + intros x. + rewrite InA_In_eq (in_map_iff (interp_expr V) (_ :: _)). + rewrite InA_In_eq (in_map_iff (interp_expr V) (_ :: _)). +Admitted. + +Lemma equivlistA_add le u : let l := to_nonempty_list (add le u) in + equivlistA eq (l.1 :: l.2) (le :: LevelExprSet.elements u). +Proof. + have he := to_nonempty_list_spec (add le u). + destruct to_nonempty_list. cbn. + intros x. rewrite he. + rewrite !LevelExprSet.elements_spec1. + split. + - move/LevelExprSet.add_spec => [->|hin]. + now constructor. constructor 2. now apply LevelExprSet.elements_spec1. + - intros h; depelim h; subst. now apply LevelExprSet.add_spec; left. + apply LevelExprSet.add_spec. now apply LevelExprSet.elements_spec1 in h. +Qed. + +Lemma fold_right_comm acc l : l <> [] -> fold_right Z.max acc l = Z.max acc (fold_right Z.max (List.hd acc l) (List.tl l)). +Proof. + induction l in acc |- *. + - intros; congruence. + - intros _. cbn. destruct l; cbn. lia. + cbn in IHl. rewrite (IHl acc). congruence. + rewrite (IHl a). congruence. lia. +Qed. + +Lemma interp_prems_add V le (u : univ) : + interp_prems V (add le u) = Z.max (interp_expr V le) (interp_prems V u). +Proof. + rewrite 2!interp_prems_elements. + erewrite fold_right_interp. 2:apply equivlistA_add. + rewrite fold_right_comm. + { apply map_nil, elements_not_empty. } + f_equal. eapply fold_right_equivlist_all. + have he := to_nonempty_list_spec u. + destruct to_nonempty_list. rewrite -he //=. +Qed. + +Lemma interp_prems_eq (P : univ -> Z -> Prop) V : + (forall le, P (singleton le) (interp_expr V le)) -> + (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (add le u) (Z.max (interp_expr V le) k)) -> + forall u, P u (interp_prems V u). +Proof. + intros hs hadd. + eapply nonEmptyLevelExprSet_elim. + - intros le. rewrite interp_prems_singleton. apply hs. + - intros le prems ih hnin. + rewrite interp_prems_add. now apply hadd. +Qed. + +Lemma add_prems_singleton n cl : add_prems n (singleton cl) = singleton (add_expr n cl). +Proof. + apply eq_univ_equal => [] [l k]. + rewrite In_add_prems LevelExprSet.singleton_spec. + firstorder. + - destruct x; noconf H0. + eapply LevelExprSet.singleton_spec in H. + now red in H; noconf H. + - destruct cl. exists (t, z). split => //. + red in H; noconf H. now apply LevelExprSet.singleton_spec. +Qed. + +Lemma interp_add_prems V n e : interp_prems V (add_prems n e) = n + interp_prems V e. +Proof. + revert e. + refine (interp_prems_eq (fun u z => interp_prems V (add_prems n u) = n + z) _ _ _). + - intros le. + rewrite add_prems_singleton interp_prems_singleton //=. + destruct le; cbn. lia. + - intros le u k heq hnin. + rewrite add_prems_add. + rewrite interp_prems_add heq interp_add_expr. lia. +Qed. + +Lemma in_pred_closure_entails cls cl : + in_pred_closure cls cl -> + (forall V, clauses_sem V cls -> clause_sem V cl). +Proof. + induction 1. + - intros V. rewrite /clauses_sem. intros ha. + apply ha in H. + move: H; rewrite /clause_sem. + destruct cl as [prems concl]. + cbn. rewrite interp_add_prems. + destruct concl as [concl conclk]. + rewrite /add_expr; cbn. lia. + - intros V clsm. cbn. + rewrite interp_prems_singleton. + cbn. lia. +Qed. + +Lemma interp_prems_in {V le} {u : univ} : LevelExprSet.In le u -> interp_prems V u >= interp_expr V le. +Proof. + revert u. + refine (interp_prems_eq (fun u z => LevelExprSet.In le u -> z >= interp_expr V le) V _ _). + - intros le' u'. + apply LevelExprSet.singleton_spec in u'. red in u'; subst. lia. + - move=> le' u z hz hnin /LevelExprSet.add_spec [->|hin]. lia. + specialize (hz hin). lia. +Qed. + +Lemma clauses_sem_subset {u u' : univ} : u ⊂_leset u' -> + forall V, interp_prems V u' >= interp_prems V u. +Proof. + intros hsub V. + revert u u' hsub. + refine (interp_prems_eq (fun u z => forall u' : univ, u ⊂_leset u' -> interp_prems V u' >= z) V _ _). + - intros le u' hsing. + specialize (hsing le). forward hsing by now apply LevelExprSet.singleton_spec. + now apply interp_prems_in. + - intros le u k ih hin u' sub. + have hle := sub le. + specialize (ih u'). + forward ih. intros x hin'. apply sub. now apply LevelExprSet.add_spec; right. + forward hle by now apply LevelExprSet.add_spec; left. + have hi := interp_prems_in (V := V) hle. lia. +Qed. + +#[refine] Instance ge_refl : Reflexive Z.ge := _. +Proof. red. lia. Qed. + +#[refine] Instance ge_trans : Transitive Z.ge := _. +Proof. red. lia. Qed. + +Lemma clauses_sem_entails {cls cl} : + entails cls cl -> + (forall V, clauses_sem V cls -> clause_sem V cl). +Proof. + induction 1. + - intros v clls. red. + destruct concl0 as [concl k]. + have hge := interp_prems_ge v prems _ H. + by lia. + - move=> V Hcls. + move: {IHentails} (IHentails _ Hcls). + unfold clause_sem. unfold ge => hyp. + etransitivity; tea. rewrite interp_prems_add. + rewrite interp_prems_add in hyp. + eapply in_pred_closure_entails in H; tea. + move: H; rewrite /clause_sem. unfold ge. + have ssub := clauses_sem_subset H1 V. lia. +Qed. + +Lemma clauses_sem_entails_all {cls prems concl} : + cls ⊢a prems → concl -> + (forall V, clauses_sem V cls -> interp_prems V prems >= interp_prems V concl). +Proof. + intros ha V hcls. + red in ha. + move: ha. + revert concl. + refine (@interp_prems_eq (fun concl z => _ -> interp_prems V prems >= z) V _ _). + - move=> le //=. move/(_ le). + intros h; forward h by now apply LevelExprSet.singleton_spec. + now have ent := (clauses_sem_entails h _ hcls). + - intros le u k ih hnin. + intros hf. + forward ih. intros x hin; apply (hf x). + rewrite LevelExprSet.add_spec; now right. + specialize (hf le). + forward hf by now apply LevelExprSet.add_spec; left. + cbn in hf. + have ent := (clauses_sem_entails hf _ hcls). cbn in ent. + lia. +Qed. + +Lemma infer_correct cls : infer_correctness cls. +Proof. + unfold infer_correctness. + destruct infer_model as [m|] eqn:hi. + - (* Correct *) move: hi. + funelim (infer_model cls) => //. + intros [= <-]. + set (obl := infer_model_obligation_1 cls). clearbody obl. + clear Heq Heqcall. + have mincl := model_incl vm. + destruct vm as [model ofV isupd clsconcl ism]; cbn in *. + set (V := clauses_levels cls) in *. + unfold correct_model. + have encl : enabled_clauses model cls. + { eapply enabled_clauses_ext. apply is_update_of_ext in isupd. exact isupd. + apply init_model_enabled. } + split => //. + unfold clauses_sem. + intros cl hin. + eapply valid_clause_model. now eapply encl in hin. + eapply Clauses.for_all_spec in ism; tc. now specialize (ism _ hin). + - intros [v clssem]. + move: hi. + funelim (infer_model cls) => //. intros _. + red in islooping. + have sem := clauses_sem_entails_all islooping v0. + specialize (sem clssem). + rewrite interp_add_prems in sem. lia. +Qed. + +Definition valid_entailment cls cl := forall V, clauses_sem V cls -> clause_sem V cl. + +Program Definition loop_check cls (cl : clause) : result (premises_model (clauses_levels cls) cl).1 LevelSet.empty (succ_clauses cls) (premises_model (clauses_levels cls) cl).2 := + let V := clauses_levels cls in + loop (premises_model V cl).1 LevelSet.empty (succ_clauses cls) (premises_model V cl).2 (premises_model V cl).2 _. +Next Obligation. + split => //. + - rewrite clauses_levels_add. lsets. + - intros l. rewrite LevelSet.union_spec. + rewrite -/(LevelMap.In l (premises_model (clauses_levels cls) cl).2). + rewrite in_premises_model. intuition auto. + - apply is_update_of_empty. +Qed. + +Definition premises_of_level_set (l : LevelSet.t) := + LevelSet.fold (fun l acc => (l, 0) :: acc) l []. + +Definition extendV V (cl : clause) := + let '(prems, concl) := cl in + (add_list (premises_of_level_set V) prems, concl). + +Lemma premises_model_map_min_premise {levels cls prems z} : + min_premise (premises_model_map (zero_model levels) cls) prems = Some z -> + (exists minp mink, LevelExprSet.In (minp, mink) prems /\ z = max_clause_premise_of minp cls - mink) \/ + (exists minp mink, LevelExprSet.In (minp, mink) prems /\ z + mink <= 0)%Z. +Proof. + set (m := premises_model_map _ _). + have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m prems. + rewrite mineq. rewrite /min_atom_value. + destruct level_value eqn:hl => //. intros [= <-]. + eapply LevelMap.find_2 in hl. eapply premises_model_map_spec in hl as [[inpcls hm]|[ninpcls h']]. left. + 2:{ apply zero_model_spec in h' as [h' ->]. cbn. right. eexists minp, mink. + split => //. lia. } + exists minp, mink. split => //. lia. +Qed. + +Lemma premises_model_map_min_premise_inv {levels cls} : + forall cl, Clauses.In cl cls -> + exists z, min_premise (premises_model_map (zero_model levels) cls) (premise cl) = Some z /\ (0 <= z)%Z. +Proof. + set (m := premises_model_map _ _). + move=> cl hin. + have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m (premise cl). + rewrite mineq. rewrite /min_atom_value. + destruct level_value eqn:hl => //. + eexists. split; trea. + have ps := premises_model_map_spec _ cls minp z (level_value_MapsTo' hl). + destruct ps as [[minpsl eq]|]. + rewrite eq. + have sp := (max_clause_premise_of_spec _ _ _ _ hin inminp). lia. + destruct H. elim H. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. + unfold level_value in hl. + move/LevelMapFact.F.not_find_in_iff: hl; elim. + rewrite premises_model_map_in. left. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. +Qed. + +Lemma is_update_of_entails {cls V m m' hne hne'} : is_update_of cls V m m' -> + cls ⊢a of_level_map m hne → of_level_map m' hne'. +Proof. + rewrite /is_update_of. + destruct LevelSet.is_empty. + - intros heq []. + rewrite !of_level_map_spec. rewrite -heq. + constructor. now apply of_level_map_spec. + - eapply strictly_updates_entails. +Qed. + +Lemma is_update_of_non_empty {cls V m m'} : ~ LevelMap.Empty m -> + is_update_of cls V m m' -> + ~ LevelMap.Empty m'. +Proof. + rewrite /is_update_of. destruct LevelSet.is_empty. + - now intros he <-. + - intros he su. now eapply strictly_updates_non_empty_map in su. +Qed. + +Lemma inj_add_prems_sub {n u u'} : add_prems n u ⊂_leset add_prems n u' -> u ⊂_leset u'. +Proof. + rewrite /add_prems. + intros hm [l k]. specialize (hm (l, k + n)). + rewrite !map_spec in hm. + intros hin. + forward hm. exists (l, k); split => //. + destruct hm as [[] [hin' eq]]. + apply (@add_expr_inj n (l, k)) in eq. now noconf eq. +Qed. + +Lemma premises_of_level_set_spec l k V : LevelSet.In l V /\ k = 0 <-> In (l, k) (premises_of_level_set V). +Proof. + rewrite /premises_of_level_set. + eapply LevelSetProp.fold_rec. + - intros s' he. firstorder. + - intros x a s' s'' hin hnin hadd ih. + red in hadd. rewrite {}hadd. + cbn. firstorder. subst. now left. noconf H1. now left. now noconf H1. +Qed. + +Lemma in_succ_add_premises {V u x k} : LevelExprSet.In (x, Z.of_nat (k + 1)) (add_list (premises_of_level_set V) u) -> LevelExprSet.In (x, Z.of_nat (k + 1)) u. +Proof. + rewrite add_list_spec. intros [hn|hn] => //. + eapply premises_of_level_set_spec in hn as []. lia. +Qed. + +(* Lemma inj_succ_prems {V u u'} : succ_prems u ⊂_leset add_list (premises_of_level_set V) u' -> succ_prems u ⊂_leset u'. +Proof. + intros sub x. rewrite In_add_prems => [] [[l k] [hin ->]]. + specialize (sub (l, Z.of_nat (k + 1))). + forward sub. + apply In_add_prems. exists (l, k). split => //. + now apply in_succ_add_premises in sub. +Qed. *) + +Lemma succ_clauses_equiv cls prems concl : + succ_clauses cls ⊢ succ_prems prems → succ_expr concl -> + cls ⊢ prems → concl. +Proof. + intros ha; depind ha. + - constructor. + move: H. + rewrite In_add_prems => [] [le [hin heq]]. + move/add_expr_inj: heq. now intros ->. + - depelim H. + + destruct cl as [prems concl]. noconf H0. + eapply in_add_clauses in H as [[prems' concl'] [hin heq]]. + noconf heq. + eapply (clause_cut _ (add_prems n prems') (add_expr n concl')). 2:eapply IHha. + 2:{ f_equal. rewrite !add_expr_add_expr. now rewrite add_prems_add add_expr_add_expr Z.add_comm. } + exact: (incls cls (prems', concl') n hin). + rewrite add_prems_add_prems in H1. rewrite Z.add_comm in H1. + rewrite -(add_prems_add_prems 1 n prems') in H1. + now move/inj_add_prems_sub: H1. + + specialize (H0 (x, k + 1)). forward H0. now apply LevelExprSet.singleton_spec. + eapply In_add_prems in H0 as [[l' k'] [hin heq]]. noconf heq. + have eq: k' = k by lia. subst k'. clear H. + eapply clause_cut. 2:eapply IHha. eapply (predcl _ x (k - 1)). + 2:{ intros x'. move/LevelExprSet.singleton_spec => ->. now have -> : k - 1 + 1 = k by lia. } + f_equal. rewrite add_prems_add. f_equal. + rewrite /succ_expr //=. lia_f_equal. +Qed. + +Lemma entails_weak_list {cls prem concl concl'} : + cls ⊢ prem → concl -> + cls ⊢ add_list concl' prem → concl. +Proof. + intros hcl. + induction concl' in prem, hcl |- *. + - exact hcl. + - cbn. eapply IHconcl'. now eapply entails_weak. +Qed. + +Lemma entails_all_weak_list {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (add_list concl' prem) concl. +Proof. + intros hcl x hin. + specialize (hcl _ hin). cbn in hcl. + now eapply entails_weak_list. +Qed. + +Lemma premises_of_level_set_empty : premises_of_level_set LevelSet.empty = []. +Proof. + now rewrite /premises_of_level_set LevelSetProp.fold_empty. +Qed. + +(* Lemma succ_clauses_equiv_weak cls prems concl : + succ_clauses cls ⊢ succ_prems prems → succ_expr concl -> + cls ⊢ prems → concl. +Proof. + move/(entails_weak_list (concl' := [])) => he. + eapply (succ_clauses_equiv _ LevelSet.empty). + cbn. now rewrite premises_of_level_set_empty. +Qed. *) + +Lemma entails_all_succ_clauses cls prems concl : + succ_clauses cls ⊢a succ_prems prems → succ_prems concl -> + cls ⊢a prems → concl. +Proof. + intros ha l hin. specialize (ha (succ_expr l)). forward ha. + eapply In_add_prems. exists l. split => //. cbn in ha. + now eapply succ_clauses_equiv in ha. +Qed. + +Definition entails_equiv cls u u' := + cls ⊢a u → u' /\ cls ⊢a u' → u. + +Notation "cls '⊢a' u ↔ u'" := (entails_equiv cls u u') (at level 90). + +Lemma max_premise_of_spec_aux s l k : + max_premise_of l s = k -> + (forall k', LevelExprSet.In (l, k') s -> (k' <= k)) /\ + ((exists k', LevelExprSet.In (l, k') s /\ k = Z.max 0 k') \/ + ((~ exists k', LevelExprSet.In (l, k') s) /\ k = 0)). +Proof. + unfold max_premise_of. + revert k. + eapply LevelExprSetProp.fold_rec. + - intros s' he k <-. cbn. split => //. + * now move=> k' /he. + * right; split => //. now move=> [] k' /he. + - intros [l' k'] a s' s'' hin hnin hadd ih k. + specialize (ih _ eq_refl) as [hle hex]. + intros hmax. + split. move=> k'0 /hadd => [] []. + { move=> [=] eq eq'. subst l' k'. rewrite eqb_refl in hmax. lia. } + { move/hle. move: hmax. destruct (eqb_spec l l'); subst. lia. lia. } + destruct hex as [[k'' [hin' heq]]|nex]. subst a. + { left. destruct (eqb_spec l l'). subst. exists (Z.max k' k''); split; trea. 2:lia. eapply hadd. + destruct (Z.max_spec k' k'') as [[hlt ->]|[hle' ->]] => //. now right. now left. subst k. + exists k''; split => //. apply hadd; now right. } + destruct nex as [nex ->]. + destruct (eqb_spec l l'). subst. left. exists k'. split => //. apply hadd; now left. lia. + subst k. right. split => //. + intros [k'' hin']. apply hadd in hin' as []. noconf H0. congruence. + apply nex. now exists k''. +Qed. + + +Lemma max_premise_of_prems_max l prems : max_premise_of l prems > 0 -> LevelExprSet.In (l, max_premise_of l prems) prems. +Proof. + destruct max_premise_of eqn:maxp => //. intros _. + apply max_premise_of_spec_aux in maxp as [hle hex]. + destruct hex as [[k' [hin heq]]|hne] => //. + now have -> : Z.pos p = k' by lia. + destruct hne; lia. +Qed. + +Lemma max_premise_of_singleton l k : max_premise_of l (singleton (l, k)) = Z.max 0 k. +Proof. + remember (max_premise_of l (singleton (l, k))) as mp. symmetry in Heqmp. + apply max_premise_of_spec_aux in Heqmp as [hle hex]. + destruct hex as [[k' [hin heq]]|hne] => //. + eapply LevelExprSet.singleton_spec in hin. now noconf hin. + destruct hne as [nein ->]. elim nein. + exists k. now eapply LevelExprSet.singleton_spec. +Qed. + +Lemma max_premise_of_spec2 l k (u : univ) : LevelExprSet.In (l, k) u -> exists k', LevelExprSet.In (l, k') u /\ Z.max 0 k' = max_premise_of l u. +Proof. + remember (max_premise_of l u) as mp. symmetry in Heqmp. + apply max_premise_of_spec_aux in Heqmp as [hle hex]. + intros hin. destruct hex. firstorder. + destruct H as [nein ->]. elim nein. now exists k. +Qed. + +Lemma max_premise_of_spec_in l (u : univ) : LevelSet.In l (levels u) -> + 0 < max_premise_of l u -> + LevelExprSet.In (l, max_premise_of l u) u. +Proof. + intros hexi hpos. + remember (max_premise_of l u) as mp. symmetry in Heqmp. + apply max_premise_of_spec_aux in Heqmp as [hle hex]. + destruct hex. destruct H as [l' [hin heq]]. + now have -> : mp = l' by lia. + destruct H as [nein ->]. elim nein. + now eapply levelexprset_levels_spec in hexi. +Qed. + +Lemma of_level_map_premises_model_map cls cl V ne : + (forall l, LevelSet.In l (clause_levels cl) -> LevelSet.In l V) -> + cls ⊢a add_list (premises_of_level_set V) (premise cl) → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. +Proof. + intros hin [l k]. + rewrite of_level_map_spec. move/premises_model_map_spec; cbn. + cbn; rewrite LevelSet.union_spec. firstorder try lsets. subst. + - rewrite Z.max_comm. + destruct (Z.max_spec 0 (max_premise_of l (premise cl))) as [[hle ->]|[hge ->]]. + * constructor. rewrite add_list_spec; right. + now eapply max_premise_of_spec_in. + * constructor. rewrite add_list_spec. left. + apply premises_of_level_set_spec. split => //. + apply hin. apply clause_levels_spec. now left. + - eapply zero_model_spec in H0 as [hin' ->]. constructor. + eapply add_list_spec. left. now eapply premises_of_level_set_spec. +Qed. + +Lemma entails_all_satisfies {cls prems m hne l k} : + cls ⊢a prems → of_level_map m hne -> + infers_atom m l k -> + cls ⊢ prems → (l, k). +Proof. + intros hl hi. + eapply entails_all_one; tea. now apply infers_atom_of_level_map. +Qed. + +Lemma premises_model_map_ne V cls : + ~ LevelMap.Empty V -> + ~ LevelMap.Empty (premises_model_map V cls). +Proof. + intros ne he. apply ne. + have ne' := premises_model_map_in V cls. + intros l k hin. + specialize (ne' l). destruct ne'. forward H0. right. now exists k. + destruct H0 as [k' hin']. + now move/he: hin'. +Qed. + +Variant check_result {cls} := + | IsLooping (v : univ) (islooping : loop_on_univ cls v) + | Invalid + | Valid. +Arguments check_result : clear implicits. + +Equations check (cls : clauses) (cl : clause) : check_result (succ_clauses cls) := + check cls cl with loop_check cls (succ_clause cl) := + | Loop v isl => IsLooping v isl + | Model W v _ with LevelMap.find (concl cl).1 v.(model_model) := { + | Some val with Z.succ (concl cl).2 <=? val := + { | true => Valid + | false => Invalid } + | None => Invalid + }. + +(* If a clause checks, then it should be valid in any extension of the model *) +Lemma check_entails {cls cl} : + check cls cl = Valid -> valid_entailment cls cl. +Proof. + destruct cl as [prems [concl k]]. + funelim (check cls _) => //. + set (V := clause_levels (succ_clause _) ∪ clauses_levels cls) in *. + clear Heqcall => _. cbn [concl fst snd] in *. + unfold valid_entailment, valid_clause, level_value_above. + move/Z.leb_le: Heq => hgt. + intros valuation ext. + have vmupd := model_updates v. + have vmok := model_ok v. + set (pm := premises_model_map _ _) in *. + have nepm : ~ LevelMap.Empty pm. + { apply premises_model_map_ne. + have zm := proj2 (@zero_model_spec concl0 V 0). + forward zm. split => //. subst V. + eapply LevelSet.union_spec. left. apply clause_levels_spec. + now right. intros he. now move/he: zm. } + have nev : ~ LevelMap.Empty (model_model v). + by apply (is_update_of_non_empty nepm vmupd). + move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. + set (cl := (prems, (concl0, k))) in V. + have of_lset := of_level_map_premises_model_map (succ_clauses cls) (succ_clause cl) V nepm. + forward of_lset. + { intros l; rewrite /V LevelSet.union_spec. auto. } + have tr := entails_all_trans of_lset ent. + eapply (entails_all_satisfies (l := concl0) (k := Z.succ k)) in tr. + 2:{ red. rewrite /level_value Heq0. now constructor. } + have se := (succ_clauses_equiv cls (premise cl) (concl0, k)). + cbn in se, tr. rewrite Z.add_1_r in se. + specialize (se tr). + eapply clauses_sem_entails in se ; tea. +Qed. + +Definition invalid_entailment cls cl := + forall V, clauses_sem V cls -> clause_sem V cl -> False. + +Definition infers_univ (m : model) (u : univ) := + exists z, min_premise m u = Some z /\ (0 <= z)%Z. + +Definition infers_expr (m : model) (le : LevelExpr.t) := + let '(l, k) := le in infers_atom m l k. + +Lemma valid_clause_elim {m prems concl k} : valid_clause m (prems, (concl, k)) -> + forall z, min_premise m prems = Some z -> (0 <= z)%Z -> + Some (Z.to_nat z + k) ≤ level_value m concl. +Proof. + rewrite /valid_clause => hcl z eqmin hge. + rewrite eqmin in hcl. cbn in *. + move: hcl; elim: Z.ltb_spec => //=. + * lia. + * move=> _. rewrite /level_value_above. destruct level_value eqn:hl => //. + move/Nat.leb_le. constructor. lia. +Qed. + +Lemma valid_clause_intro {m prems concl k} : + (forall z, + min_premise m prems = Some z -> (0 <= z)%Z -> + Some (Z.to_nat z + k) ≤ level_value m concl) -> + valid_clause m (prems, (concl, k)). +Proof. + rewrite /valid_clause //=. + destruct min_premise => //. + elim: Z.ltb_spec => //= hge. + intros hz. + specialize (hz _ eq_refl hge). depelim hz. + rewrite /level_value_above H0. + now apply Nat.leb_le. +Qed. + +Lemma infers_expr_min_atom_value m le : infers_expr m le -> exists k, min_atom_value m le = Some k /\ (0 <= k)%Z. +Proof. + destruct le as [l k]; rewrite /infers_expr //=. + rewrite /infers_atom. destruct level_value => // hle; depelim hle. + eexists; split; trea. lia. +Qed. + +Lemma min_premise_add_infers m prems le : + infers_expr m le -> + forall z, min_premise m prems = Some z -> (0 <= z)%Z -> + exists z', min_premise m (add le prems) = Some z' /\ + ((min_atom_value m le = Some z' /\ (0 <= z' <= z)%Z) \/ z' = z). +Proof. + intros infe z hmin hpos. + have [hle [min' [hin hm]]] := min_premise_spec m (add le prems). + have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. + move/LevelExprSet.add_spec: hin => [heq|hin]. + - noconf heq. + eapply infers_expr_min_atom_value in infe as [z' [mineq hge]]. + rewrite mineq in hm. exists z'; split => //. + specialize (hle min''). forward hle. + { rewrite LevelExprSet.add_spec. now right. } + rewrite hm -hm' hmin in hle. now depelim hle. + - exists z. split => //. 2:right; reflexivity. rewrite hm -hmin hm'. + move: (hle' _ hin). rewrite hmin. intros h; depelim h. + rewrite H0 in hm. + specialize (hle min''). forward hle. eapply LevelExprSet.add_spec. now right. + rewrite hm in hle. rewrite -hm' hmin in hle. depelim hle. + rewrite H0 -hm' hmin. f_equal. lia. +Qed. + +Lemma fold_left_map {A B C} (f : B -> A -> A) (g : C -> B) l acc : + fold_left (fun acc l => f (g l) acc) l acc = + fold_left (fun acc l => f l acc) (map g l) acc. +Proof. + induction l in acc |- *; cbn; auto. +Qed. + +Lemma fold_left_max_acc {n l} : (forall x, In x l -> x = n) -> n = fold_left (option_map2 Z.min) l n. +Proof. + induction l in n |- *. + - now cbn. + - cbn. intros he. transitivity (option_map2 Z.min n a). 2:apply IHl. + specialize (he a). forward he. now left. subst. destruct n => //= //. lia_f_equal. + intros. have h := (he x). forward h by now right. + have h' := (he a). forward h' by now left. subst. + destruct n => //=; lia_f_equal. +Qed. + +Lemma option_map2_comm x y : option_map2 Z.min x y = option_map2 Z.min y x. +Proof. + destruct x, y; cbn; lia_f_equal. +Qed. + +Lemma option_map2_assoc x y z : + option_map2 Z.min x (option_map2 Z.min y z) = + option_map2 Z.min (option_map2 Z.min x y) z. +Proof. + destruct x, y, z; cbn; lia_f_equal. +Qed. + +Local Notation fn := (fold_left (option_map2 Z.min)). + +Lemma fold_left_impl n l : + (forall x, In x (n :: l) -> fn l n ≤Z x) /\ + (exists x, In x (n :: l) /\ fn l n = x). +Proof. + induction l in n |- *. + - cbn. split; intros. + destruct H => //. subst. reflexivity. + exists n. split => //. now left. + - cbn. split; intros. + { destruct (IHl n) as [hle [min [hin heq]]]. + rewrite fold_left_comm. + { now intros; rewrite -option_map2_assoc (option_map2_comm x0 y) option_map2_assoc. } + repeat destruct H; subst. + * specialize (hle n). forward hle. now left. + transitivity (fn l n); auto. eapply Zmin_opt_left. + * eapply Zmin_opt_right. + * transitivity (fn l n); auto. apply Zmin_opt_left. + apply hle. now right. } + * specialize (IHl (option_map2 Z.min n a)). + destruct IHl as [hle [min [hin heq]]]. subst min. eexists. split; trea. + destruct hin. + rewrite -H. + destruct n, a; cbn; firstorder. + destruct (Z.min_spec z z0) as [[? heq]|[? heq]]. + rewrite -{1}heq. now left. right; left. f_equal. lia. + now right. +Qed. + +Lemma fold_left_impl_eq n n' l l' : + (forall x, In x (n :: l) <-> In x (n' :: l' )) -> + fn l n = fn l' n'. +Proof. + intros heq. + destruct (fold_left_impl n l) as [hle [minl [hin heq']]]. + destruct (fold_left_impl n' l') as [hle' [minl' [hin' heq'']]]. + rewrite heq' heq''. + specialize (hle minl'). forward hle. now apply heq. + specialize (hle' minl). forward hle'. now apply heq. + rewrite heq'' in hle'. rewrite heq' in hle. depelim hle'. depelim hle. f_equal; lia. + now depelim hle. +Qed. + +Lemma fold_left_comm_f {A} (f : A -> A -> A) n l : + (forall x y, f x y = f y x) -> + fold_left f l n = fold_left (flip f) l n. +Proof. + induction l in n |- *; cbn; auto. + intros hf. rewrite IHl //. + unfold flip. now rewrite hf. +Qed. + +Lemma min_premise_add {m le prems} : min_premise m (add le prems) = + option_map2 Z.min (min_atom_value m le) (min_premise m prems). +Proof. + rewrite {1}/min_premise. + have hs' := to_nonempty_list_spec (add le prems). + destruct to_nonempty_list. + have eqf : (fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (min_atom_value m t)) = + (option_map2 Z.min (min_atom_value m le) (min_premise m prems)). + 2:{ now rewrite eqf. } + rewrite -(to_nonempty_list_spec' (add le prems)) in hs'. noconf hs'. + rewrite fold_left_map. rewrite fold_left_comm_f. intros [] []; cbn; auto. lia_f_equal. unfold flip. + have l := fold_left_impl_eq (min_atom_value m (to_nonempty_list (add le prems)).1) (min_atom_value m le) + (map (min_atom_value m) (to_nonempty_list (add le prems)).2) (map (min_atom_value m) (LevelExprSet.elements prems)). + rewrite l. + intros x. + { rewrite -!map_cons to_nonempty_list_spec' !in_map_iff. + split. + - move=> [] lk [] <-. + rewrite -InA_In_eq. + move/LevelExprSet.elements_spec1. + rewrite LevelExprSet.add_spec. + intros [->|inp]. + * exists le. split => //. now left. + * exists lk. split => //. right. now apply InA_In_eq, LevelExprSet.elements_spec1. + - intros [x' [<- hin]]. + exists x'. split => //. rewrite -InA_In_eq. + eapply LevelExprSet.elements_spec1. rewrite LevelExprSet.add_spec. + apply InA_In_eq in hin. depelim hin. now left. + eapply LevelExprSet.elements_spec1 in hin. now right. } + rewrite option_map2_comm. + rewrite /min_premise. + destruct (to_nonempty_list prems) eqn:he. + rewrite fold_left_map. + rewrite (fold_left_comm_f _ _ (map _ l0)). intros. apply option_map2_comm. + rewrite -(fold_left_comm (option_map2 Z.min)). + { intros. now rewrite -option_map2_assoc (option_map2_comm x y) option_map2_assoc. } + rewrite -(to_nonempty_list_spec' prems) he; cbn. + now rewrite option_map2_comm. +Qed. + +Lemma min_premise_elim m (P : univ -> option Z -> Prop): + (forall le, P (singleton le) (min_atom_value m le)) -> + (forall prems acc le, P prems acc -> ~ LevelExprSet.In le prems -> P (add le prems) (option_map2 Z.min (min_atom_value m le) acc)) -> + forall prems, P prems (min_premise m prems). +Proof. + intros hs hadd. + eapply nonEmptyLevelExprSet_elim. + - intros le. rewrite /min_premise. + rewrite singleton_to_nonempty_list. cbn. apply hs. + - intros le prems hp. now rewrite min_premise_add. +Qed. + +Lemma min_premise_add_down {m} {prems : univ} {l k} : + LevelExprSet.In (l, k + 1) prems -> + forall z, min_premise m prems = Some z -> + min_premise m (add (l, k) prems) = Some z. +Proof. + intros ine z hmin. + have [hle [min' [hin hm]]] := min_premise_spec m (add (l, k) prems). + have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. + move/LevelExprSet.add_spec: hin => [heq|hin]. + - noconf heq. + specialize (hle (l, k + 1)). + forward hle. eapply LevelExprSet.add_spec. now right. + rewrite hm in hle. + depelim hle. destruct level_value eqn:hl. noconf H0; noconf H1. lia. congruence. + destruct level_value eqn:hl' => //. + specialize (hle' _ ine). rewrite hmin in hle'; depelim hle'. + now rewrite hl' in H1. + - rewrite hm. specialize (hle' min' hin). rewrite hmin in hle'. + depelim hle'. rewrite H0. f_equal. rewrite H0 in hm. + specialize (hle min''). forward hle. eapply LevelExprSet.add_spec. now right. + rewrite hm in hle. rewrite -hm' hmin in hle. depelim hle. lia. +Qed. + + +Lemma min_premise_singleton m u : min_premise m (singleton u) = min_atom_value m u. +Proof. + now rewrite /min_premise singleton_to_nonempty_list; cbn. +Qed. + +Lemma min_atom_value_add m e x n : + min_atom_value m e = Some x -> + min_atom_value m (add_expr n e) = Some (x - Z.of_nat n)%Z. +Proof. + rewrite /min_atom_value. destruct e. cbn. + destruct level_value => //. intros [= <-]. + f_equal. lia. +Qed. + + +Lemma min_atom_value_add_inv m e x n : + min_atom_value m (add_expr n e) = Some x -> + min_atom_value m e = Some (x + Z.of_nat n)%Z. +Proof. + rewrite /min_atom_value. destruct e. cbn. + destruct level_value => //. intros [= <-]. + f_equal. lia. +Qed. + +Lemma min_premise_add_prems {m n prems z} : min_premise m prems = Some z -> min_premise m (add_prems n prems) = Some (z - Z.of_nat n)%Z. +Proof. + revert z. + eapply min_premise_elim. + - intros le hm. + destruct le as [concl k]. + rewrite add_prems_singleton min_premise_singleton. + apply min_atom_value_add. + - intros prems' acc le ih nle z hm. + destruct acc; cbn in hm. 2:{ destruct (min_atom_value m le); cbn in hm; congruence. } + specialize (ih _ eq_refl). + rewrite add_prems_add min_premise_add. + destruct (min_atom_value m le) eqn:hm'; cbn in hm => //. noconf hm. + apply (min_atom_value_add _ _ _ n) in hm'. + rewrite ih hm'. cbn. f_equal. lia. +Qed. + +Lemma min_premise_add_prems_inv {m n prems z} : min_premise m (add_prems n prems) = Some z -> + min_premise m prems = Some (z + Z.of_nat n)%Z. +Proof. + revert z. + pattern prems. + set (P := (fun n0 hm => + forall z : Z, + min_premise m (add_prems n n0) = Some z -> hm = Some (z + Z.of_nat n)%Z)). + apply (@min_premise_elim _ P); subst P; cbn. + - intros le z hm. + destruct le as [concl k]. + rewrite add_prems_singleton min_premise_singleton in hm. + now apply min_atom_value_add_inv. + - intros prems' acc le ih nle z. + rewrite add_prems_add min_premise_add. + destruct (min_premise m (add_prems n prems')) eqn:he => //=. + * destruct (min_atom_value m (add_expr n le)) eqn:ha => //=. + intros [= <-]. + eapply min_atom_value_add_inv in ha. rewrite ha. + specialize (ih _ eq_refl). subst acc. cbn. lia_f_equal. + * destruct (min_atom_value m (add_expr n le)) eqn:ha => //=. +Qed. + +Lemma level_value_above_leq {m l k} : + Some k ≤ level_value m l -> + level_value_above m l k. +Proof. + intros h; rewrite /level_value_above. + depelim h. rewrite H0. apply Nat.leb_le. lia. +Qed. + +Lemma valid_clause_shift m n cl : + valid_clause m cl -> valid_clause m (add_clause n cl). +Proof. + destruct cl as [prems [concl k]]. + move/valid_clause_elim => hv. + apply valid_clause_intro => z eqmin zpos. + eapply min_premise_add_prems_inv in eqmin. + specialize (hv _ eqmin). forward hv. lia. + etransitivity; tea. constructor; lia. +Qed. + +Lemma entails_model_valid cls cl : entails cls cl -> + forall m, is_model cls m -> valid_clause m cl. +Proof. + induction 1. + - intros m ism. + destruct concl0 as [concl k]. + apply valid_clause_intro => z hmin hge. + eapply min_premise_spec_aux in hmin as [hle [x [hin heq]]]. + specialize (hle _ H). depelim hle. + destruct level_value eqn:hl => //. noconf H1. + constructor. lia. + - intros. + specialize (IHentails m H2). + depelim H. + * destruct cl as [premsc conclc]. + noconf H0. + eapply Clauses.for_all_spec in H3. + eapply H3 in H. 2:tc. + destruct concl0 as [concl k]. + eapply valid_clause_intro => z eqmin hge. + have mins := min_premise_subset m (add_prems n premsc) prems H2. + rewrite eqmin in mins; depelim mins. + destruct conclc as [conclc k']. + have vshift : valid_clause m (add_prems n premsc, add_expr n (conclc, k')). + { now eapply (valid_clause_shift _ n) in H. } + have hv := valid_clause_elim vshift _ H4. forward hv by lia. + eapply (min_premise_add_infers _ _ (add_expr n (conclc, k'))) in eqmin as [minadd [eqminadd disj]]; tea. + 2:{ rewrite /infers_expr /infers_atom. cbn. etransitivity; tea. constructor; lia. } + move/valid_clause_elim: IHentails => //=. + move/(_ _ eqminadd). + destruct disj as [[eqmnew le']| ->]. + + cbn in eqmnew. depelim hv. rewrite H6 in eqmnew. + have : (0 <= minadd)%Z by (noconf eqmnew; lia). + move=> h /(_ h). noconf eqmnew. intros h'; depelim h'. + rewrite H8. constructor; lia. + + move/(_ hge). intros h; depelim h. rewrite H6; constructor; lia. + * destruct concl0 as [concl0 k']. + apply valid_clause_intro => z hmin hgt. + have mins := min_premise_subset m _ _ H1. + rewrite min_premise_singleton in mins. + specialize (H1 (x, k+1)); forward H1 by now apply LevelExprSet.singleton_spec. + have hadd := min_premise_add_down H1 _ hmin. + exact: valid_clause_elim IHentails _ hadd hgt. +Qed. + +Lemma check_entails_looping {cls cl v isl} : + check cls cl = IsLooping v isl -> cls ⊢a v → succ_prems v. +Proof. + funelim (check cls cl) => //. + intros [=]; subst v0. clear isl0 Heqcall. + red in isl. clear Heq; move: isl. + now move/(entails_all_shift 1)/entails_all_succ_clauses. +Qed. + +Lemma enabled_clause_ext {m m' cl} : + m ⩽ m' -> enabled_clause m cl -> enabled_clause m' cl. +Proof. + intros hext; rewrite /enabled_clause. + destruct cl as [prems [concl k]]; cbn; move=> [z [hm hpos]]. + have pr := min_premise_pres prems hext. + rewrite hm in pr. depelim pr. exists y. split => //. lia. +Qed. + +Lemma check_entails_false {cls cl} : + check cls cl = Invalid -> ~ entails cls cl. +Proof. + funelim (check cls cl) => //. + - (* Found no value for the conclusion: impossible *) + clear Heq0 Heqcall prf => _ _. + set (V := clause_levels (succ_clause cl) ∪ clauses_levels cls) in *. + destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *. + have vmupd := model_of_V v. + set (pm := premises_model_map _ _) in *. + cbn in Heq. + move/LevelMapFact.F.not_find_in_iff: Heq; apply. + apply vmupd. rewrite LevelSet.union_spec; left. + rewrite clause_levels_spec. now right. + - (* Found a value *) + set (V := clause_levels (succ_clause cl) ∪ clauses_levels cls) in *. + destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *. + rename val into conclval_v => _. clear Heq1 Heqcall prf. + unfold valid_clause, level_value_above. + move/leb_complete_conv: Heq => hgt. intro. + have vmupd := model_updates v. + have vmok := model_ok v. + set (pm := premises_model_map _ _) in *. + have nepm : ~ LevelMap.Empty pm. + { apply premises_model_map_ne. + have zm := proj2 (@zero_model_spec concl V 0). + forward zm. split => //. subst V. + eapply LevelSet.union_spec. left. apply clause_levels_spec. + now right. intros he. now move/he: zm. } + have nev : ~ LevelMap.Empty (model_model v). + by apply (is_update_of_non_empty nepm vmupd). + move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. + set (cl := (prems, (concl, k))) in V. + move/entails_plus: H. + move/entails_model_valid/(_ _ vmok). + have en : enabled_clause (model_model v) (succ_clause (prems, (concl, k))). + { apply (@enabled_clause_ext pm). + exact: is_update_of_ext (model_updates v). + red; cbn. + have hcl : Clauses.In (succ_clause cl) (Clauses.singleton (succ_clause cl)). + { now eapply Clauses.singleton_spec. } + exact: @premises_model_map_min_premise_inv V _ _ hcl. } + destruct en as [z [minp hge]]. + move/valid_clause_elim/(_ z minp hge). + cbn in minp. + rewrite /level_value Heq0 => h; depelim h. red in H. lia. +Qed. + +End LoopChecking. From 0694e0aaee573963636af505137c794fbe564db5 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 8 Sep 2025 14:04:14 +0200 Subject: [PATCH 032/164] Full formalization with partial model in Z, have to deal with negative premises --- template-rocq/theories/PartialLoopCheckingZ.v | 735 ++++++++++++------ 1 file changed, 508 insertions(+), 227 deletions(-) diff --git a/template-rocq/theories/PartialLoopCheckingZ.v b/template-rocq/theories/PartialLoopCheckingZ.v index da9470a54..6b3e2fb26 100644 --- a/template-rocq/theories/PartialLoopCheckingZ.v +++ b/template-rocq/theories/PartialLoopCheckingZ.v @@ -90,7 +90,7 @@ Module Type LoopCheckingItf (Level : LevelOrderedType) (LevelExprSet : LevelExprSet_fun Level LevelExpr) (LevelMap : FMapOTInterface Level). - Definition model := LevelMap.t Z. + Definition model := LevelMap.t (option Z). Definition valuation := LevelMap.t nat. Definition clause : Type := LevelExprSet.nonEmptyLevelExprSet × LevelExpr.t. @@ -693,9 +693,13 @@ Definition clause_conclusion cl := levelexpr_level (concl cl). Local Open Scope Z_scope. -Definition model := LevelMap.t Z. +Definition model := LevelMap.t (option Z). -Definition level_value (m : model) (level : Level.t) : option Z := LevelMap.find level m. +Definition level_value (m : model) (level : Level.t) : option Z := + match LevelMap.find level m with + | Some v => v + | None => None + end. Definition levelexpr_value (m : model) (atom : LevelExpr.t) := level_value m (levelexpr_level atom). @@ -756,7 +760,7 @@ Inductive update_result := | Holds | DoesntHold (wm : LevelSet.t × model). -Definition update_model (m : model) l v : model := LevelMap.add l v m. +Definition update_model (m : model) l v : model := LevelMap.add l (Some v) m. Definition update_value (m : model) (cl : clause) : option model := let k0 := min_premise m (premise cl) in @@ -797,7 +801,7 @@ Infix "=m" := LevelMap.Equal (at level 50). Definition strict_update m '(prems, (l, k)) m' := exists v, [/\ min_premise m prems = Some v, ~~ level_value_above m l (k + v) & - m' =m (LevelMap.add l (k + v) m)]. + m' =m (LevelMap.add l (Some (k + v)) m)]. Inductive strictly_updates cls : LevelSet.t -> model -> model -> Prop := | update_one m cl m' : Clauses.In cl cls -> @@ -1144,7 +1148,7 @@ Proof. - intros he. specialize (he (clause_conclusion cl)). destruct cl as [prems [concl k]]. destruct H0 as [? [? ? heq]]. - setoid_rewrite heq in he. eapply (he (k + x)); cbn. + setoid_rewrite heq in he. eapply (he (Some (k + x))); cbn. rewrite LevelMapFact.F.add_mapsto_iff. firstorder. - intros he. now apply IHstrictly_updates2. Qed. @@ -1244,7 +1248,7 @@ Definition in_clauses_conclusions (cls : clauses) (x : Level.t): Prop := exists cl, Clauses.In cl cls /\ (level cl.2) = x. Definition v_minus_w_bound (W : LevelSet.t) (m : model) := - LevelMap.fold (fun w v acc => Z.max v acc) + LevelMap.fold (fun w v acc => Z.max (option_get 0 v) acc) (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0%Z. Definition levelexpr_k : LevelExpr.t -> Z := snd. @@ -1303,9 +1307,7 @@ Infix "≤Z" := (opt_le Z.le) (at level 50). Definition model_rel R (m m' : model) := forall l k, LevelMap.MapsTo l k m -> exists k', LevelMap.MapsTo l k' m' /\ R k k'. -Infix "⩽" := (model_rel Z.le) (at level 70). (* \leqslant *) - -Infix "⩹" := (model_rel Z.lt) (at level 70). +Infix "⩽" := (model_rel (opt_le Z.le)) (at level 70). (* \leqslant *) Definition model_map_outside V (m m' : model) := forall l, ~ LevelSet.In l V -> @@ -1516,21 +1518,23 @@ Proof. intros m m' m'' mm' m'm'' l k map. now transitivity k'. Qed. -Lemma update_model_monotone m l k : level_value m l ≤ Some k -> m ⩽ update_model m l k. +Lemma update_model_monotone m l k : level_value m l ≤ Some k -> + m ⩽ update_model m l k. Proof. intros hl. intros l' k' maps. unfold update_model. cbn. destruct (eqb_spec l l'). - - subst l'. exists k. move: hl. + - subst l'. exists (Some k). move: hl. unfold level_value. rewrite (LevelMap.find_1 maps). intros hle. - split => //. eapply LevelMap.add_1. eapply LevelMap.OT.eq_refl. now depelim hle. - - exists k'. split => //. apply LevelMap.add_2 => //. lia. + split => //. eapply LevelMap.add_1. eapply LevelMap.OT.eq_refl. + - exists k'. split => //. apply LevelMap.add_2 => //. reflexivity. Qed. -Lemma update_model_not_above m l k : level_value_above m l k = false -> m ⩽ update_model m l k. +Lemma update_model_not_above m l k : level_value_above m l k = false -> + m ⩽ update_model m l k. Proof. unfold level_value_above. intros hlev. @@ -1539,14 +1543,14 @@ Proof. Qed. Lemma level_value_MapsTo {l k} {m : model} : - LevelMap.MapsTo l k m -> level_value m l = Some k. + LevelMap.MapsTo l k m -> level_value m l = k. Proof. unfold level_value. move=> mapto; rewrite (LevelMap.find_1 mapto) //. Qed. Lemma level_value_MapsTo' {l k} {m : model} : - level_value m l = Some k -> LevelMap.MapsTo l k m. + level_value m l = Some k -> LevelMap.MapsTo l (Some k) m. Proof. unfold level_value. destruct LevelMap.find eqn:hfind => //. eapply LevelMap.find_2 in hfind. now intros [= ->]. @@ -1563,11 +1567,12 @@ Proof. move: ha; rewrite /level_value_above. eapply level_value_MapsTo in hin. rewrite hin. intros hlt'. - exists (k + v). + exists (Some (k + v)). split. left. split; reflexivity. move/negbTE: hlt'. - elim: Z.leb_spec => //. lia. - exists k'. split => //. right; eauto. lia. + destruct k' => //. + elim: Z.leb_spec => //. intros; constructor; lia. constructor. + exists k'. split => //. right; eauto. reflexivity. Qed. Lemma strictly_updates_ext cls w m m' : strictly_updates cls w m m' -> m ⩽ m'. @@ -1617,7 +1622,7 @@ Proof. unfold level_value. destruct LevelMap.find eqn:hl => //. - apply LevelMap.find_2 in hl. specialize (lem _ hl) as [k' [mapsto leq]]. - rewrite (LevelMap.find_1 mapsto). now constructor. + now rewrite (LevelMap.find_1 mapsto). - constructor. Qed. @@ -2048,7 +2053,7 @@ Proof. rewrite (LevelMap.find_1 H) //. destruct (LevelMap.find _ m) eqn:hl' => //. eapply LevelMap.find_2 in hl'. - assert (LevelMap.MapsTo x z fm). + assert (LevelMap.MapsTo x o fm). eapply LevelMapFact.filter_iff. tc. split => //. now rewrite [_ = true]not_mem. now rewrite (LevelMap.find_1 H) in hl. } @@ -2063,7 +2068,9 @@ Proof. unfold level_value. cbn. rewrite hadd LevelMapFact.F.add_o. destruct LevelMap.OT.eq_dec. do 2 red in e0. subst x. - intros hf. constructor. lia. + destruct LevelMap.find eqn:heq. + apply LevelMap.find_2 in heq. elim nin. now exists o. + intros _. destruct e; constructor; cbn. lia. destruct LevelMap.find => hf; depelim hf; constructor; lia. Qed. @@ -2121,6 +2128,9 @@ Qed. Definition model_of V (m : model) := forall k, LevelSet.In k V -> LevelMap.In k m. +Definition defined_model_of V (m : model) := + forall l, LevelSet.In l V -> exists k, LevelMap.MapsTo l (Some k) m. + Definition only_model_of V (m : model) := forall k, LevelSet.In k V <-> exists x, LevelMap.MapsTo k x m. @@ -2150,22 +2160,23 @@ Proof. lsets. Qed. -Lemma level_value_above_MapsTo m l k : level_value_above m l k -> exists k', LevelMap.MapsTo l k' m /\ (k <= k'). +Lemma level_value_above_MapsTo m l k : level_value_above m l k -> exists k', LevelMap.MapsTo l k' m /\ (Some k ≤ k'). Proof. unfold level_value_above. destruct level_value eqn:hl => //. - move/Z.leb_le => hle; exists z. - eapply level_value_MapsTo' in hl. split => //. + move/Z.leb_le => hle; exists (Some z). + eapply level_value_MapsTo' in hl. split => //. now constructor. Qed. -Lemma level_value_above_MapsTo' m l k k' : LevelMap.MapsTo l k' m -> (k <= k') -> level_value_above m l k. +Lemma level_value_above_MapsTo' m l k k' : LevelMap.MapsTo l k' m -> (Some k ≤ k') -> level_value_above m l k. Proof. unfold level_value_above. intros H; apply LevelMap.find_1 in H. rewrite /level_value H. - now apply Z.leb_le. + destruct k'. intros h; depelim h. + now apply Z.leb_le. intros h; depelim h. Qed. -Lemma level_value_add m l k : level_value (LevelMap.add l k m) l = Some k. +Lemma level_value_add m l k : level_value (LevelMap.add l (Some k) m) l = Some k. Proof. rewrite /level_value LevelMapFact.F.add_eq_o //. Qed. @@ -2252,11 +2263,11 @@ Lemma model_of_update w m l k : model_of w m -> model_of (LevelSet.add l w) (upd Proof. rewrite /model_of => hint l'. rewrite LevelSet.add_spec. intros [->|hadd]. - - exists k. now apply LevelMap.add_1. + - exists (Some k). now apply LevelMap.add_1. - specialize (hint _ hadd). unfold update_model. destruct hint as [x hx]. destruct (eqb_spec l l'). subst. - now exists k; apply LevelMap.add_1. + now exists (Some k); apply LevelMap.add_1. now exists x; eapply LevelMap.add_2. Qed. @@ -2346,7 +2357,7 @@ Proof. 2:{ unfold min_atom_value. destruct min'. unfold level_value. destruct (LevelMap.find t m) eqn:hfind. 2:constructor. apply LevelMap.find_2 in hfind. apply ext in hfind as [k' [hfind hle]]. - apply LevelMap.find_1 in hfind. rewrite hfind. constructor. lia. + apply LevelMap.find_1 in hfind. rewrite hfind. depelim hle; constructor. lia. } destruct min'. specialize (leq _ _ H) as [? []]. unfold min_atom_value at 2. rewrite H1. rewrite -eqminz. constructor. lia. @@ -2356,7 +2367,7 @@ Lemma level_value_above_mon m m' l k : m ⩽ m' -> level_value_above m l k -> le Proof. intros ext; move/level_value_above_MapsTo => [v [hm hleq]]. eapply ext in hm. destruct hm as [v' [hm' leq']]. - eapply level_value_above_MapsTo'; tea. lia. + eapply level_value_above_MapsTo'; tea. transitivity v => //. Qed. Lemma model_of_subset V V' m : @@ -2465,6 +2476,16 @@ Qed. Lemma model_of_value_None W m l : model_of W m -> LevelSet.In l W -> + LevelMap.find l m = None -> False. +Proof. + intros tm inw. specialize (tm l inw) as [v hm]. + rewrite /level_value. + now rewrite (LevelMap.find_1 hm). +Qed. + +Lemma defined_model_of_value_None W m l : + defined_model_of W m -> + LevelSet.In l W -> level_value m l = None -> False. Proof. intros tm inw. specialize (tm l inw) as [v hm]. @@ -2473,7 +2494,7 @@ Proof. Qed. Lemma invalid_clause_measure W cls cl m : - model_of W m -> + defined_model_of W m -> ~~ valid_clause m cl -> Clauses.In cl (cls_diff cls W) -> (0 < measure_w W cls m (concl cl))%Z. @@ -2499,7 +2520,7 @@ Proof. unfold gain; cbn. enough ((level_value_default m l) < (v_minus_w_bound W m) + (k - premise_min preml))%Z. lia. unfold level_value_default. destruct (level_value m l) as [vl|] eqn:hl; revgoals. - { eapply model_of_value_None in hl; tea => //. + { eapply defined_model_of_value_None in hl; tea => //. eapply Clauses.diff_spec in hin as [hin _]. now apply in_clauses_with_concl in hin as [hin _]. } depelim hlt. @@ -3290,6 +3311,14 @@ Proof. intros k hin. destruct (mof k hin). specialize (ext _ _ H) as [k' []]. now exists k'. Qed. +Lemma defined_model_of_ext {W m m'} : + defined_model_of W m -> m ⩽ m' -> defined_model_of W m'. +Proof. + intros mof ext. + intros k hin. destruct (mof k hin). specialize (ext _ _ H) as [k' []]. + depelim H1. now exists y. +Qed. + Lemma valid_model_total W W' m cls : forall vm : valid_model W W' m cls, model_of W m -> model_of W (model_model vm). Proof. @@ -3321,6 +3350,14 @@ Proof. setoid_rewrite LevelSet.union_spec. firstorder. Qed. +Lemma defined_model_of_union_inv U V cls : + defined_model_of (LevelSet.union U V) cls -> + defined_model_of U cls /\ defined_model_of V cls. +Proof. + rewrite /defined_model_of. + setoid_rewrite LevelSet.union_spec. firstorder. +Qed. + Lemma strictly_updates_model_of_gen cls W m m' : strictly_updates cls W m m' -> forall W', model_of W' m -> model_of (LevelSet.union W' W) m'. @@ -3372,7 +3409,7 @@ Proof. setoid_rewrite LevelMapFact.F.add_mapsto_iff. cbn. destruct (Level.eq_dec concl x). { subst. rewrite LevelSet.union_spec LevelSet.singleton_spec. - firstorder; exists (cl + minv); left; split => //. } + firstorder; exists (Some (cl + minv)); left; split => //. } { rewrite LevelSet.union_spec LevelSet.singleton_spec /LevelSet.E.eq. firstorder. subst x. congruence. } - intros W' tot. @@ -3393,7 +3430,7 @@ Lemma strict_update_modify m cl m' : strict_update m cl m' -> Proof. rewrite /strict_update. destruct cl as [prems [concl k]]. - intros [v [hmin hab eq]]. now exists (k + v). + intros [v [hmin hab eq]]. now exists (Some (k + v)). Qed. Lemma strictly_updates_model_of {cls W m m'} : @@ -3488,7 +3525,7 @@ Proof. apply strictly_updates_ext in su2. depelim H2; rewrite ?H3. 2:{ rewrite H2; constructor. } eapply level_value_MapsTo', su2 in H4 as [k' [map le]]. - eapply level_value_MapsTo in map. rewrite map. constructor; lia. + eapply level_value_MapsTo in map. rewrite map. depelim le. constructor; lia. - constructor. now eapply strictly_updates_ext. clear -mof su. induction su. @@ -3582,7 +3619,7 @@ Definition max_premise_model cls sel m := LevelMap.MapsTo l (max_clause_premise cls) m) /\ (forall l k, LevelMap.MapsTo l k m -> LevelSet.In l (sel cls) /\ k = max_clause_premise cls). -Definition max_premise_map cls : model := +(* Definition max_premise_map cls : model := let max := max_clause_premise cls in let ls := clauses_levels cls in LevelSet.fold (fun l acc => LevelMap.add l max acc) ls (LevelMap.empty _). @@ -3608,7 +3645,7 @@ Proof. eapply LevelMapFact.F.add_mapsto_iff in H3 as []. * destruct H3. noconf H4. split => //. apply H1. now left. * destruct H3. firstorder. -Qed. +Qed. *) Lemma infer_atom_downward {m l k k'} : infers_atom m l k -> @@ -3628,20 +3665,21 @@ Proof. rewrite /infers_atom. intros infa le. depelim infa. eapply level_value_MapsTo' in H0. eapply le in H0 as [k' [hm hle]]. - rewrite (level_value_MapsTo hm). constructor; lia. + rewrite (level_value_MapsTo hm). depelim hle; constructor; lia. Qed. Lemma infers_atom_mapsto m l k : infers_atom m l k <-> - exists k', LevelMap.MapsTo l k' m /\ (k <= k'). + exists k', LevelMap.MapsTo l k' m /\ (Some k ≤ k'). Proof. rewrite /infers_atom; split. - intros hle; depelim hle. - eapply level_value_MapsTo' in H0. exists y. split => //. + eapply level_value_MapsTo' in H0. exists (Some y). split => //. + now constructor. - intros [k' [hm hle]]. - eapply level_value_MapsTo in hm. rewrite hm. now constructor. + eapply level_value_MapsTo in hm. now rewrite hm. Qed. -Lemma above_max_premise_model_infers {cls m} : +(* Lemma above_max_premise_model_infers {cls m} : above_max_premise_model cls m -> (forall l, LevelSet.In l (clauses_levels cls) -> infers_atom m l (max_clause_premise cls)). Proof. @@ -3655,7 +3693,7 @@ Proof. now eapply H. reflexivity. * subst m. eapply infers_atom_mapsto. destruct hm. specialize (H l hl). eexists; split. exact H. lia. -Qed. +Qed. *) Lemma clauses_with_concl_union cls W W' : Clauses.Equal (clauses_with_concl cls (LevelSet.union W W')) @@ -3687,14 +3725,14 @@ Section InnerLoop. Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := sum_W W (fun w => Z.to_nat (measure_w W cls m w)). - Lemma maps_to_value_default {x k m} : LevelMap.MapsTo x k m -> level_value m x = Some k. + Lemma maps_to_value_default {x k m} : LevelMap.MapsTo x k m -> level_value m x = k. Proof. intros h; apply LevelMap.find_1 in h. now rewrite /level_value h. Qed. Lemma measure_model W cls m : - model_of W m -> + defined_model_of W m -> let clsdiff := cls_diff cls W in measure W cls m = 0%nat -> is_model clsdiff m. Proof using. @@ -3711,7 +3749,8 @@ Section InnerLoop. intros l hin. specialize (hv _ inw) as [k lv]. rewrite /level_value_default (maps_to_value_default lv) in heq. apply hadd in hin as []. - * subst x. rewrite (maps_to_value_default lv). constructor. lia. + * subst x. rewrite (maps_to_value_default lv). + constructor. lia. * now apply ih. } clear hm. eapply ClausesFact.for_all_iff. tc. @@ -3789,15 +3828,15 @@ Section InnerLoop. Qed. Lemma level_values_in_W m m' W x : - model_of W m -> + defined_model_of W m -> m ⩽ m' -> LevelSet.In x W -> level_value m x ≤ level_value m' x -> exists k k', level_value m x = Some k /\ level_value m' x = Some k' /\ (k <= k'). Proof. intros hwv ext hin hleq. specialize (hwv _ hin) as x'. destruct x' as [k hl]. rewrite (maps_to_value_default hl) in hleq. - eapply w_values_ext in hwv; tea. - specialize (hwv _ hin) as [k' hl']. + eapply defined_model_of_ext in ext; tea. + specialize (ext _ hin) as [k' hl']. rewrite (maps_to_value_default hl') in hleq. depelim hleq. do 2 eexists. intuition eauto. now rewrite (maps_to_value_default hl). @@ -3805,7 +3844,7 @@ Section InnerLoop. Qed. Lemma measure_le {W cls m m'} : - model_of W m -> + defined_model_of W m -> model_map_outside W m m' -> m ⩽ m' -> (measure W cls m' <= measure W cls m)%nat. @@ -3822,7 +3861,7 @@ Section InnerLoop. Qed. Lemma measure_lt {W cls m m'} : - model_of W m -> + defined_model_of W m -> model_map_outside W m m' -> m ⩽ m' -> (exists l, [/\ LevelSet.In l W, (0 < measure_w W cls m l)%Z & @@ -3851,7 +3890,7 @@ Section InnerLoop. intros acc acc' accle. eapply Nat.add_le_lt_mono => //. depelim hlev. rewrite /level_value_default ?H0 ?H1 in hbound |- *. - lia. now eapply model_of_value_None in H; tea. + lia. now eapply defined_model_of_value_None in H; tea. Qed. Lemma is_model_equal {cls cls' m} : Clauses.Equal cls cls' -> is_model cls m -> is_model cls' m. @@ -4064,7 +4103,7 @@ Section InnerLoop. rewrite H. exists x1. now rewrite eq -eq'. Qed. - Inductive findSpec l m : option Z -> Prop := + Inductive findSpec l m : option (option Z) -> Prop := | inm k : LevelMap.MapsTo l k m -> findSpec l m (Some k) | ninm : ~ LevelMap.In l m -> findSpec l m None. @@ -4155,6 +4194,14 @@ Section InnerLoop. apply LevelMapFact.F.not_find_in_iff in he. firstorder. congruence. Qed. + Lemma levelmap_level_value_eq x (m m' : model) : + (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> + level_value m x = level_value m' x. + Proof. + intros he. + rewrite /level_value. rewrite (levelmap_find_eq x m m') //. + Qed. + Lemma levelmap_find_eq_inv {A} x (m m' : LevelMap.t A) : LevelMap.find x m = LevelMap.find x m' -> (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m'). @@ -4179,7 +4226,7 @@ Section InnerLoop. intros hin. rewrite (@min_premise_preserved _ m) //. move=> x. rewrite levelexprset_levels_spec => [] [k] /hin inW. - apply levelmap_find_eq => k'. + apply levelmap_level_value_eq => k'. rewrite restrict_model_spec. firstorder. Qed. @@ -4397,7 +4444,7 @@ Section InnerLoop. Lemma union_idem cls : Clauses.Equal (Clauses.union cls cls) cls. Proof. intros ?; rewrite Clauses.union_spec. firstorder. Qed. - Lemma above_max_premise_model_trans {cls V' m m'} : + (* (* Lemma above_max_premise_model_trans {cls V' m m'} : above_max_premise_model cls m -> strictly_updates cls V' m m' -> above_max_premise_model cls m'. @@ -4407,7 +4454,7 @@ Section InnerLoop. rewrite union_idem in tr. now left; eexists. * left; exists V'. now subst. - Qed. + Qed. *) Lemma max_clause_premise_spec2 cls : (exists cl, Clauses.In cl cls /\ max_clause_premise cls = Z.max (premise_max (premise cl)) 0) \/ @@ -4424,8 +4471,8 @@ Section InnerLoop. { exists x. firstorder. lia. } * destruct ih. left. exists x. split; firstorder. subst. lia. - Qed. - + Qed. *) +(* Lemma max_clause_premise_mon {cls cls'} : cls ⊂_clset cls' -> (max_clause_premise cls <= max_clause_premise cls'). @@ -4439,7 +4486,7 @@ Section InnerLoop. - rewrite hs'. apply hincl in hin. now eapply he' in hin. - rewrite hs. lia. - lia. - Qed. + Qed. *) Lemma update_total_model W m m' : @@ -4540,14 +4587,21 @@ Section InnerLoop. intros [incl inprems incls]. rewrite clause_levels_spec. move=> [] hin. - apply inprems in hin. - rewrite /level_value. - apply levelmap_find_eq => k. + apply levelmap_level_value_eq => k. rewrite model_update_spec. clear -mW om hin. firstorder. - - subst x. apply levelmap_find_eq => k. + - subst x. apply levelmap_level_value_eq => k. rewrite model_update_spec. cbn in *. firstorder. cbn in H. apply om in incl as [x hm]. now apply H in hm. Qed. + Lemma strictly_updates_defined_model cls W m m' : + strictly_updates cls W m m' -> + defined_model_of W m'. + Proof. + induction 1. + - cbn. + Admitted. + Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) (loop : forall (V' U' : LevelSet.t) (cls' : clauses) (minit m : model) (prf : [/\ clauses_levels cls' ⊂_lset V', only_model_of V' minit & @@ -4618,12 +4672,14 @@ Section InnerLoop. destruct hm as [cll [hind nvalid inwconcl hl]]. eapply Nat.lt_le_trans with (measure W cls (model_update m (model_model mr))). 2:{ eapply measure_le; eauto; try eapply mr; tea. - - now eapply strictly_updates_total_model in upd. + - eapply strictly_updates_defined_model; tea. - apply model_map_outside_update. eapply valid_model_only_model. now eapply strictly_updates_restrict_only_model. - eapply is_update_of_ext. have mof := strictly_updates_model_of upd. apply: valid_model_is_update_of_eq _ _ _ _ cls mof mr eqprem. } + have isdef : defined_model_of W (model_update m (model_model mr)). + { apply (todo "defined model"). } eapply measure_lt; tea. { eapply model_map_outside_weaken. eapply hext. have incl := model_incl mr. lsets. } { apply hext. } @@ -4801,9 +4857,9 @@ Lemma max_min max min k : min <= 0 -> max >= 0 -> k <= max -> k >= min -> (max - Proof. lia. Qed. Definition model_min m := - LevelMap.fold (fun l k acc => Z.min acc k) m 0. + LevelMap.fold (fun l k acc => Z.min acc (option_get 0 k)) m 0. -Lemma model_min_spec m : forall l k, LevelMap.MapsTo l k m -> (model_min m <= k)%Z. +Lemma model_min_spec m : forall l k, LevelMap.MapsTo l (Some k) m -> (model_min m <= k)%Z. Proof. intros l k hm. rewrite /model_min. @@ -4814,7 +4870,7 @@ Proof. eapply levelmap_find_eq_inv in hadd. eapply hadd in hm''. rewrite LevelMapFact.F.add_mapsto_iff in hm''. move: hm''=> [] [h h']. - * subst k. lia. + * subst e. cbn. lia. * move/hle: h'. lia. Qed. @@ -4828,9 +4884,9 @@ Proof. Qed. Definition model_max m := - LevelMap.fold (fun l k acc => Z.max acc k) m 0. + LevelMap.fold (fun l k acc => Z.max acc (option_get 0 k)) m 0. -Lemma model_max_spec m : forall l k, LevelMap.MapsTo l k m -> (k <= model_max m)%Z. +Lemma model_max_spec m : forall l k, LevelMap.MapsTo l k m -> (k ≤ Some (model_max m)). Proof. intros l k hm. rewrite /model_max. @@ -4841,8 +4897,8 @@ Proof. eapply levelmap_find_eq_inv in hadd. eapply hadd in hm''. rewrite LevelMapFact.F.add_mapsto_iff in hm''. move: hm''=> [] [h h']. - * subst k. lia. - * move/hle: h'. lia. + * subst k. destruct e; constructor. cbn. lia. + * move/hle: h'. intros h'; depelim h'; constructor; lia. Qed. Lemma model_max_spec2 m : (0 <= model_max m)%Z. @@ -4856,10 +4912,10 @@ Qed. Definition valuation_of_model (m : model) : LevelMap.t nat := let max := model_max m in let min := model_min m in - LevelMap.fold (fun l k acc => LevelMap.add l (Z.to_nat (max - k - min)) acc) m (LevelMap.empty _). + LevelMap.fold (fun l k acc => LevelMap.add l (Z.to_nat (max - option_get 0 k - min)) acc) m (LevelMap.empty _). Lemma valuation_of_model_spec m : - forall l k, LevelMap.MapsTo l k m -> + forall l k, LevelMap.MapsTo l (Some k) m -> let v := (model_max m - k - model_min m)%Z in LevelMap.MapsTo l (Z.to_nat v) (valuation_of_model m). Proof. @@ -4922,7 +4978,7 @@ Proof. Qed. Lemma strictly_updates_all cls V minit m : strictly_updates cls V minit m -> - (forall l k, LevelSet.In l V -> LevelMap.MapsTo l k minit -> exists k', LevelMap.MapsTo l k' m /\ Z.lt k k'). + (forall l k, LevelSet.In l V -> LevelMap.MapsTo l k minit -> exists k', LevelMap.MapsTo l (Some k') m /\ opt_le Z.lt k (Some k')). Proof. induction 1. - intros l k hin hm. @@ -4933,26 +4989,27 @@ Proof. intros hle eq. setoid_rewrite eq. eexists. setoid_rewrite LevelMapFact.F.add_mapsto_iff. split; [left;split;eauto|] => //. destruct level_value eqn:hl => //. - * rewrite (level_value_MapsTo hm) in hl. noconf hl. lia. - * rewrite (level_value_MapsTo hm) in hl. noconf hl. + * rewrite (level_value_MapsTo hm) in hl. noconf hl. constructor. lia. + * rewrite (level_value_MapsTo hm) in hl. noconf hl. constructor. - intros l k; rewrite LevelSet.union_spec; move=> [] hin hm. apply IHstrictly_updates1 in hm as [k' [hle hm']]; tea. eapply strictly_updates_ext in H0. apply H0 in hle as [k'' [hm'' lek'']]. - exists k''. split => //. lia. + depelim lek''. + exists y. split => //. depelim hm'; constructor; lia. eapply strictly_updates_ext in H. eapply H in hm as [k' [hm' lek']]. eapply IHstrictly_updates2 in hm' as [k'' [hm'' lek'']]; tea. - exists k''. split => //. lia. + exists k''. split => //. depelim lek'; depelim lek''; constructor; lia. Qed. Lemma strictly_updates_zero_model cls V mzero m : - (forall l, LevelSet.In l V -> LevelMap.MapsTo l 0%Z mzero) -> + (forall l, LevelSet.In l V -> LevelMap.MapsTo l (Some 0%Z) mzero) -> strictly_updates cls V mzero m -> - forall l, LevelSet.In l V -> exists k, LevelMap.MapsTo l k m /\ (0 < k)%Z. + forall l, LevelSet.In l V -> exists k, LevelMap.MapsTo l (Some k) m /\ (0 < k)%Z. Proof. intros ho. move/strictly_updates_all => ha l hin. eapply ha in hin; revgoals. now apply ho. - destruct hin as [k' [hm hle]]. + destruct hin as [k' [hm hle]]. depelim hle. now exists k'. Qed. @@ -4978,13 +5035,14 @@ Definition model_domain (m : model) V := Definition model_rel_partial R V (m m' : model) := forall l, (LevelSet.In l V -> forall k, LevelMap.MapsTo l k m -> - exists k', LevelMap.MapsTo l k' m' /\ R k k') /\ + exists k', LevelMap.MapsTo l k' m' /\ opt_le R k k') /\ (~ LevelSet.In l V -> forall k, LevelMap.MapsTo l k m <-> LevelMap.MapsTo l k m'). Lemma model_of_sext {R W W' m m'} : model_of W m -> model_of W' m -> - model_rel_partial R W m m' -> model_of W' m'. + model_rel_partial R W m m' -> + model_of W' m'. Proof. intros mof mof' ext. intros l hin. @@ -4995,6 +5053,21 @@ Proof. exists x. now apply lout. Qed. +Lemma defined_model_of_sext {R W W' m m'} : + defined_model_of W m -> + defined_model_of W' m -> + model_rel_partial R W m m' -> + defined_model_of W' m'. +Proof. + intros mof mof' ext. + intros l hin. + destruct (mof' l hin). specialize (ext l) as [lin lout]. + destruct (inLevelSet W l) as [hin'|hout]. + - specialize (lin hin' _ H). firstorder. depelim H1. now exists y. + - specialize (lout hout (Some x)). + exists x. now apply lout. +Qed. + Lemma not_in_union_inv l ls ls' : ~ LevelSet.In l (LevelSet.union ls ls') -> ~ LevelSet.In l ls /\ ~ LevelSet.In l ls'. @@ -5050,11 +5123,11 @@ Proof. destruct H0 as [minp [hmin nabove hm']]. eapply LevelSet.singleton_spec in inv; red in inv; subst l. eapply LevelMapFact.F.MapsTo_fun in hin; tea. noconf hin. - exists (conclk + minp). split => //. + exists (Some (conclk + minp)). split => //. rewrite hm'. rewrite LevelMapFact.F.add_mapsto_iff. left. split => //. move/negbTE: nabove; move/level_value_not_above_spec. - rewrite (level_value_MapsTo mt). now intros x; depelim x. + now rewrite (level_value_MapsTo mt). - move/model_of_union_inv => [] totls totls'. forward IHsu1 by auto. forward IHsu2. @@ -5073,42 +5146,89 @@ Proof. intros H. apply H, in_singleton. Qed. +Definition defined_map (m : LevelMap.t (option Z)) := + exists l k, LevelMap.MapsTo l (Some k) m. + +Lemma levelmap_add_spec {A} (m m' : LevelMap.t A) {k v}: + LevelMapFact.Add k v m m' -> + m' =m LevelMap.add k v m. +Proof. + trivial. +Qed. + #[program] -Definition of_level_map (m : LevelMap.t Z) (hne : ~ LevelMap.Empty m) : nonEmptyLevelExprSet := - {| t_set := LevelMap.fold (fun l k acc => LevelExprSet.add (l, k) acc) m LevelExprSet.empty |}. +Definition of_level_map (m : LevelMap.t (option Z)) (hne : defined_map m) : nonEmptyLevelExprSet := + {| t_set := LevelMap.fold (fun l k acc => + if k is (Some k') return _ then LevelExprSet.add (l, k') acc else acc) m LevelExprSet.empty |}. Next Obligation. apply not_Empty_is_empty. move: hne. eapply LevelMapFact.fold_rec. firstorder. intros. rewrite /LevelExprSet.Empty. - rw LevelExprSet.add_spec. intros ha. apply (ha (k, e)). now left. + intros ha. destruct e eqn:he. + - specialize (ha (k, z)). apply ha; apply LevelExprSet.add_spec. now left. + - destruct hne as [witl [witk hin]]. + apply levelmap_add_spec in H1. rewrite H1 in hin. + rewrite LevelMapFact.F.add_mapsto_iff in hin; + destruct hin as [[? eq]|[new hm]]; try congruence. + eapply H2. now exists witl, witk. exact ha. +Qed. + +Lemma mapsto_some_add_none l k l' (m : model) : + LevelMap.MapsTo l (Some k) (LevelMap.add l' None m) <-> + LevelMap.MapsTo l (Some k) m /\ l <> l'. +Proof. + rewrite LevelMapFact.F.add_mapsto_iff. + firstorder. congruence. congruence. Qed. Lemma of_level_map_spec m hne : - forall l k, LevelExprSet.In (l, k) (of_level_map m hne) <-> LevelMap.MapsTo l k m. + forall l k, LevelExprSet.In (l, k) (of_level_map m hne) <-> LevelMap.MapsTo l (Some k) m. Proof. intros l k; rewrite /of_level_map //=. clear hne. have : forall acc, LevelExprSet.In (l, k) - (LevelMap.fold (fun (l0 : LevelMap.key) k0 (acc : LevelExprSet.t) => LevelExprSet.add (l0, k0) acc) m acc) <-> - LevelMap.MapsTo l k m \/ LevelExprSet.In (l, k) acc. + (LevelMap.fold (fun (l0 : LevelMap.key) k0 (acc : LevelExprSet.t) => + if k0 is (Some k') then LevelExprSet.add (l0, k') acc else acc) m acc) <-> + LevelMap.MapsTo l (Some k) m \/ LevelExprSet.In (l, k) acc. move=> acc; eapply LevelMapFact.fold_rec. - firstorder. - - intros. rewrite LevelExprSet.add_spec H2. - split. - * intros [eq|hm]. - + noconf eq. specialize (H1 l). eapply levelmap_find_eq_inv in H1. - erewrite H1. left. apply LevelMapFact.F.add_mapsto_iff. left => //. - + specialize (H1 l). eapply levelmap_find_eq_inv in H1; erewrite H1. - rewrite LevelMapFact.F.add_mapsto_iff. - destruct (eq_dec l k0); subst; firstorder. - * intros hm'. destruct hm'. - + specialize (H1 l). eapply levelmap_find_eq_inv in H1. eapply H1 in H3. - apply LevelMapFact.F.add_mapsto_iff in H3. destruct H3. firstorder; subst. left. red. red in H3. subst. reflexivity. - unfold LevelExprSet.E.eq. destruct H3. now right; left. - + unfold LevelExprSet.E.eq. now right. + - intros. + destruct e eqn:he. + { rewrite LevelExprSet.add_spec H2. + split. + * intros [eq|hm]. + + noconf eq. specialize (H1 l). eapply levelmap_find_eq_inv in H1. + erewrite H1. left. apply LevelMapFact.F.add_mapsto_iff. left => //. + + specialize (H1 l). eapply levelmap_find_eq_inv in H1; erewrite H1. + rewrite LevelMapFact.F.add_mapsto_iff. + destruct (eq_dec l k0); subst; firstorder. exact None. + * intros hm'. destruct hm'. + + specialize (H1 l). eapply levelmap_find_eq_inv in H1. eapply H1 in H3. + apply LevelMapFact.F.add_mapsto_iff in H3. destruct H3. firstorder; subst. left. red. red in H3. subst. + noconf H6; reflexivity. + unfold LevelExprSet.E.eq. destruct H3. now right; left. + + unfold LevelExprSet.E.eq. now right. } + { rewrite H2. clear H2; apply levelmap_add_spec in H1; rewrite H1. + rewrite mapsto_some_add_none. firstorder. cbn in H0. + destruct (eq_dec l k0). + * subst. cbn in H0. firstorder. + * left. auto. } - intros. rewrite H. firstorder. lesets. Qed. +Lemma strictly_updates_defined_map {cls W m m'} : + strictly_updates cls W m m' -> defined_map m'. +Proof. + induction 1. + - exists (clause_conclusion cl). + destruct cl as [prems [concl k]]. + destruct H0 as [? [? ? heq]]. cbn. + setoid_rewrite heq. exists (k + x); cbn. + rewrite LevelMapFact.F.add_mapsto_iff. firstorder. + - assumption. +Qed. + + Definition premise_values (prems : univ) m := NonEmptySetFacts.map (fun '(l, k) => (l, option_get 0 (level_value m l))) prems. @@ -5123,7 +5243,7 @@ Proof. Qed. Definition hyps_map (hyps : univ) m := - (forall (l : Level.t) k, LevelExprSet.In (l, k) hyps <-> LevelMap.MapsTo l k m). + (forall (l : Level.t) k, LevelExprSet.In (l, k) hyps <-> LevelMap.MapsTo l (Some k) m). Lemma model_hyps_entails cls m hyps (prems : univ) concl : Clauses.In (prems, concl) cls -> @@ -5182,7 +5302,7 @@ Proof. rewrite H1 in minsleq. depelim minsleq. lia. Qed. -Lemma strictly_updates_entails {cls V mzero m} (hne : ~ LevelMap.Empty mzero) (hne' : ~ LevelMap.Empty m) : +Lemma strictly_updates_entails {cls V mzero m} (hne : defined_map mzero) (hne' : defined_map m) : strictly_updates cls V mzero m -> entails_all cls (of_level_map mzero hne) (of_level_map m hne'). Proof. @@ -5198,7 +5318,7 @@ Proof. intros [l k'] hin. eapply of_level_map_spec in hin. rewrite eqm' in hin. rewrite LevelMapFact.F.add_mapsto_iff in hin. - destruct hin as [[eq heq]|[neq hm]]. subst k'. + destruct hin as [[eq heq]|[neq hm]]. noconf heq. have hypss := of_level_map_spec m hne. set (hyps := of_level_map m hne) in *. clearbody hyps. have entailscl : entails cls (prems, (concl, k)) by exact: entails_in H. @@ -5210,7 +5330,7 @@ Proof. (* rewrite hmin. lia_f_equal. *) (* have -> : k + (z - mink) = k + (z - mink) by lia. now red in eq; subst concl. *) constructor. now rewrite of_level_map_spec. - - have hnemid : ~ LevelMap.Empty m'. by exact: strictly_updates_non_empty_map su1. + - have hnemid : defined_map m'. by exact: strictly_updates_defined_map su1. specialize (IHsu1 hne hnemid). specialize (IHsu2 hnemid hne'). eapply entails_all_trans; tea. @@ -5224,7 +5344,7 @@ Proof. now apply LevelSet.choose_spec2 in ch. Qed. -Lemma of_level_map_of_level_set cls sel V m hne hne' : +(* Lemma of_level_map_of_level_set cls sel V m hne hne' : max_premise_model cls sel m -> V =_lset sel cls -> of_level_map m hne = of_level_set V (max_clause_premise cls) hne'. @@ -5235,7 +5355,7 @@ Proof. move/(proj2 mp l) => [hin eq]. split. 2:lia. lsets. move=> [] inl ->. rewrite hv in inl. now apply mp. -Qed. +Qed. *) Lemma infers_atom_of_level_map {cls m hne l k} : infers_atom m l k -> @@ -5251,7 +5371,7 @@ Proof. rewrite Z2Nat.id. lia. reflexivity. Qed. -Lemma of_level_map_entails_of_level_set cls V m hne hne' : +(* Lemma of_level_map_entails_of_level_set cls V m hne hne' : above_max_premise_model cls m -> V ⊂_lset clauses_levels cls -> cls ⊢a of_level_map m hne → of_level_set V (max_clause_premise cls) hne'. @@ -5263,7 +5383,7 @@ Proof. have hi := above_max_premise_model_infers mp. move: (hi l (hv _ hin)). eapply infers_atom_of_level_map. -Qed. +Qed. *) (* The criterion for loops: when a set of updates manages to strictly update all the levels it started with, @@ -5274,7 +5394,7 @@ Qed. *) -Lemma strictly_updates_entails_loop cls V (hne : ~ LevelSet.Empty V) mzero m : +(* Lemma strictly_updates_entails_loop cls V (hne : ~ LevelSet.Empty V) mzero m : max_premise_model cls clauses_levels mzero -> V =_lset clauses_levels cls -> model_of V mzero -> @@ -5304,9 +5424,9 @@ Proof. forward hl. apply vincl, hin. eapply LevelMapFact.F.MapsTo_fun in hm; tea. noconf hm. split => //. lia. -Qed. +Qed. *) -Lemma strictly_updates_entails_loop_above_max cls V (hne : ~ LevelSet.Empty V) mzero m : +(* Lemma strictly_updates_entails_loop_above_max cls V (hne : ~ LevelSet.Empty V) mzero m : above_max_premise_model cls mzero -> V =_lset clauses_levels cls -> model_of V mzero -> @@ -5329,24 +5449,24 @@ Proof. * subst mzero. eapply strictly_updates_entails_loop; tea. apply max_premise_model_exists. -Qed. +Qed. *) Lemma entails_any_one V cls m nem m' nem' : model_of V m -> cls ⊢a of_level_map m nem → of_level_map m' nem' -> model_rel_partial Z.lt V m m' -> forall l k, LevelSet.In l V -> - LevelMap.MapsTo l k m -> cls ⊢ of_level_map m nem → (l, k + 1). + LevelMap.MapsTo l (Some k) m -> cls ⊢ of_level_map m nem → (l, k + 1). Proof. intros tot cla mp l k hin hm. eapply entails_all_one; tea. move: (proj1 (mp l) hin). move: (tot _ hin) => [x hm']. move/(_ _ hm) => [k'' [hm'' lt]]. - apply infers_atom_of_level_map. red. rewrite (level_value_MapsTo hm''). constructor. lia. + apply infers_atom_of_level_map. red. rewrite (level_value_MapsTo hm''). + depelim lt. constructor. lia. Qed. - Lemma only_model_of_model_of {V m} : only_model_of V m -> model_of V m. Proof. intros om l. move/om. intros [k hm]; now exists k. @@ -5362,7 +5482,7 @@ Lemma entails_any V cls m nem m' nem' : Proof. intros tot cla mp [l k]. rewrite In_add_prems => [] [[l' k']] [] /of_level_map_spec hm [=] -> ->. - eapply entails_any_one; tea. exact tot. apply tot. now exists k'. + eapply entails_any_one; tea. exact tot. apply tot. now exists (Some k'). Qed. Lemma strictly_updates_entails_on_V cls V mzero hne m : @@ -5372,7 +5492,7 @@ Lemma strictly_updates_entails_on_V cls V mzero hne m : Proof. move=> tot su. have mp := strictly_updates_model_lt su tot. - have nem := strictly_updates_non_empty_map su. + have nem := strictly_updates_defined_map su. eapply strictly_updates_strenghten in su. eapply (strictly_updates_entails hne nem) in su; tea. eapply entails_any in su; tea. @@ -5429,6 +5549,19 @@ Proof. - auto. Qed. +Lemma strictly_updates_defined_init_map {cls W m m'} : + strictly_updates cls W m m' -> defined_map m. +Proof. + induction 1. + - destruct cl as [prems [concl k]]. + destruct H0 as [? [? ? heq]]. + eapply min_premise_spec_aux in H0 as [_ [[] [inprems heq']]]. + unfold min_atom_value in heq'. + destruct level_value eqn:hl => //. apply level_value_MapsTo' in hl. + now exists t, z0. + - auto. +Qed. + Lemma check_model_ne_init_map {cls V U minit m W m'} : [/\ clauses_levels cls ⊂_lset V, only_model_of V minit & is_update_of cls U minit m] -> check_model cls (U, m) = Some (W, m') -> @@ -5440,6 +5573,18 @@ Proof. now eapply strictly_updates_non_empty_init_map in su. Qed. + +Lemma check_model_defined_init_map {cls V U minit m W m'} : + [/\ clauses_levels cls ⊂_lset V, only_model_of V minit & is_update_of cls U minit m] -> + check_model cls (U, m) = Some (W, m') -> + defined_map minit. +Proof. + intros [_ _ isupd] check. + eapply check_model_is_update_of in check as [su incl]; tea. + rewrite union_idem in su. + now eapply strictly_updates_defined_init_map in su. +Qed. + Lemma check_model_ne_map {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> ~ LevelMap.Empty m'. @@ -5449,6 +5594,15 @@ Proof. now eapply strictly_updates_non_empty_map in su. Qed. +Lemma check_model_defined_map {cls U m W m'} : + check_model cls (U, m) = Some (W, m') -> + defined_map m'. +Proof. + intros check. + eapply check_model_spec in check as [W' [su incl]]; tea. + now eapply strictly_updates_defined_map in su. +Qed. + #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) (prf : [/\ clauses_levels cls ⊂_lset V, only_model_of V minit & is_update_of cls U minit m]) : result V U cls minit @@ -5456,7 +5610,7 @@ Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : mod loop V U cls minit m prf with inspect (check_model cls (U, m)) := | exist None eqm => Model U {| model_model := m |} _ | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { - | exist true eq := Loop (of_level_map minit (check_model_ne_init_map prf eqm)) _ + | exist true eq := Loop (of_level_map minit (check_model_defined_init_map prf eqm)) _ (* Loop on cls ↓ W, with |W| < |V| *) | exist false neq with inner_loop V U minit loop W (cls ↓ W) m' _ := { | Loop u isloop := Loop u (loop_on_subset _ isloop) @@ -5466,7 +5620,7 @@ Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : mod with inspect (check_model cls (Wc, mwc.(model_model))) := { | exist None eqm' => Model (LevelSet.union W Wc) {| model_model := mwc.(model_model) |} _ | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { - | exist true _ := Loop (of_level_map m' (check_model_ne_map eqm)) _ + | exist true _ := Loop (of_level_map m' (check_model_defined_map eqm)) _ | exist false neq' with loop V (LevelSet.union W Wcls) cls minit mcls _ := { (* Here Wcls < V, we've found a model for all of the clauses with conclusion in W, which can now be fixed. We concentrate on the clauses whose @@ -5484,7 +5638,7 @@ Proof. all:have cls_sub := clauses_conclusions_levels cls. all:destruct prf as [clsV mof isupd]. - red. eapply LevelSet.equal_spec in eq. - set (prf := check_model_ne_init_map _ _); clearbody prf. + set (prf := check_model_defined_init_map _ _); clearbody prf. eapply check_model_is_update_of in eqm; tea. rewrite eq in eqm. destruct eqm as [eqm incl]. rewrite union_idem in eqm. unshelve eapply strictly_updates_entails_on_V in eqm; tea. @@ -5499,7 +5653,7 @@ Proof. * eapply strictly_updates_strenghten. exact eqm. - now intros ?; rewrite in_clauses_with_concl. - - set (ne := check_model_ne_map _). clearbody ne. + - set (ne := check_model_defined_map _). clearbody ne. have hu := model_updates mwc. eapply check_model_is_update_of in eqm as [eqm incl]; tea. have om : only_model_of V m'. @@ -5715,24 +5869,26 @@ Qed. Definition max_clause_premises cls : model := let ls := clauses_levels cls in - let fn l m := LevelMap.add l (max_clause_premise_of l cls) m in + let fn l m := LevelMap.add l (Some (max_clause_premise_of l cls)) m in LevelSet.fold fn ls (LevelMap.empty _). Lemma max_clause_premises_spec l k cls : - LevelMap.MapsTo l k (max_clause_premises cls) -> LevelSet.In l (clauses_levels cls) /\ k = max_clause_premise_of l cls. + LevelMap.MapsTo l k (max_clause_premises cls) -> + LevelSet.In l (clauses_levels cls) /\ k = Some (max_clause_premise_of l cls). Proof. unfold max_clause_premises. eapply LevelSetProp.fold_rec. - intros s' he hm. now rewrite LevelMapFact.F.empty_mapsto_iff in hm. - intros x a s' s'' hin hnin hadd ih. rewrite LevelMapFact.F.add_mapsto_iff. - intros [[-> <-]|[]] => //. + intros [[-> [= <-]]|[]] => //. * split => //. apply hadd. now left. * split => //. apply hadd; now right. now apply ih. Qed. Lemma max_clause_premises_spec_inv cls : - forall l, LevelSet.In l (clauses_levels cls) -> LevelMap.MapsTo l (max_clause_premise_of l cls) (max_clause_premises cls). + forall l, LevelSet.In l (clauses_levels cls) -> + LevelMap.MapsTo l (Some (max_clause_premise_of l cls)) (max_clause_premises cls). Proof. unfold max_clause_premises. eapply LevelSetProp.fold_rec. @@ -5750,8 +5906,8 @@ Lemma init_model_levels cls k : LevelMap.In k (init_model cls) <-> LevelSet.In k (clauses_levels cls). Proof. split. - now move => [] k' /max_clause_premises_spec. - move/max_clause_premises_spec_inv. now eexists. + - now move => [] k' /max_clause_premises_spec. + - move/max_clause_premises_spec_inv. now eexists. Qed. Definition init_w (levels : LevelSet.t) : LevelSet.t := LevelSet.empty. @@ -5773,9 +5929,9 @@ Qed. Local Open Scope string_scope2. -Definition print_level_Z_map (m : LevelMap.t Z) := +Definition print_level_Z_map (m : LevelMap.t (option Z)) := let list := LevelMap.elements m in - print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_Z w) nl list. + print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_option string_of_Z w) nl list. Definition print_result {V cls} (m : infer_result V cls) := match m return string with @@ -5895,14 +6051,14 @@ Qed. Definition premises_model_map (m : model) cls : model := let levels := clauses_premises_levels cls in LevelSet.fold (fun l acc => - LevelMap.add l (max_clause_premise_of l cls) acc) levels m. + LevelMap.add l (Some (max_clause_premise_of l cls)) acc) levels m. Variant checking_result (cls : clauses) (cl : clause) : Type := | DoesNotHold : ~ entails cls cl -> checking_result cls cl | Entails : entails cls cl -> checking_result cls cl. Definition zero_model levels : model := - LevelSet.fold (fun l acc => LevelMap.add l 0 acc) levels (LevelMap.empty _). + LevelSet.fold (fun l acc => LevelMap.add l None acc) levels (LevelMap.empty _). Definition premises_model V cl : LevelSet.t * model := let levels := LevelSet.union (clause_levels cl) V in @@ -5910,16 +6066,23 @@ Definition premises_model V cl : LevelSet.t * model := Lemma premises_model_map_spec m cls : forall l k, - LevelMap.MapsTo l k (premises_model_map m cls) -> - ((LevelSet.In l (clauses_premises_levels cls) /\ k = max_clause_premise_of l cls) \/ + LevelMap.MapsTo l k (premises_model_map m cls) <-> + ((LevelSet.In l (clauses_premises_levels cls) /\ k = Some (max_clause_premise_of l cls)) \/ (~ LevelSet.In l (clauses_premises_levels cls) /\ LevelMap.MapsTo l k m)). Proof. intros l k; rewrite /premises_model_map. eapply LevelSetProp.fold_rec. - - intros s' he hm. right. split => //. + - intros s' he. split. intros hm. right. split => //. + firstorder. - intros x a s' s'' hin hnin hadd ih. - rewrite LevelMapFact.F.add_mapsto_iff. - firstorder. subst k. red in H; subst. firstorder. + split. + * rewrite LevelMapFact.F.add_mapsto_iff. + firstorder. subst k. red in H; subst. firstorder. + * intros [[hin' ->]|]. + rewrite LevelMapFact.F.add_mapsto_iff. + destruct (eq_dec x l); subst; firstorder. + destruct (eq_dec x l); subst; firstorder. + rewrite LevelMapFact.F.add_mapsto_iff. right; split => //. Qed. Lemma premises_model_map_in m cls l : @@ -5933,7 +6096,7 @@ Proof. firstorder. Qed. -Lemma zero_model_spec {l ls n} : LevelMap.MapsTo l n (zero_model ls) <-> LevelSet.In l ls /\ n = 0. +Lemma zero_model_spec {l ls n} : LevelMap.MapsTo l n (zero_model ls) <-> LevelSet.In l ls /\ n = None. Proof. unfold zero_model. eapply LevelSetProp.fold_rec. @@ -5957,10 +6120,10 @@ Proof. apply clause_levels_spec. left. now subst. - apply zero_model_spec in H as [hin ->]. apply LevelSet.union_spec in hin. firstorder. - - right. exists 0. apply zero_model_spec. split => //; lsets. + - right. exists None. apply zero_model_spec. split => //; lsets. - eapply clause_levels_spec in H as [H|H]. * left. exists cl. split => //. now apply Clauses.singleton_spec. - * subst. right. exists 0. apply zero_model_spec. split => //. + * subst. right. exists None. apply zero_model_spec. split => //. apply LevelSet.union_spec. left. apply clause_levels_spec. now right. Qed. @@ -6092,16 +6255,21 @@ Proof. symmetry in premeq. move: premeq. unfold min_atom_value. unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. + destruct o => //. intros [= <-]. eapply LevelMap.find_2 in findp. have premm := valuation_of_model_spec _ _ _ findp. unfold interp_level. eapply LevelMap.find_1 in premm. rewrite premm. assert (z1 - k' <= z0 - k). lia. - have hm : z0 <= model_max model. eapply model_max_spec; tea. - have hm' : z1 <= model_max model. eapply model_max_spec; tea. - have hmi : model_min model <= z0. eapply model_min_spec; tea. - have hmi' : model_min model <= z1. eapply model_min_spec; tea. + have hm : z0 <= model_max model. + { eapply model_max_spec in hfind; tea. now depelim hfind. } + have hm' : z1 <= model_max model. + { eapply model_max_spec in findp; tea. now depelim findp. } + have hmi : model_min model <= z0. + { eapply model_min_spec; tea. } + have hmi' : model_min model <= z1. + { eapply model_min_spec; tea. } assert (0 <= model_max model)%Z by apply model_max_spec2. assert (model_min model <= 0)%Z by apply model_min_spec2. lia. @@ -6519,10 +6687,10 @@ Proof. have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m prems. rewrite mineq. rewrite /min_atom_value. destruct level_value eqn:hl => //. intros [= <-]. - eapply LevelMap.find_2 in hl. eapply premises_model_map_spec in hl as [[inpcls hm]|[ninpcls h']]. left. - 2:{ apply zero_model_spec in h' as [h' ->]. cbn. right. eexists minp, mink. - split => //. lia. } - exists minp, mink. split => //. lia. + eapply level_value_MapsTo' in hl. + eapply premises_model_map_spec in hl as [[inpcls hm]|[ninpcls h']]. left. + 2:{ apply zero_model_spec in h' as [h' [= ->]]. } + exists minp, mink. split => //. noconf hm. lia. Qed. Lemma premises_model_map_min_premise_inv {levels cls} : @@ -6535,16 +6703,22 @@ Proof. rewrite mineq. rewrite /min_atom_value. destruct level_value eqn:hl => //. eexists. split; trea. - have ps := premises_model_map_spec _ cls minp z (level_value_MapsTo' hl). - destruct ps as [[minpsl eq]|]. + have ps := proj1 (premises_model_map_spec _ cls minp (Some z)) (level_value_MapsTo' hl). + destruct ps as [[minpsl [= eq]]|]. rewrite eq. have sp := (max_clause_premise_of_spec _ _ _ _ hin inminp). lia. destruct H. elim H. eapply clauses_premises_levels_spec. exists cl. split => //. eapply levelexprset_levels_spec. now exists mink. unfold level_value in hl. - move/LevelMapFact.F.not_find_in_iff: hl; elim. - rewrite premises_model_map_in. left. + destruct LevelMap.find eqn:hl'. subst o. + 2:{ move/LevelMapFact.F.not_find_in_iff: hl'. elim. + rewrite premises_model_map_in. left. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. } + eapply LevelMap.find_2 in hl'. + move/premises_model_map_spec: hl' => [[]|[nin hm]] => //. + move: nin; elim. eapply clauses_premises_levels_spec. exists cl. split => //. eapply levelexprset_levels_spec. now exists mink. Qed. @@ -6569,6 +6743,21 @@ Proof. - intros he su. now eapply strictly_updates_non_empty_map in su. Qed. +Instance defined_map_proper : Proper (LevelMap.Equal ==> iff) defined_map. +Proof. + intros x y eq; rewrite /defined_map. + now setoid_rewrite eq. +Qed. + +Lemma is_update_of_defined_map {cls V m m'} : defined_map m -> + is_update_of cls V m m' -> + defined_map m'. +Proof. + rewrite /is_update_of. destruct LevelSet.is_empty. + - now intros he <-. + - intros he su. now eapply strictly_updates_defined_map in su. +Qed. + Lemma inj_add_prems_sub {n u u'} : add_prems n u ⊂_leset add_prems n u' -> u ⊂_leset u'. Proof. rewrite /add_prems. @@ -6750,13 +6939,30 @@ Proof. now eapply levelexprset_levels_spec in hexi. Qed. +Lemma max_premise_of_spec_pos l k (u : univ) : LevelExprSet.In (l, k) u -> + 0 <= k -> + LevelExprSet.In (l, max_premise_of l u) u. +Proof. + intros hexi hpos. + remember (max_premise_of l u) as mp. symmetry in Heqmp. + destruct (max_premise_of_spec_aux _ _ _ Heqmp) as [hle hex]. + destruct hex. + - have h0 := (hle _ hexi). +Admitted. +(* + destruct H as [l' [hin heq]]. + have -> : mp = l' by lia. + destruct H as [nein ->]. elim nein. + now eapply levelexprset_levels_spec in hexi. +Qed. *) + Lemma of_level_map_premises_model_map cls cl V ne : (forall l, LevelSet.In l (clause_levels cl) -> LevelSet.In l V) -> cls ⊢a add_list (premises_of_level_set V) (premise cl) → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. Proof. intros hin [l k]. rewrite of_level_map_spec. move/premises_model_map_spec; cbn. - cbn; rewrite LevelSet.union_spec. firstorder try lsets. subst. + cbn; rewrite LevelSet.union_spec. firstorder try lsets. noconf H1. - rewrite Z.max_comm. destruct (Z.max_spec 0 (max_premise_of l (premise cl))) as [[hle ->]|[hge ->]]. * constructor. rewrite add_list_spec; right. @@ -6764,10 +6970,51 @@ Proof. * constructor. rewrite add_list_spec. left. apply premises_of_level_set_spec. split => //. apply hin. apply clause_levels_spec. now left. - - eapply zero_model_spec in H0 as [hin' ->]. constructor. - eapply add_list_spec. left. now eapply premises_of_level_set_spec. + - eapply zero_model_spec in H1 as [hin' [= ->]]. +Qed. + +Lemma max_premise_of_pos l prems : max_premise_of l prems >= 0. +Proof. + have hs := max_premise_of_spec_aux prems l. + destruct max_premise_of. lia. lia. + specialize (hs _ eq_refl) as [_ [[k' []]|[_ hne]]]; lia. Qed. +Lemma of_level_map_premises_model_map' cls cl V ne : + (forall l, LevelSet.In l (clause_levels cl) -> LevelSet.In l V) -> + (forall l k, LevelExprSet.In (l, k) (premise cl) -> k >= 0) -> + cls ⊢a premise cl → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. +Proof. + intros hin hpos [l k]. + rewrite of_level_map_spec. move/premises_model_map_spec; cbn. + intros [[hin'[= heq]]|[hnin hm]]. + 2:{ now apply zero_model_spec in hm as []. } + move: hin'; cbn; rewrite LevelSet.union_spec. intros []; [|lsets]. + move: heq. + destruct (Z.max_spec (max_premise_of l (premise cl)) 0) as [[hle ->]|[hge heq]]. + * have := max_premise_of_pos l (premise cl). lia. + * intros ->. rewrite levelexprset_levels_spec in H. destruct H as [k inp]. + specialize (hpos _ _ inp). rewrite heq. + constructor. + eapply max_premise_of_spec_pos; tea. lia. +Qed. + (* eapply max_premise_of_spec_in. + * eapply premises_model_map_spec in H as [[hin' [= heq']]|[hnin hm]]. + 2:{ + apply clauses_premises_levels_spec in hin' as [cl' [incl hix]]. + apply Clauses.singleton_spec in incl. subst cl'. + + destruct hin' as + have hm := max_clause_premise_of_spec _ _ _ _ + + + + destruct } constructor. rewrite add_list_spec. left. + apply premises_of_level_set_spec. split => //. + apply hin. apply clause_levels_spec. now left. + - eapply zero_model_spec in H1 as [hin' [= ->]]. +Qed. *) + Lemma entails_all_satisfies {cls prems m hne l k} : cls ⊢a prems → of_level_map m hne -> infers_atom m l k -> @@ -6789,20 +7036,58 @@ Proof. now move/he: hin'. Qed. +Lemma clauses_ne_exist cls : ~ Clauses.Empty cls -> exists cl, Clauses.In cl cls. +Proof. + intros ne. + destruct (Clauses.choose cls) eqn:hc. + - exists e. now apply Clauses.choose_spec1 in hc. + - now apply Clauses.choose_spec2 in hc. +Qed. + +Lemma premises_model_map_defined V cls : + ~ Clauses.Empty cls -> + defined_map (premises_model_map V cls). +Proof. + move/clauses_ne_exist => [cl hin]. + destruct cl as [prems concl]. + pose proof (to_nonempty_list_spec' prems). + set (l := (to_nonempty_list prems).1) in *. + have ne' := proj2 (premises_model_map_spec V cls l (Some (max_clause_premise_of l cls))). + forward ne'. + { left. split => //. eapply clauses_premises_levels_spec. + exists (prems, concl). split => //. rewrite //= levelexprset_levels_spec. + setoid_rewrite <- LevelExprSet.elements_spec1. rewrite -H //=. + exists l.2. constructor. destruct l; reflexivity. } + now exists l; eexists. +Qed. + Variant check_result {cls} := | IsLooping (v : univ) (islooping : loop_on_univ cls v) | Invalid | Valid. Arguments check_result : clear implicits. +Equations check_atom_value (z : Z) (l : option Z) : bool := + | _, None => false + | z, Some v => z <=? v. + +Lemma check_atom_value_spec z l : reflectProp (Some z ≤ l) (check_atom_value z l). +Proof. + funelim (check_atom_value z l). + - destruct (Z.leb_spec z v); constructor. + * now constructor. + * intros h; depelim h. lia. + - constructor. intros h; depelim h. +Qed. + Equations check (cls : clauses) (cl : clause) : check_result (succ_clauses cls) := check cls cl with loop_check cls (succ_clause cl) := | Loop v isl => IsLooping v isl | Model W v _ with LevelMap.find (concl cl).1 v.(model_model) := { - | Some val with Z.succ (concl cl).2 <=? val := + | Some val with check_atom_value (Z.succ (concl cl).2) val := { | true => Valid | false => Invalid } - | None => Invalid + | None => Invalid (* Impossible actually *) }. (* If a clause checks, then it should be valid in any extension of the model *) @@ -6814,24 +7099,23 @@ Proof. set (V := clause_levels (succ_clause _) ∪ clauses_levels cls) in *. clear Heqcall => _. cbn [concl fst snd] in *. unfold valid_entailment, valid_clause, level_value_above. - move/Z.leb_le: Heq => hgt. + move/check_atom_value_spec: Heq; intros h; depelim h. rename H into hgt. intros valuation ext. have vmupd := model_updates v. have vmok := model_ok v. set (pm := premises_model_map _ _) in *. - have nepm : ~ LevelMap.Empty pm. - { apply premises_model_map_ne. - have zm := proj2 (@zero_model_spec concl0 V 0). - forward zm. split => //. subst V. - eapply LevelSet.union_spec. left. apply clause_levels_spec. - now right. intros he. now move/he: zm. } - have nev : ~ LevelMap.Empty (model_model v). - by apply (is_update_of_non_empty nepm vmupd). + have nepm : defined_map pm. + { apply premises_model_map_defined. + set (cl := succ_clause _) in *. + move/(_ cl). rewrite Clauses.singleton_spec. congruence. } + have nev : defined_map (model_model v). + by apply (is_update_of_defined_map nepm vmupd). move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. set (cl := (prems, (concl0, k))) in V. - have of_lset := of_level_map_premises_model_map (succ_clauses cls) (succ_clause cl) V nepm. + have of_lset := of_level_map_premises_model_map' (succ_clauses cls) (succ_clause cl) V nepm. forward of_lset. { intros l; rewrite /V LevelSet.union_spec. auto. } + forward of_lset. todo "ensure positive premises". have tr := entails_all_trans of_lset ent. eapply (entails_all_satisfies (l := concl0) (k := Z.succ k)) in tr. 2:{ red. rewrite /level_value Heq0. now constructor. } @@ -6851,30 +7135,27 @@ Definition infers_expr (m : model) (le : LevelExpr.t) := let '(l, k) := le in infers_atom m l k. Lemma valid_clause_elim {m prems concl k} : valid_clause m (prems, (concl, k)) -> - forall z, min_premise m prems = Some z -> (0 <= z)%Z -> - Some (Z.to_nat z + k) ≤ level_value m concl. + forall z, min_premise m prems = Some z -> + Some (z + k) ≤ level_value m concl. Proof. - rewrite /valid_clause => hcl z eqmin hge. + rewrite /valid_clause => hcl z eqmin. rewrite eqmin in hcl. cbn in *. - move: hcl; elim: Z.ltb_spec => //=. - * lia. - * move=> _. rewrite /level_value_above. destruct level_value eqn:hl => //. - move/Nat.leb_le. constructor. lia. + move: hcl. rewrite /level_value_above. destruct level_value eqn:hl => //. + move/Z.leb_le. constructor. lia. Qed. Lemma valid_clause_intro {m prems concl k} : (forall z, - min_premise m prems = Some z -> (0 <= z)%Z -> - Some (Z.to_nat z + k) ≤ level_value m concl) -> + min_premise m prems = Some z -> + Some (z + k) ≤ level_value m concl) -> valid_clause m (prems, (concl, k)). Proof. rewrite /valid_clause //=. destruct min_premise => //. - elim: Z.ltb_spec => //= hge. intros hz. - specialize (hz _ eq_refl hge). depelim hz. + specialize (hz _ eq_refl). depelim hz. rewrite /level_value_above H0. - now apply Nat.leb_le. + apply Z.leb_le. lia. Qed. Lemma infers_expr_min_atom_value m le : infers_expr m le -> exists k, min_atom_value m le = Some k /\ (0 <= k)%Z. @@ -6884,19 +7165,19 @@ Proof. eexists; split; trea. lia. Qed. -Lemma min_premise_add_infers m prems le : - infers_expr m le -> - forall z, min_premise m prems = Some z -> (0 <= z)%Z -> +Lemma min_premise_add_infers m prems le lev : + level_value m le.1 = Some lev -> + forall z, min_premise m prems = Some z -> exists z', min_premise m (add le prems) = Some z' /\ - ((min_atom_value m le = Some z' /\ (0 <= z' <= z)%Z) \/ z' = z). + ((z' = lev - le.2 /\ z' <= z) \/ z' = z). Proof. - intros infe z hmin hpos. + intros hlev z hmin. have [hle [min' [hin hm]]] := min_premise_spec m (add le prems). have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. move/LevelExprSet.add_spec: hin => [heq|hin]. - - noconf heq. - eapply infers_expr_min_atom_value in infe as [z' [mineq hge]]. - rewrite mineq in hm. exists z'; split => //. + - noconf heq. destruct le as [le k]. + rewrite /min_atom_value hlev in hm. + eexists; split => //; trea. left. specialize (hle min''). forward hle. { rewrite LevelExprSet.add_spec. now right. } rewrite hm -hm' hmin in hle. now depelim hle. @@ -7074,7 +7355,7 @@ Qed. Lemma min_atom_value_add m e x n : min_atom_value m e = Some x -> - min_atom_value m (add_expr n e) = Some (x - Z.of_nat n)%Z. + min_atom_value m (add_expr n e) = Some (x - n)%Z. Proof. rewrite /min_atom_value. destruct e. cbn. destruct level_value => //. intros [= <-]. @@ -7084,14 +7365,14 @@ Qed. Lemma min_atom_value_add_inv m e x n : min_atom_value m (add_expr n e) = Some x -> - min_atom_value m e = Some (x + Z.of_nat n)%Z. + min_atom_value m e = Some (x + n)%Z. Proof. rewrite /min_atom_value. destruct e. cbn. destruct level_value => //. intros [= <-]. f_equal. lia. Qed. -Lemma min_premise_add_prems {m n prems z} : min_premise m prems = Some z -> min_premise m (add_prems n prems) = Some (z - Z.of_nat n)%Z. +Lemma min_premise_add_prems {m n prems z} : min_premise m prems = Some z -> min_premise m (add_prems n prems) = Some (z - n)%Z. Proof. revert z. eapply min_premise_elim. @@ -7109,13 +7390,13 @@ Proof. Qed. Lemma min_premise_add_prems_inv {m n prems z} : min_premise m (add_prems n prems) = Some z -> - min_premise m prems = Some (z + Z.of_nat n)%Z. + min_premise m prems = Some (z + n)%Z. Proof. revert z. pattern prems. set (P := (fun n0 hm => forall z : Z, - min_premise m (add_prems n n0) = Some z -> hm = Some (z + Z.of_nat n)%Z)). + min_premise m (add_prems n n0) = Some z -> hm = Some (z + n)%Z)). apply (@min_premise_elim _ P); subst P; cbn. - intros le z hm. destruct le as [concl k]. @@ -7136,7 +7417,7 @@ Lemma level_value_above_leq {m l k} : level_value_above m l k. Proof. intros h; rewrite /level_value_above. - depelim h. rewrite H0. apply Nat.leb_le. lia. + depelim h. rewrite H0. apply Z.leb_le. lia. Qed. Lemma valid_clause_shift m n cl : @@ -7144,9 +7425,9 @@ Lemma valid_clause_shift m n cl : Proof. destruct cl as [prems [concl k]]. move/valid_clause_elim => hv. - apply valid_clause_intro => z eqmin zpos. + apply valid_clause_intro => z eqmin. eapply min_premise_add_prems_inv in eqmin. - specialize (hv _ eqmin). forward hv. lia. + specialize (hv _ eqmin). etransitivity; tea. constructor; lia. Qed. @@ -7156,7 +7437,7 @@ Proof. induction 1. - intros m ism. destruct concl0 as [concl k]. - apply valid_clause_intro => z hmin hge. + apply valid_clause_intro => z hmin. eapply min_premise_spec_aux in hmin as [hle [x [hin heq]]]. specialize (hle _ H). depelim hle. destruct level_value eqn:hl => //. noconf H1. @@ -7169,30 +7450,28 @@ Proof. eapply Clauses.for_all_spec in H3. eapply H3 in H. 2:tc. destruct concl0 as [concl k]. - eapply valid_clause_intro => z eqmin hge. + eapply valid_clause_intro => z eqmin. have mins := min_premise_subset m (add_prems n premsc) prems H2. rewrite eqmin in mins; depelim mins. destruct conclc as [conclc k']. have vshift : valid_clause m (add_prems n premsc, add_expr n (conclc, k')). { now eapply (valid_clause_shift _ n) in H. } - have hv := valid_clause_elim vshift _ H4. forward hv by lia. + have hv := valid_clause_elim vshift _ H4. + depelim hv. rename y0 into vmconclc. eapply (min_premise_add_infers _ _ (add_expr n (conclc, k'))) in eqmin as [minadd [eqminadd disj]]; tea. - 2:{ rewrite /infers_expr /infers_atom. cbn. etransitivity; tea. constructor; lia. } move/valid_clause_elim: IHentails => //=. move/(_ _ eqminadd). - destruct disj as [[eqmnew le']| ->]. - + cbn in eqmnew. depelim hv. rewrite H6 in eqmnew. - have : (0 <= minadd)%Z by (noconf eqmnew; lia). - move=> h /(_ h). noconf eqmnew. intros h'; depelim h'. - rewrite H8. constructor; lia. - + move/(_ hge). intros h; depelim h. rewrite H6; constructor; lia. + destruct disj as [[eq le']| ->]. + + move=> h. cbn in le'. cbn in eq. subst minadd. + depelim h. rewrite H8. constructor. lia. + + intros h; depelim h. rewrite H8; constructor; lia. * destruct concl0 as [concl0 k']. - apply valid_clause_intro => z hmin hgt. + apply valid_clause_intro => z hmin. have mins := min_premise_subset m _ _ H1. rewrite min_premise_singleton in mins. specialize (H1 (x, k+1)); forward H1 by now apply LevelExprSet.singleton_spec. have hadd := min_premise_add_down H1 _ hmin. - exact: valid_clause_elim IHentails _ hadd hgt. + exact: valid_clause_elim IHentails _ hadd. Qed. Lemma check_entails_looping {cls cl v isl} : @@ -7208,9 +7487,9 @@ Lemma enabled_clause_ext {m m' cl} : m ⩽ m' -> enabled_clause m cl -> enabled_clause m' cl. Proof. intros hext; rewrite /enabled_clause. - destruct cl as [prems [concl k]]; cbn; move=> [z [hm hpos]]. + destruct cl as [prems [concl k]]; cbn; move=> [z hm]. have pr := min_premise_pres prems hext. - rewrite hm in pr. depelim pr. exists y. split => //. lia. + rewrite hm in pr. depelim pr. now exists y. Qed. Lemma check_entails_false {cls cl} : @@ -7232,18 +7511,17 @@ Proof. destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *. rename val into conclval_v => _. clear Heq1 Heqcall prf. unfold valid_clause, level_value_above. - move/leb_complete_conv: Heq => hgt. intro. + move: (check_atom_value_spec (Z.succ k) conclval_v). rewrite Heq. + intros r; depelim r. rename H into nent. intros H. have vmupd := model_updates v. have vmok := model_ok v. set (pm := premises_model_map _ _) in *. - have nepm : ~ LevelMap.Empty pm. - { apply premises_model_map_ne. - have zm := proj2 (@zero_model_spec concl V 0). - forward zm. split => //. subst V. - eapply LevelSet.union_spec. left. apply clause_levels_spec. - now right. intros he. now move/he: zm. } - have nev : ~ LevelMap.Empty (model_model v). - by apply (is_update_of_non_empty nepm vmupd). + have nepm : defined_map pm. + { apply premises_model_map_defined. + set (cl := succ_clause _) in *. + move/(_ cl). rewrite Clauses.singleton_spec. congruence. } + have nev : defined_map (model_model v). + by apply (is_update_of_defined_map nepm vmupd). move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. set (cl := (prems, (concl, k))) in V. move/entails_plus: H. @@ -7254,11 +7532,14 @@ Proof. red; cbn. have hcl : Clauses.In (succ_clause cl) (Clauses.singleton (succ_clause cl)). { now eapply Clauses.singleton_spec. } - exact: @premises_model_map_min_premise_inv V _ _ hcl. } - destruct en as [z [minp hge]]. - move/valid_clause_elim/(_ z minp hge). + have hs:= @premises_model_map_min_premise_inv V _ _ hcl. firstorder. } + destruct en as [z minp]. + move/valid_clause_elim/(_ z minp). cbn in minp. - rewrite /level_value Heq0 => h; depelim h. red in H. lia. + rewrite /level_value Heq0 => h; depelim h. apply nent. + constructor. + have posz : 0 <= z. apply (todo "positive premises"). + lia. Qed. End LoopChecking. From 31bde50b56dca5635c0197dd64e635f1cb674b29 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 8 Sep 2025 15:46:58 +0200 Subject: [PATCH 033/164] Complete proof of correctness and completeness for Z / N with injective successor --- template-rocq/theories/PartialLoopCheckingZ.v | 336 +++++++++++------- 1 file changed, 198 insertions(+), 138 deletions(-) diff --git a/template-rocq/theories/PartialLoopCheckingZ.v b/template-rocq/theories/PartialLoopCheckingZ.v index 6b3e2fb26..a30f3fa80 100644 --- a/template-rocq/theories/PartialLoopCheckingZ.v +++ b/template-rocq/theories/PartialLoopCheckingZ.v @@ -3344,6 +3344,16 @@ Proof. now apply hu. now apply hv. Qed. +Lemma defined_model_of_union {U V cls} : + defined_model_of U cls -> + defined_model_of V cls -> + defined_model_of (LevelSet.union U V) cls. +Proof. + intros hu hv x. + rewrite LevelSet.union_spec; move => [] hin. + now apply hu. now apply hv. +Qed. + Lemma model_of_union_inv U V cls : model_of (LevelSet.union U V) cls -> model_of U cls /\ model_of V cls. Proof. rewrite /model_of. @@ -4599,8 +4609,44 @@ Section InnerLoop. defined_model_of W m'. Proof. induction 1. - - cbn. - Admitted. + - cbn. destruct cl as [prems [concl k]]; cbn in H0. + destruct H0 as [hz [hmin habov heq]]. + move=> l /LevelSet.singleton_spec => -> //=. + setoid_rewrite heq. exists (k + hz). + apply LevelMapFact.F.add_mapsto_iff. + left; split => //. + - apply defined_model_of_union; auto. + eapply defined_model_of_ext. exact IHstrictly_updates1. + now apply strictly_updates_ext in H0. + Qed. + + Lemma defined_model_of_restrict W m : + defined_model_of W m -> defined_model_of W (restrict_model W m). + Proof. + intros def l hin. specialize (def _ hin) as [k hm]. + exists k. apply restrict_model_spec. split => //. + Qed. + + Lemma defined_model_of_update W m m' : + model_of W m' -> + defined_model_of W m -> defined_model_of W (model_update m' m). + Proof. + intros mof def l hin. specialize (def _ hin) as [k hm]. + exists k. apply model_update_spec. right. split => //. + now apply mof. + Qed. + + Lemma defined_model_of_is_update_of {W W' W'' m m'} : + defined_model_of W m -> + is_update_of W' W'' m m' -> + defined_model_of W m'. + Proof. + intros def isupd l hin. move: isupd; rewrite /is_update_of. + destruct LevelSet.is_empty. + - intros h; setoid_rewrite <- h. specialize (def _ hin) as [k hm]. + now exists k. + - now move/strictly_updates_ext/defined_model_of_ext; move/(_ W). + Qed. Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) (loop : forall (V' U' : LevelSet.t) (cls' : clauses) (minit m : model) @@ -4662,11 +4708,13 @@ Section InnerLoop. { intros ?. now rewrite ClausesProp.union_sym union_diff_cls. } { have incl := model_incl mr. apply strictly_updates_incl in sumr. have hdiff := clauses_conclusions_diff_left cls W (cls ⇂ W). lsets. } - - have tmr : model_of W (model_model mr). + - have mW : model_of W m. + { now eapply strictly_updates_model_of in upd. } + have tmr : model_of W (model_model mr). { eapply valid_model_total. eapply strictly_updates_restrict_only_model in upd. intro. apply upd. } have tmr' : model_of W (model_update m (model_model mr)). - { eapply update_total_model; tea. now apply strictly_updates_total_model in upd. } + { eapply update_total_model; tea. } eapply (check_model_spec_diff tmr') in eqm as [subwwconcl subwconcl hm hext] => //. pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). destruct hm as [cll [hind nvalid inwconcl hl]]. @@ -4679,7 +4727,11 @@ Section InnerLoop. have mof := strictly_updates_model_of upd. apply: valid_model_is_update_of_eq _ _ _ _ cls mof mr eqprem. } have isdef : defined_model_of W (model_update m (model_model mr)). - { apply (todo "defined model"). } + { eapply strictly_updates_defined_model in upd. + eapply defined_model_of_restrict in upd. + have hupd := model_updates mr. + have hu := (defined_model_of_is_update_of upd hupd). + apply defined_model_of_update; tea. } eapply measure_lt; tea. { eapply model_map_outside_weaken. eapply hext. have incl := model_incl mr. lsets. } { apply hext. } @@ -5769,6 +5821,16 @@ Proof. now rewrite eq in sh. Qed. +Lemma entails_pred_closure_neg {cls u concl k p} : + cls ⊢ u → (concl, k) -> + cls ⊢ u → (concl, k + Z.neg p). +Proof. + intros ent. + eapply (entails_pred_closure_n (n := Pos.to_nat p)). + have eq : Z.neg p + Z.of_nat (Pos.to_nat p) = 0. lia. + now rewrite -Z.add_assoc eq Z.add_0_r. +Qed. + Lemma loop_any cls u n : cls ⊢a u → succ_prems u -> cls ⊢a u → add_prems n u. @@ -5778,7 +5840,10 @@ Proof. - assert (exists n, Z.pos p = Z.of_nat n). exists (Pos.to_nat p). now rewrite Z_of_pos_alt. destruct H as [n ->]. destruct n. cbn. intros. rewrite add_prems_0. apply entails_all_tauto. apply loop_any_successor. - - apply (todo "downward closure"). + - intros _ [l k]. rewrite In_add_prems. + intros [[] [hin heq]]. rewrite /add_expr in heq. noconf heq. + apply entails_pred_closure_neg. + now constructor. Qed. Lemma univ_non_empty (u : univ) : ~ LevelSet.Empty (levels u). @@ -5835,10 +5900,18 @@ Qed. Definition maximal_prem l n cls := Clauses.For_all (fun cl => forall n', LevelExprSet.In (l, n') (premise cl) -> n' <= n) cls. -Definition max_premise_of l (u : univ) : Z := - LevelExprSet.fold (fun '(l', k) acc => if eqb l l' then Z.max k acc else acc) u 0. +Definition max_opt_of {A} (max : A -> A -> A) (x : option A) (y : option A) : option A := + match x, y with + | Some x, Some y => Some (max x y) + | Some x, None => Some x + | _, _ => y + end. + +Definition max_premise_of l (u : univ) : option Z := + LevelExprSet.fold (fun '(l', k) acc => if eqb l l' then + max_opt_of Z.max (Some k) acc else acc) u None. -Lemma max_premise_of_spec l k (u : univ) : LevelExprSet.In (l, k) u -> k <= max_premise_of l u. +Lemma max_premise_of_spec l k (u : univ) : LevelExprSet.In (l, k) u -> Some k ≤ max_premise_of l u. Proof. rewrite /max_premise_of. eapply LevelExprSetProp.fold_rec. @@ -5846,16 +5919,16 @@ Proof. - intros x a s' s'' hin nin hadd hle. intros hs''. destruct x. apply hadd in hs'' as []. - * noconf H. rewrite eqb_refl. lia. + * noconf H. rewrite eqb_refl. destruct a; cbn. constructor. lia. reflexivity. * elim: eqb_spec; try intros ->; - specialize (hle H); lia. + specialize (hle H); depelim hle; cbn; constructor; lia. Qed. Definition max_clause_premise_of l (cls : clauses) := - Clauses.fold (fun cl acc => Z.max (max_premise_of l (premise cl)) acc) cls 0. + Clauses.fold (fun cl acc => max_opt_of Z.max (max_premise_of l (premise cl)) acc) cls None. Lemma max_clause_premise_of_spec l k cls : - forall cl, Clauses.In cl cls -> LevelExprSet.In (l, k) (premise cl) -> k <= max_clause_premise_of l cls. + forall cl, Clauses.In cl cls -> LevelExprSet.In (l, k) (premise cl) -> Some k ≤ max_clause_premise_of l cls. Proof. rewrite /max_clause_premise_of => cl. eapply ClausesProp.fold_rec. @@ -5863,18 +5936,20 @@ Proof. - intros x a s' s'' hin nin hadd hle. intros hs''. destruct x. apply hadd in hs'' as []. - * noconf H. cbn. move/max_premise_of_spec. lia. - * specialize (hle H); lia. + * noconf H. cbn. move/max_premise_of_spec. + intros h; etransitivity; tea. destruct (max_premise_of l n), a; cbn; constructor; lia. + * intros h; specialize (hle H h). depelim hle. cbn. + destruct (max_premise_of l n); cbn; constructor; lia. Qed. Definition max_clause_premises cls : model := let ls := clauses_levels cls in - let fn l m := LevelMap.add l (Some (max_clause_premise_of l cls)) m in + let fn l m := LevelMap.add l (max_clause_premise_of l cls) m in LevelSet.fold fn ls (LevelMap.empty _). Lemma max_clause_premises_spec l k cls : LevelMap.MapsTo l k (max_clause_premises cls) -> - LevelSet.In l (clauses_levels cls) /\ k = Some (max_clause_premise_of l cls). + LevelSet.In l (clauses_levels cls) /\ k = max_clause_premise_of l cls. Proof. unfold max_clause_premises. eapply LevelSetProp.fold_rec. @@ -5888,7 +5963,7 @@ Qed. Lemma max_clause_premises_spec_inv cls : forall l, LevelSet.In l (clauses_levels cls) -> - LevelMap.MapsTo l (Some (max_clause_premise_of l cls)) (max_clause_premises cls). + LevelMap.MapsTo l (max_clause_premise_of l cls) (max_clause_premises cls). Proof. unfold max_clause_premises. eapply LevelSetProp.fold_rec. @@ -6051,7 +6126,7 @@ Qed. Definition premises_model_map (m : model) cls : model := let levels := clauses_premises_levels cls in LevelSet.fold (fun l acc => - LevelMap.add l (Some (max_clause_premise_of l cls)) acc) levels m. + LevelMap.add l (max_clause_premise_of l cls) acc) levels m. Variant checking_result (cls : clauses) (cl : clause) : Type := | DoesNotHold : ~ entails cls cl -> checking_result cls cl @@ -6067,7 +6142,7 @@ Definition premises_model V cl : LevelSet.t * model := Lemma premises_model_map_spec m cls : forall l k, LevelMap.MapsTo l k (premises_model_map m cls) <-> - ((LevelSet.In l (clauses_premises_levels cls) /\ k = Some (max_clause_premise_of l cls)) \/ + ((LevelSet.In l (clauses_premises_levels cls) /\ k = max_clause_premise_of l cls /\ isSome k) \/ (~ LevelSet.In l (clauses_premises_levels cls) /\ LevelMap.MapsTo l k m)). Proof. intros l k; rewrite /premises_model_map. @@ -6078,7 +6153,12 @@ Proof. split. * rewrite LevelMapFact.F.add_mapsto_iff. firstorder. subst k. red in H; subst. firstorder. - * intros [[hin' ->]|]. + left; firstorder. + apply clauses_premises_levels_spec in hin as [cl [incl inlev]]. + apply levelexprset_levels_spec in inlev as [k inprem]. + have hs := max_clause_premise_of_spec l k cls cl incl inprem. + depelim hs. now rewrite H3. + * intros [[hin' [-> iss]]|]. rewrite LevelMapFact.F.add_mapsto_iff. destruct (eq_dec x l); subst; firstorder. destruct (eq_dec x l); subst; firstorder. @@ -6289,7 +6369,8 @@ Proof. have hm := max_clause_premises_spec_inv cls l inV. rewrite (level_value_MapsTo hm). have hs := max_clause_premise_of_spec l k _ _ hin premin. - eexists; split => //. + depelim hs. rewrite H0. + eexists => //. Qed. Lemma interp_add_expr V n e : interp_expr V (add_expr n e) = n + interp_expr V e. @@ -6453,17 +6534,6 @@ Proof. eexists; split; trea. now apply eq in b0. Qed. -Lemma interp_prems_equiv V (u u' : univ) : - LevelExprSet.Equal u u' -> - interp_prems V u = interp_prems V u'. -Proof. - move=> eq. rewrite !interp_prems_elements. - apply fold_right_equivlist_all. - intros x. - rewrite InA_In_eq (in_map_iff (interp_expr V) (_ :: _)). - rewrite InA_In_eq (in_map_iff (interp_expr V) (_ :: _)). -Admitted. - Lemma equivlistA_add le u : let l := to_nonempty_list (add le u) in equivlistA eq (l.1 :: l.2) (le :: LevelExprSet.elements u). Proof. @@ -6680,7 +6750,9 @@ Definition extendV V (cl : clause) := Lemma premises_model_map_min_premise {levels cls prems z} : min_premise (premises_model_map (zero_model levels) cls) prems = Some z -> - (exists minp mink, LevelExprSet.In (minp, mink) prems /\ z = max_clause_premise_of minp cls - mink) \/ + (exists minp mink, LevelExprSet.In (minp, mink) prems /\ + exists maxp, max_clause_premise_of minp cls = Some maxp /\ + z = maxp - mink) \/ (exists minp mink, LevelExprSet.In (minp, mink) prems /\ z + mink <= 0)%Z. Proof. set (m := premises_model_map _ _). @@ -6688,9 +6760,10 @@ Proof. rewrite mineq. rewrite /min_atom_value. destruct level_value eqn:hl => //. intros [= <-]. eapply level_value_MapsTo' in hl. - eapply premises_model_map_spec in hl as [[inpcls hm]|[ninpcls h']]. left. + eapply premises_model_map_spec in hl as [[inpcls [hm _]]|[ninpcls h']]. left. 2:{ apply zero_model_spec in h' as [h' [= ->]]. } - exists minp, mink. split => //. noconf hm. lia. + exists minp, mink. split => //. noconf hm. rewrite -hm. + eexists; split => //. Qed. Lemma premises_model_map_min_premise_inv {levels cls} : @@ -6702,25 +6775,27 @@ Proof. have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m (premise cl). rewrite mineq. rewrite /min_atom_value. destruct level_value eqn:hl => //. - eexists. split; trea. - have ps := proj1 (premises_model_map_spec _ cls minp (Some z)) (level_value_MapsTo' hl). - destruct ps as [[minpsl [= eq]]|]. - rewrite eq. - have sp := (max_clause_premise_of_spec _ _ _ _ hin inminp). lia. - destruct H. elim H. - eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. - unfold level_value in hl. - destruct LevelMap.find eqn:hl'. subst o. - 2:{ move/LevelMapFact.F.not_find_in_iff: hl'. elim. - rewrite premises_model_map_in. left. - eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. } - eapply LevelMap.find_2 in hl'. - move/premises_model_map_spec: hl' => [[]|[nin hm]] => //. - move: nin; elim. - eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. + - eexists. split; trea. + have ps := proj1 (premises_model_map_spec _ cls minp (Some z)) (level_value_MapsTo' hl). + destruct ps as [[minpsl [eq _]]|]. + * symmetry in eq. + have sp := (max_clause_premise_of_spec _ _ _ _ hin inminp). + depelim sp. rewrite eq in H0. noconf H0. lia. + * destruct H. elim H. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. + - unfold level_value in hl. + destruct LevelMap.find eqn:hl'. subst o. + 2:{ move/LevelMapFact.F.not_find_in_iff: hl'. elim. + rewrite premises_model_map_in. left. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. } + eapply LevelMap.find_2 in hl'. + move/premises_model_map_spec: hl' => [[]|[nin hm]] => //. + * now intros hnminp [_ hn]. + * move: nin; elim. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. Qed. Lemma is_update_of_entails {cls V m m' hne hne'} : is_update_of cls V m m' -> @@ -6871,9 +6946,9 @@ Notation "cls '⊢a' u ↔ u'" := (entails_equiv cls u u') (at level 90). Lemma max_premise_of_spec_aux s l k : max_premise_of l s = k -> - (forall k', LevelExprSet.In (l, k') s -> (k' <= k)) /\ - ((exists k', LevelExprSet.In (l, k') s /\ k = Z.max 0 k') \/ - ((~ exists k', LevelExprSet.In (l, k') s) /\ k = 0)). + (forall k', LevelExprSet.In (l, k') s -> (Some k' ≤ k)) /\ + ((exists k', LevelExprSet.In (l, k') s /\ k = Some k') \/ + ((~ exists k', LevelExprSet.In (l, k') s) /\ k = None)). Proof. unfold max_premise_of. revert k. @@ -6885,30 +6960,33 @@ Proof. specialize (ih _ eq_refl) as [hle hex]. intros hmax. split. move=> k'0 /hadd => [] []. - { move=> [=] eq eq'. subst l' k'. rewrite eqb_refl in hmax. lia. } - { move/hle. move: hmax. destruct (eqb_spec l l'); subst. lia. lia. } + { move=> [=] eq eq'. subst l' k'. rewrite eqb_refl in hmax. + destruct a; cbn in hmax; subst; constructor; lia. } + { move/hle. move: hmax. destruct (eqb_spec l l'); subst. + intros <-. intros h; depelim h; cbn. constructor; lia. + intros -> h; depelim h; constructor; lia. } destruct hex as [[k'' [hin' heq]]|nex]. subst a. - { left. destruct (eqb_spec l l'). subst. exists (Z.max k' k''); split; trea. 2:lia. eapply hadd. - destruct (Z.max_spec k' k'') as [[hlt ->]|[hle' ->]] => //. now right. now left. subst k. - exists k''; split => //. apply hadd; now right. } + { left. destruct (eqb_spec l l'). subst. exists (Z.max k' k''); split; trea. + 2:{ subst k. eexists; split => //. apply hadd. now right. } + eapply hadd. + destruct (Z.max_spec k' k'') as [[hlt ->]|[hle' ->]] => //. now right. now left. } destruct nex as [nex ->]. - destruct (eqb_spec l l'). subst. left. exists k'. split => //. apply hadd; now left. lia. + destruct (eqb_spec l l'). subst. left. exists k'. split => //. apply hadd; now left. subst k. right. split => //. intros [k'' hin']. apply hadd in hin' as []. noconf H0. congruence. apply nex. now exists k''. Qed. - -Lemma max_premise_of_prems_max l prems : max_premise_of l prems > 0 -> LevelExprSet.In (l, max_premise_of l prems) prems. +Lemma max_premise_of_prems_max {l prems k} : + max_premise_of l prems = Some k -> LevelExprSet.In (l, k) prems. Proof. - destruct max_premise_of eqn:maxp => //. intros _. + destruct max_premise_of eqn:maxp => //. intros [= ->]. apply max_premise_of_spec_aux in maxp as [hle hex]. - destruct hex as [[k' [hin heq]]|hne] => //. - now have -> : Z.pos p = k' by lia. - destruct hne; lia. + destruct hex as [[k' [hin [= ->]]]|hne] => //. + destruct hne; congruence. Qed. -Lemma max_premise_of_singleton l k : max_premise_of l (singleton (l, k)) = Z.max 0 k. +Lemma max_premise_of_singleton l k : max_premise_of l (singleton (l, k)) = Some k. Proof. remember (max_premise_of l (singleton (l, k))) as mp. symmetry in Heqmp. apply max_premise_of_spec_aux in Heqmp as [hle hex]. @@ -6918,7 +6996,8 @@ Proof. exists k. now eapply LevelExprSet.singleton_spec. Qed. -Lemma max_premise_of_spec2 l k (u : univ) : LevelExprSet.In (l, k) u -> exists k', LevelExprSet.In (l, k') u /\ Z.max 0 k' = max_premise_of l u. +Lemma max_premise_of_spec2 l k (u : univ) : LevelExprSet.In (l, k) u -> + exists k', LevelExprSet.In (l, k') u /\ max_premise_of l u = Some k'. Proof. remember (max_premise_of l u) as mp. symmetry in Heqmp. apply max_premise_of_spec_aux in Heqmp as [hle hex]. @@ -6927,42 +7006,36 @@ Proof. Qed. Lemma max_premise_of_spec_in l (u : univ) : LevelSet.In l (levels u) -> - 0 < max_premise_of l u -> - LevelExprSet.In (l, max_premise_of l u) u. + exists k, max_premise_of l u = Some k /\ LevelExprSet.In (l, k) u. Proof. - intros hexi hpos. + intros hexi. remember (max_premise_of l u) as mp. symmetry in Heqmp. apply max_premise_of_spec_aux in Heqmp as [hle hex]. - destruct hex. destruct H as [l' [hin heq]]. - now have -> : mp = l' by lia. - destruct H as [nein ->]. elim nein. - now eapply levelexprset_levels_spec in hexi. + destruct hex. destruct H as [l' [hin heq]]. subst mp. + - eexists; split => //. + - destruct H as [nein ->]. elim nein. + now eapply levelexprset_levels_spec in hexi. Qed. -Lemma max_premise_of_spec_pos l k (u : univ) : LevelExprSet.In (l, k) u -> - 0 <= k -> - LevelExprSet.In (l, max_premise_of l u) u. +Lemma max_opt_of_l {A} {f : A -> A -> A} l : max_opt_of f l None = l. Proof. - intros hexi hpos. - remember (max_premise_of l u) as mp. symmetry in Heqmp. - destruct (max_premise_of_spec_aux _ _ _ Heqmp) as [hle hex]. - destruct hex. - - have h0 := (hle _ hexi). -Admitted. -(* - destruct H as [l' [hin heq]]. - have -> : mp = l' by lia. - destruct H as [nein ->]. elim nein. - now eapply levelexprset_levels_spec in hexi. -Qed. *) + destruct l => //. +Qed. -Lemma of_level_map_premises_model_map cls cl V ne : +Lemma max_opt_of_r {A} {f : A -> A -> A} l : max_opt_of f None l = l. +Proof. + destruct l => //. +Qed. + +(* Lemma of_level_map_premises_model_map cls cl V ne : (forall l, LevelSet.In l (clause_levels cl) -> LevelSet.In l V) -> cls ⊢a add_list (premises_of_level_set V) (premise cl) → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. Proof. intros hin [l k]. rewrite of_level_map_spec. move/premises_model_map_spec; cbn. - cbn; rewrite LevelSet.union_spec. firstorder try lsets. noconf H1. + rewrite max_opt_of_l. + cbn; rewrite LevelSet.union_spec. firstorder try lsets. + cbn in H1. - rewrite Z.max_comm. destruct (Z.max_spec 0 (max_premise_of l (premise cl))) as [[hle ->]|[hge ->]]. * constructor. rewrite add_list_spec; right. @@ -6971,49 +7044,28 @@ Proof. apply premises_of_level_set_spec. split => //. apply hin. apply clause_levels_spec. now left. - eapply zero_model_spec in H1 as [hin' [= ->]]. -Qed. +Qed. *) -Lemma max_premise_of_pos l prems : max_premise_of l prems >= 0. +(* Lemma max_premise_of_pos l prems : max_premise_of l prems >= 0. Proof. have hs := max_premise_of_spec_aux prems l. destruct max_premise_of. lia. lia. specialize (hs _ eq_refl) as [_ [[k' []]|[_ hne]]]; lia. Qed. + *) -Lemma of_level_map_premises_model_map' cls cl V ne : - (forall l, LevelSet.In l (clause_levels cl) -> LevelSet.In l V) -> - (forall l k, LevelExprSet.In (l, k) (premise cl) -> k >= 0) -> +Lemma of_level_map_premises_model_map cls cl V ne : cls ⊢a premise cl → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. Proof. - intros hin hpos [l k]. + intros [l k]. rewrite of_level_map_spec. move/premises_model_map_spec; cbn. - intros [[hin'[= heq]]|[hnin hm]]. + intros [[hin' [[= heq] _]]|[hnin hm]]. 2:{ now apply zero_model_spec in hm as []. } move: hin'; cbn; rewrite LevelSet.union_spec. intros []; [|lsets]. - move: heq. - destruct (Z.max_spec (max_premise_of l (premise cl)) 0) as [[hle ->]|[hge heq]]. - * have := max_premise_of_pos l (premise cl). lia. - * intros ->. rewrite levelexprset_levels_spec in H. destruct H as [k inp]. - specialize (hpos _ _ inp). rewrite heq. - constructor. - eapply max_premise_of_spec_pos; tea. lia. + eapply max_premise_of_spec_in in H as [maxp' [eq hin']]. + rewrite eq in heq; noconf heq. + now constructor. Qed. - (* eapply max_premise_of_spec_in. - * eapply premises_model_map_spec in H as [[hin' [= heq']]|[hnin hm]]. - 2:{ - apply clauses_premises_levels_spec in hin' as [cl' [incl hix]]. - apply Clauses.singleton_spec in incl. subst cl'. - - destruct hin' as - have hm := max_clause_premise_of_spec _ _ _ _ - - - - destruct } constructor. rewrite add_list_spec. left. - apply premises_of_level_set_spec. split => //. - apply hin. apply clause_levels_spec. now left. - - eapply zero_model_spec in H1 as [hin' [= ->]]. -Qed. *) Lemma entails_all_satisfies {cls prems m hne l k} : cls ⊢a prems → of_level_map m hne -> @@ -7052,13 +7104,15 @@ Proof. destruct cl as [prems concl]. pose proof (to_nonempty_list_spec' prems). set (l := (to_nonempty_list prems).1) in *. - have ne' := proj2 (premises_model_map_spec V cls l (Some (max_clause_premise_of l cls))). - forward ne'. - { left. split => //. eapply clauses_premises_levels_spec. - exists (prems, concl). split => //. rewrite //= levelexprset_levels_spec. - setoid_rewrite <- LevelExprSet.elements_spec1. rewrite -H //=. - exists l.2. constructor. destruct l; reflexivity. } - now exists l; eexists. + have hs := max_clause_premise_of_spec l l.2 cls (prems, concl) hin. + forward hs. cbn. eapply LevelExprSet.elements_spec1; rewrite -H. + constructor. destruct l; reflexivity. depelim hs. + exists l, y. apply premises_model_map_spec. left. + split => //. + eapply clauses_premises_levels_spec. eexists; split; tea => //. + rewrite //= levelexprset_levels_spec. exists l.2. + setoid_rewrite <- LevelExprSet.elements_spec1. rewrite -H //=. + constructor. destruct l; reflexivity. Qed. Variant check_result {cls} := @@ -7112,10 +7166,7 @@ Proof. by apply (is_update_of_defined_map nepm vmupd). move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. set (cl := (prems, (concl0, k))) in V. - have of_lset := of_level_map_premises_model_map' (succ_clauses cls) (succ_clause cl) V nepm. - forward of_lset. - { intros l; rewrite /V LevelSet.union_spec. auto. } - forward of_lset. todo "ensure positive premises". + have of_lset := of_level_map_premises_model_map (succ_clauses cls) (succ_clause cl) V nepm. have tr := entails_all_trans of_lset ent. eapply (entails_all_satisfies (l := concl0) (k := Z.succ k)) in tr. 2:{ red. rewrite /level_value Heq0. now constructor. } @@ -7538,7 +7589,16 @@ Proof. cbn in minp. rewrite /level_value Heq0 => h; depelim h. apply nent. constructor. - have posz : 0 <= z. apply (todo "positive premises"). + have posz : 0 <= z. + { have hsu := model_updates v. + eapply is_update_of_ext in hsu. + have hs := min_premise_pres (succ_prems prems) hsu. + rewrite minp in hs. + set (scl := succ_clause _) in *. + have hmin := @premises_model_map_min_premise_inv V (Clauses.singleton scl) scl. + forward hmin. now apply Clauses.singleton_spec. + destruct hmin as [minp' [hmineq hpos]]. + rewrite hmineq in hs. depelim hs. lia. } lia. Qed. From aab1355ba4f57703afb5f528cf898fdfb9d01d8d Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 9 Sep 2025 09:57:51 +0200 Subject: [PATCH 034/164] Do not go through successor clauses for checking anymore --- template-rocq/theories/PartialLoopCheckingZ.v | 139 ++++++++---------- 1 file changed, 65 insertions(+), 74 deletions(-) diff --git a/template-rocq/theories/PartialLoopCheckingZ.v b/template-rocq/theories/PartialLoopCheckingZ.v index a30f3fa80..aebfec975 100644 --- a/template-rocq/theories/PartialLoopCheckingZ.v +++ b/template-rocq/theories/PartialLoopCheckingZ.v @@ -6729,12 +6729,12 @@ Qed. Definition valid_entailment cls cl := forall V, clauses_sem V cls -> clause_sem V cl. -Program Definition loop_check cls (cl : clause) : result (premises_model (clauses_levels cls) cl).1 LevelSet.empty (succ_clauses cls) (premises_model (clauses_levels cls) cl).2 := +Program Definition loop_check cls (cl : clause) : result (premises_model (clauses_levels cls) cl).1 LevelSet.empty cls (premises_model (clauses_levels cls) cl).2 := let V := clauses_levels cls in - loop (premises_model V cl).1 LevelSet.empty (succ_clauses cls) (premises_model V cl).2 (premises_model V cl).2 _. + loop (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 (premises_model V cl).2 _. Next Obligation. split => //. - - rewrite clauses_levels_add. lsets. + - lsets. - intros l. rewrite LevelSet.union_spec. rewrite -/(LevelMap.In l (premises_model (clauses_levels cls) cl).2). rewrite in_premises_model. intuition auto. @@ -7134,14 +7134,27 @@ Proof. - constructor. intros h; depelim h. Qed. -Equations check (cls : clauses) (cl : clause) : check_result (succ_clauses cls) := - check cls cl with loop_check cls (succ_clause cl) := +Lemma valid_model_find {V W cl cls} : + forall v : valid_model (clause_levels cl ∪ V) W (premises_model_map (zero_model (clause_levels cl ∪ V)) (Clauses.singleton cl)) cls, + ~ LevelMap.find (concl cl).1 (model_model v) = None. +Proof. + intros v hfind. + destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *; cbn in *. + have vmupd := model_of_V v. + set (pm := premises_model_map _ _) in *. + move/LevelMapFact.F.not_find_in_iff: hfind; apply. + apply vmupd. rewrite LevelSet.union_spec; left. + rewrite clause_levels_spec. now right. +Qed. + +Equations check (cls : clauses) (cl : clause) : check_result cls := + check cls cl with loop_check cls cl := | Loop v isl => IsLooping v isl - | Model W v _ with LevelMap.find (concl cl).1 v.(model_model) := { - | Some val with check_atom_value (Z.succ (concl cl).2) val := + | Model W v _ with inspect (LevelMap.find (concl cl).1 v.(model_model)) := { + | exist (Some val) he with check_atom_value (concl cl).2 val := { | true => Valid | false => Invalid } - | None => Invalid (* Impossible actually *) + | exist None he with valid_model_find v he := {} }. (* If a clause checks, then it should be valid in any extension of the model *) @@ -7149,9 +7162,9 @@ Lemma check_entails {cls cl} : check cls cl = Valid -> valid_entailment cls cl. Proof. destruct cl as [prems [concl k]]. - funelim (check cls _) => //. - set (V := clause_levels (succ_clause _) ∪ clauses_levels cls) in *. - clear Heqcall => _. cbn [concl fst snd] in *. + funelim (check cls _) => // _. + set (V := clause_levels _ ∪ clauses_levels cls) in *. + clear Heqcall H. cbn [concl fst snd] in *. clear Heq0. unfold valid_entailment, valid_clause, level_value_above. move/check_atom_value_spec: Heq; intros h; depelim h. rename H into hgt. intros valuation ext. @@ -7160,20 +7173,17 @@ Proof. set (pm := premises_model_map _ _) in *. have nepm : defined_map pm. { apply premises_model_map_defined. - set (cl := succ_clause _) in *. + set (cl := (prems, _)) in *. move/(_ cl). rewrite Clauses.singleton_spec. congruence. } have nev : defined_map (model_model v). by apply (is_update_of_defined_map nepm vmupd). move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. set (cl := (prems, (concl0, k))) in V. - have of_lset := of_level_map_premises_model_map (succ_clauses cls) (succ_clause cl) V nepm. + have of_lset := of_level_map_premises_model_map cls cl V nepm. have tr := entails_all_trans of_lset ent. - eapply (entails_all_satisfies (l := concl0) (k := Z.succ k)) in tr. - 2:{ red. rewrite /level_value Heq0. now constructor. } - have se := (succ_clauses_equiv cls (premise cl) (concl0, k)). - cbn in se, tr. rewrite Z.add_1_r in se. - specialize (se tr). - eapply clauses_sem_entails in se ; tea. + eapply (entails_all_satisfies (l := concl0) (k := k)) in tr. + 2:{ red. rewrite /level_value he. now constructor. } + eapply clauses_sem_entails in tr ; tea. Qed. Definition invalid_entailment cls cl := @@ -7529,9 +7539,6 @@ Lemma check_entails_looping {cls cl v isl} : check cls cl = IsLooping v isl -> cls ⊢a v → succ_prems v. Proof. funelim (check cls cl) => //. - intros [=]; subst v0. clear isl0 Heqcall. - red in isl. clear Heq; move: isl. - now move/(entails_all_shift 1)/entails_all_succ_clauses. Qed. Lemma enabled_clause_ext {m m' cl} : @@ -7547,59 +7554,43 @@ Lemma check_entails_false {cls cl} : check cls cl = Invalid -> ~ entails cls cl. Proof. funelim (check cls cl) => //. - - (* Found no value for the conclusion: impossible *) - clear Heq0 Heqcall prf => _ _. - set (V := clause_levels (succ_clause cl) ∪ clauses_levels cls) in *. - destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *. - have vmupd := model_of_V v. - set (pm := premises_model_map _ _) in *. - cbn in Heq. - move/LevelMapFact.F.not_find_in_iff: Heq; apply. - apply vmupd. rewrite LevelSet.union_spec; left. - rewrite clause_levels_spec. now right. - - (* Found a value *) - set (V := clause_levels (succ_clause cl) ∪ clauses_levels cls) in *. - destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *. - rename val into conclval_v => _. clear Heq1 Heqcall prf. - unfold valid_clause, level_value_above. - move: (check_atom_value_spec (Z.succ k) conclval_v). rewrite Heq. - intros r; depelim r. rename H into nent. intros H. - have vmupd := model_updates v. - have vmok := model_ok v. - set (pm := premises_model_map _ _) in *. - have nepm : defined_map pm. - { apply premises_model_map_defined. - set (cl := succ_clause _) in *. - move/(_ cl). rewrite Clauses.singleton_spec. congruence. } - have nev : defined_map (model_model v). + set (V := clause_levels cl ∪ clauses_levels cls) in *. + destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *. + rename val into conclval_v => _. clear H Heq0 Heqcall prf. cbn in he. + move: (check_atom_value_spec k conclval_v). rewrite Heq. + intros r; depelim r. rename H into nent. intros H. + have vmupd := model_updates v. + have vmok := model_ok v. + set (pm := premises_model_map _ _) in *. + set (cl := (prems, _)) in V. + have nepm : defined_map pm. + { apply premises_model_map_defined. + move/(_ cl). rewrite Clauses.singleton_spec /cl. congruence. } + have nev : defined_map (model_model v). by apply (is_update_of_defined_map nepm vmupd). - move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. - set (cl := (prems, (concl, k))) in V. - move/entails_plus: H. - move/entails_model_valid/(_ _ vmok). - have en : enabled_clause (model_model v) (succ_clause (prems, (concl, k))). - { apply (@enabled_clause_ext pm). - exact: is_update_of_ext (model_updates v). - red; cbn. - have hcl : Clauses.In (succ_clause cl) (Clauses.singleton (succ_clause cl)). - { now eapply Clauses.singleton_spec. } - have hs:= @premises_model_map_min_premise_inv V _ _ hcl. firstorder. } - destruct en as [z minp]. - move/valid_clause_elim/(_ z minp). - cbn in minp. - rewrite /level_value Heq0 => h; depelim h. apply nent. - constructor. - have posz : 0 <= z. - { have hsu := model_updates v. - eapply is_update_of_ext in hsu. - have hs := min_premise_pres (succ_prems prems) hsu. - rewrite minp in hs. - set (scl := succ_clause _) in *. - have hmin := @premises_model_map_min_premise_inv V (Clauses.singleton scl) scl. - forward hmin. now apply Clauses.singleton_spec. - destruct hmin as [minp' [hmineq hpos]]. - rewrite hmineq in hs. depelim hs. lia. } - lia. + move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. + move/entails_model_valid/(_ _ vmok): H. + have [z minp] : enabled_clause (model_model v) cl. + { apply (@enabled_clause_ext pm). + exact: is_update_of_ext (model_updates v). + red; cbn. + have hcl : Clauses.In cl (Clauses.singleton cl). + { now eapply Clauses.singleton_spec. } + have hs:= @premises_model_map_min_premise_inv V _ _ hcl. firstorder. } + move/valid_clause_elim/(_ z minp). + cbn in minp. + rewrite /level_value he => h; depelim h. apply nent. + constructor. + have posz : 0 <= z. + { have hsu := model_updates v. + eapply is_update_of_ext in hsu. + have hs := min_premise_pres prems hsu. + rewrite minp in hs. + have hmin := @premises_model_map_min_premise_inv V (Clauses.singleton cl) cl. + forward hmin. now apply Clauses.singleton_spec. + destruct hmin as [minp' [hmineq hpos]]. + rewrite hmineq in hs. depelim hs. lia. } + lia. Qed. End LoopChecking. From 115d80828d2f0fd9160c5ec1144becab265230e8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 10 Sep 2025 17:22:53 +0200 Subject: [PATCH 035/164] Updated, abstract interface for loop-checking --- template-rocq/theories/PartialLoopCheckingZ.v | 845 +++++++++++++++--- template-rocq/theories/SemiLattice.v | 70 ++ 2 files changed, 772 insertions(+), 143 deletions(-) create mode 100644 template-rocq/theories/SemiLattice.v diff --git a/template-rocq/theories/PartialLoopCheckingZ.v b/template-rocq/theories/PartialLoopCheckingZ.v index aebfec975..38567e39e 100644 --- a/template-rocq/theories/PartialLoopCheckingZ.v +++ b/template-rocq/theories/PartialLoopCheckingZ.v @@ -90,61 +90,41 @@ Module Type LoopCheckingItf (Level : LevelOrderedType) (LevelExprSet : LevelExprSet_fun Level LevelExpr) (LevelMap : FMapOTInterface Level). - Definition model := LevelMap.t (option Z). - Definition valuation := LevelMap.t nat. - - Definition clause : Type := LevelExprSet.nonEmptyLevelExprSet × LevelExpr.t. - - Parameter clauses : Type. - Parameter clauses_of_list : list clause -> clauses. - Parameter list_of_clauses : clauses -> list clause. + (* Type of consistent models of a set of universe constraints *) + Parameter model : Type. + Notation univ := LevelExprSet.nonEmptyLevelExprSet. Inductive constraint_type := UnivEq | UnivLe. - Notation constraint := (LevelExprSet.nonEmptyLevelExprSet * constraint_type * LevelExprSet.nonEmptyLevelExprSet). - - Parameter enforce_constraint : forall (cstr : constraint) (cls : clauses), clauses. - - Parameter valid_model : forall (V : LevelSet.t) (U : LevelSet.t) (m : model) (cls : clauses), Type. + Notation constraint := (univ * constraint_type * univ). - Parameter model_model : forall V U m cls, valid_model V U m cls -> model. + Parameter init_model : model. - (* { model_model : model; - model_of_V :> model_of V model_model; - model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; - model_ok :> is_model cls model_model; - model_extends : model_extension V m model_model; - }. *) + (* Returns None if already declared *) + Parameter declare_level : Level.t -> model -> option model. - Infix "⊂_lset" := LevelSet.Subset (at level 70). + (* If the constraints mention undeclared universes, returns None, + otherwise, returns either a model or a looping universe, i.e. such that u >= u + 1 is implied + by the constraint *) + Parameter enforce : constraint -> model -> option (model + univ). - Parameter enforce_clauses : forall {V U init cls} (m : valid_model V U init cls) (cls' : clauses), option model. - - Parameter loop_on : forall w : LevelSet.t, ~ LevelSet.Empty w -> clauses -> Prop. - - Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := - | Loop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne cls) - | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). + (* Returns true is the clause is valid in the model and all its possible consistent extensions. + Returns false if the constraint results in an inconsistent set of constraints or it simply + is not valid. *) + Parameter check : model -> constraint -> bool. - Parameter init_model : clauses -> model. - Parameter clauses_levels : clauses -> LevelSet.t. - - Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). - - Parameter infer : forall (cls : clauses), infer_result (clauses_levels cls) cls. - - Parameter print_result : forall {V cls}, infer_result V cls -> string. - - Parameter print_clauses : clauses -> string. + (* Returns the valuation of the model: a minimal assignement from levels to constraints + that make the enforced clauses valid. *) + Parameter valuation : model -> LevelMap.t nat. End LoopCheckingItf. -Module LoopChecking +Module LoopCheckingImpl (* Signature of levels: decidable, ordered type *) (Level : LevelOrderedType) (LevelSet : LevelSet_fun Level) (LevelExpr : LevelExprItf Level) (LevelExprSet : LevelExprSet_fun Level LevelExpr) - (LevelMap : FMapOTInterface Level) <: LoopCheckingItf Level LevelSet LevelExpr LevelExprSet LevelMap. + (LevelMap : FMapOTInterface Level). Definition level (e : LevelExpr.t) : Level.t := fst e. Definition levels (e : LevelExprSet.t) := @@ -482,12 +462,10 @@ Module NonEmptySetFacts. intuition auto. Qed. - End NonEmptySetFacts. Import NonEmptySetFacts. Notation univ := nonEmptyLevelExprSet. - Definition clause : Type := univ × LevelExpr.t. Module Clause. @@ -798,10 +776,10 @@ Definition check_model (cls : clauses) (wm : LevelSet.t × model) : option (Leve Infix "=m" := LevelMap.Equal (at level 50). -Definition strict_update m '(prems, (l, k)) m' := +Definition strict_update m '(prems, (concl, k)) m' := exists v, - [/\ min_premise m prems = Some v, ~~ level_value_above m l (k + v) & - m' =m (LevelMap.add l (Some (k + v)) m)]. + [/\ min_premise m prems = Some v, ~~ level_value_above m concl (k + v) & + m' =m (LevelMap.add concl (Some (k + v)) m)]. Inductive strictly_updates cls : LevelSet.t -> model -> model -> Prop := | update_one m cl m' : Clauses.In cl cls -> @@ -2134,6 +2112,13 @@ Definition defined_model_of V (m : model) := Definition only_model_of V (m : model) := forall k, LevelSet.In k V <-> exists x, LevelMap.MapsTo k x m. +Lemma only_model_of_model_of {V m} : only_model_of V m -> model_of V m. +Proof. + intros om l. move/om. intros [k hm]; now exists k. +Qed. + +Coercion only_model_of_model_of : only_model_of >-> model_of. + Definition check_model_invariants cls w m w' m' (modified : bool) := if modified then [/\ w ⊂_lset w', @@ -2726,7 +2711,8 @@ Variant in_pred_closure cls : clause -> Prop := Derive Signature for in_pred_closure. Inductive entails (cls : clauses) : clause -> Prop := -| clause_in (prems : nonEmptyLevelExprSet) (concl : LevelExpr.t) : LevelExprSet.In concl prems -> entails cls (prems, concl) +| clause_in (prems : nonEmptyLevelExprSet) (concl : LevelExpr.t) : + LevelExprSet.In concl prems -> entails cls (prems, concl) | clause_cut prems' concl' prems concl : in_pred_closure cls (prems', concl') -> entails cls (add concl' prems, concl) -> @@ -5519,13 +5505,6 @@ Proof. depelim lt. constructor. lia. Qed. -Lemma only_model_of_model_of {V m} : only_model_of V m -> model_of V m. -Proof. - intros om l. move/om. intros [k hm]; now exists k. -Qed. - -Coercion only_model_of_model_of : only_model_of >-> model_of. - Lemma entails_any V cls m nem m' nem' : only_model_of V m -> cls ⊢a of_level_map m nem → of_level_map m' nem' -> @@ -6038,91 +6017,10 @@ Definition print_clauses (cls : clauses) := print_list (fun '(l, r) => print_premise l ^ " → " ^ to_string_expr r) nl list. -Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) - (prf : clauses_levels cls ⊂_lset V /\ clauses_levels cls' ⊂_lset V /\ only_model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := - | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m m _. -Proof. - split. - - intros x. rewrite clauses_levels_spec. - move=> [] cl. rewrite Clauses.union_spec. - intros [[] incls]. apply H. apply clauses_levels_spec. exists cl. split => //. - apply H0. apply clauses_levels_spec. exists cl; split => //. - - exact H1. - - eapply is_update_of_empty. -Qed. - - -(* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by - setting a minimal value for the new atoms in [clauses_levels cls \ V] - such that the new clauses [cls] do not hold vacuously. -*) -(* Equations? infer_extension {V W init cls} (m : valid_model V W init cls) (cls' : clauses) : - result (LevelSet.union (clauses_levels cls') V) LevelSet.empty (Clauses.union cls cls') (min_model m.(model_model) cls') := - infer_extension m cls' := - infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model m.(model_model) cls') cls cls' _. -Proof. - repeat split. - - pose proof (model_clauses_conclusions m). intros x. lsets. - - pose proof (clauses_conclusions_levels cls'). lsets. - - red. intros. - unfold min_model. rewrite min_model_map_levels. - pose proof (model_of_V m k). - apply LevelSet.union_spec in H as []; auto. -Qed. - -Definition enforce_clauses {V W init cls} (m : valid_model V W init cls) cls' : option model := - match infer_extension m cls' with - | Loop _ _ _ => None - | Model w m _ => Some m.(model_model) - end. -*) -(* Definition enforce_clause {V W init cls} (m : valid_model V W init cls) cl : option model := - enforce_clauses m (Clauses.singleton cl). *) - -Inductive constraint_type := UnivEq | UnivLe. - -Notation constraint := (nonEmptyLevelExprSet * constraint_type * nonEmptyLevelExprSet)%type. - -Definition enforce_constraint (cstr : constraint) (cls : clauses) : clauses := - let '(l, d, r) := cstr in - match d with - | UnivLe => - LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) l cls - | UnivEq => - let cls := - LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) l cls - in - let cls' := - LevelExprSet.fold (fun rk acc => Clauses.add (l, rk) acc) r cls - in cls' - end. - Definition clauses_of_list := ClausesProp.of_list. Definition list_of_clauses := Clauses.elements. Definition valuation := LevelMap.t nat. -Definition add_max l k m := - match LevelMap.find l m with - | Some k' => - if (k' LevelMap.add l k m - end. - -Lemma In_add_max l l' k acc : - LevelMap.In (elt:=nat) l (add_max l' k acc) <-> - (l = l' \/ LevelMap.In l acc). -Proof. - unfold add_max. - destruct LevelMap.find eqn:hl. - - case: Nat.ltb_spec. - + rewrite LevelMapFact.F.add_in_iff /Level.eq. - firstorder eauto. - + intros. intuition auto. subst. - now rewrite LevelMapFact.F.in_find_iff hl. - - LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. -Qed. - Definition premises_model_map (m : model) cls : model := let levels := clauses_premises_levels cls in LevelSet.fold (fun l acc => @@ -7121,17 +7019,19 @@ Variant check_result {cls} := | Valid. Arguments check_result : clear implicits. -Equations check_atom_value (z : Z) (l : option Z) : bool := - | _, None => false - | z, Some v => z <=? v. +Equations check_atom_value (z : option Z) (l : option Z) : bool := + | Some _, None => false + | Some z, Some v => z <=? v + | None, _ => true. -Lemma check_atom_value_spec z l : reflectProp (Some z ≤ l) (check_atom_value z l). +Lemma check_atom_value_spec z l : reflectProp (z ≤ l) (check_atom_value z l). Proof. funelim (check_atom_value z l). - destruct (Z.leb_spec z v); constructor. * now constructor. * intros h; depelim h. lia. - constructor. intros h; depelim h. + - constructor. constructor. Qed. Lemma valid_model_find {V W cl cls} : @@ -7139,7 +7039,7 @@ Lemma valid_model_find {V W cl cls} : ~ LevelMap.find (concl cl).1 (model_model v) = None. Proof. intros v hfind. - destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *; cbn in *. + destruct cl as [prems [concl k]]; unfold LoopCheckingImpl.concl, snd in *; cbn in *. have vmupd := model_of_V v. set (pm := premises_model_map _ _) in *. move/LevelMapFact.F.not_find_in_iff: hfind; apply. @@ -7151,12 +7051,22 @@ Equations check (cls : clauses) (cl : clause) : check_result cls := check cls cl with loop_check cls cl := | Loop v isl => IsLooping v isl | Model W v _ with inspect (LevelMap.find (concl cl).1 v.(model_model)) := { - | exist (Some val) he with check_atom_value (concl cl).2 val := + | exist (Some val) he with check_atom_value (Some (concl cl).2) val := { | true => Valid | false => Invalid } | exist None he with valid_model_find v he := {} }. +Definition check_clauses (cls : clauses) (cls' : clauses) : bool := + let check_one cl := + match check cls cl with + | IsLooping v isl => false + | Valid => true + | Invalid => false + end + in + Clauses.for_all check_one cls'. + (* If a clause checks, then it should be valid in any extension of the model *) Lemma check_entails {cls cl} : check cls cl = Valid -> valid_entailment cls cl. @@ -7555,9 +7465,9 @@ Lemma check_entails_false {cls cl} : Proof. funelim (check cls cl) => //. set (V := clause_levels cl ∪ clauses_levels cls) in *. - destruct cl as [prems [concl k]]; unfold LoopChecking.concl, snd in *. + destruct cl as [prems [concl k]]; unfold LoopCheckingImpl.concl, snd in *. rename val into conclval_v => _. clear H Heq0 Heqcall prf. cbn in he. - move: (check_atom_value_spec k conclval_v). rewrite Heq. + move: (check_atom_value_spec (Some k) conclval_v). rewrite Heq. intros r; depelim r. rename H into nent. intros H. have vmupd := model_updates v. have vmok := model_ok v. @@ -7593,4 +7503,653 @@ Proof. lia. Qed. -End LoopChecking. +Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) + (prf : clauses_levels cls ⊂_lset V /\ clauses_levels cls' ⊂_lset V /\ only_model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := + | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m m _. +Proof. + split. + - intros x. rewrite clauses_levels_spec. + move=> [] cl. rewrite Clauses.union_spec. + intros [[] incls]. apply H. apply clauses_levels_spec. exists cl. split => //. + apply H0. apply clauses_levels_spec. exists cl; split => //. + - exact H1. + - eapply is_update_of_empty. +Qed. + + +(* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by + setting a minimal value for the new atoms in [clauses_levels cls \ V] + such that the new clauses [cls] do not hold vacuously. +*) + +Variant level_value_spec (m : model) (l : Level.t) : option Z -> Prop := +| level_value_in k : LevelMap.MapsTo l k m -> level_value_spec m l k +| level_value_nin : ~ LevelMap.In l m -> level_value_spec m l None. + +Lemma level_valueP {m l} : level_value_spec m l (level_value m l). +Proof. + rewrite /level_value. + case: find_spec. + - now move=> k0 hm; apply level_value_in. + - now move=> hnin; apply level_value_nin. +Qed. + +Lemma maps_to_update {l k} {m : model} {k'} : LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m <-> k = k'. +Proof. + firstorder. now eapply LevelMapFact.F.MapsTo_fun in H; tea. now subst. +Qed. + +Equations add_max (l : Level.t) (k : option Z) (m : model) : model := +add_max l k m with level_value m l := + { | Some k' with check_atom_value k (Some k') := + { | true => m + | false => LevelMap.add l k m } + | None => LevelMap.add l k m }. + +Lemma nleq k k' : ~ k ≤Z Some k' -> exists z, k = Some z /\ k' < z. +Proof. + destruct k. + - exists z. split => //. eapply Znot_ge_lt => hl; apply H. constructor. lia. + - elim. constructor. +Qed. + +Lemma add_max_spec l l' k k' (m : model) : + LevelMap.MapsTo l k (add_max l' k' m) <-> + (l = l' /\ k = max_opt_of Z.max k' (level_value m l)) \/ + (l <> l' /\ LevelMap.MapsTo l k m). +Proof. + funelim (add_max l' k' m). + - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. firstorder; subst. + left. split => //. rewrite Heq. now rewrite max_opt_of_l. + left. firstorder. now rewrite Heq max_opt_of_l. + - clear Heqcall. + destruct (eq_dec l0 l). + * subst l0. rewrite Heq0. + move/check_atom_value_spec: Heq. + rewrite (maps_to_update (level_value_MapsTo' Heq0)). + firstorder; subst; try left; try split; auto; depelim Heq; cbn; lia_f_equal. + * firstorder. + - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. + have := check_atom_value_spec k (Some k'). rewrite {}Heq. + intros h; depelim h. apply nleq in H as [z [-> hlt]]. + firstorder; subst. + * left; split => //. rewrite Heq0 //=. lia_f_equal. + * left; split => //. rewrite Heq0 //=. lia_f_equal. +Qed. + +Definition min_model_clause cl m := + LevelExprSet.fold (fun '(l, k) acc => add_max l (Some k) acc) (premise cl) + (add_max (concl cl) None m). + +Definition min_model_map (m : model) cls : model := + Clauses.fold min_model_clause cls m. + +Lemma In_add_max l l' k acc : + LevelMap.In l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). +Proof. + rewrite /LevelMap.In. + rw add_max_spec. firstorder subst. + eexists; left; eauto. + destruct (eq_dec l l'); subst; eexists; eauto. +Qed. + +Definition is_max k' k l acc := + match LevelMap.find l acc with + | Some k'' => k' = Nat.max k k'' + | _ => k' = k + end. + +Lemma max_opt_of_spec {x y k'} : max_opt_of Z.max x y = k' -> + (x ≤ y /\ k' = y) \/ (y ≤ x /\ k' = x). +Proof. + destruct x, y; cbn; firstorder subst. + - destruct (Z.max_spec z z0) as [[]|[]]; + [left|right]; split; try constructor; lia_f_equal. + - right. split; constructor. + - left. split; constructor. + - left; split; constructor. +Qed. + +(*Lemma In_fold_aadd_dd_max k n a : + LevelMap.In (elt:=nat) k + (LevelExprSet.fold + (fun '(l, k0) acc => add_max l k0 acc) n a) <-> + (LevelSet.In k (levels n)) \/ LevelMap.In k a. +Proof. + eapply LevelExprSetProp.fold_rec. + - intros s' he. + rewrite (LevelExprSetProp.empty_is_empty_1 he). + cbn. unfold levels. rewrite LevelExprSetProp.fold_empty. rewrite LevelSetFact.empty_iff. intuition auto. + - intros. + destruct x as [l k']. + rewrite In_add_max. + rewrite H2 !levelexprset_levels_spec. + split. + * intros []; subst. + left. exists k'. apply H1. now left. + destruct H3 as [[k'' ?]|?]. left; exists k''. apply H1. now right. + now right. + * red in H1. setoid_rewrite H1. + intros [[k'' []]|]. noconf H3. now left. + right. now left; exists k''. right; right. apply H3. +Qed.*) + + +Definition max_of_premises l kl n := + (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ kl). + +Definition is_expr l (e : LevelExpr.t) := + let '(concl, k) := e in concl = l. + +Definition max_of_clause l kl cl := + max_of_premises l kl (premise cl). + +Definition max_of_map l kl m := + (forall kl', LevelMap.MapsTo l kl' m -> kl' ≤ kl). + +Definition is_max_of_clause_and_map l cl m k := + max_of_premises l k (premise cl) /\ max_of_map l k m. + +Definition is_in_premise l k (u : LevelExprSet.t) := + (exists kl, LevelExprSet.In (l, kl) u /\ k = Some kl). + +Definition is_in_clause l k (cl : clause) := + is_in_premise l k (premise cl) \/ (l = (clause_conclusion cl) /\ k = None). + +Definition is_max_of_clause_model l cl m k := + is_max_of_clause_and_map l cl m k /\ + (is_in_clause l k cl \/ LevelMap.MapsTo l k m). + +Definition is_higher l k m := exists k', LevelMap.MapsTo l k' m /\ k ≤ k'. + +Definition is_max_of_clause_map (map : model) l cl (m : model) : Prop := + (forall k, LevelMap.MapsTo l k map -> is_max_of_clause_model l cl m k) + /\ (forall l k, LevelMap.MapsTo l k m \/ is_in_clause l k cl -> is_higher l k map). + + +Lemma max_opt_of_le_l z z' : z ≤ max_opt_of Z.max z z'. +Proof. + destruct z, z'; cbn; constructor; lia. +Qed. + +Lemma max_opt_of_le_r z z' : z' ≤ max_opt_of Z.max z z'. +Proof. + destruct z, z'; cbn; constructor; lia. +Qed. + +Lemma is_higher_le l k l' k' m : is_higher l k m -> is_higher l k (add_max l' k' m). +Proof. + rewrite /is_higher. + rw add_max_spec. + intros [k'0 [hm hle]]. + destruct (eq_dec l l'). + - subst. eexists. split; eauto. rewrite (level_value_MapsTo hm). + transitivity k'0 => //. apply max_opt_of_le_r. + - exists k'0. split; eauto. +Qed. + +Lemma is_higher_add l k m : is_higher l k (add_max l k m). +Proof. + rewrite /is_higher. + rw add_max_spec. eexists. split; eauto. + apply max_opt_of_le_l. +Qed. + +Lemma is_higher_mon l k k' m : is_higher l k' m -> k ≤ k' -> is_higher l k m. +Proof. + intros [? []] le. exists x. split => //. now transitivity k'. +Qed. + +Lemma MapsTo_fold_add_max l n a : + let map := LevelExprSet.fold (fun '(l, k0) acc => add_max l (Some k0) acc) n a in + (forall k, LevelMap.MapsTo l k map -> + ((exists kl, + [/\ LevelExprSet.In (l, kl) n, k = Some kl, + (forall kl', LevelExprSet.In (l, kl') n -> kl' <= kl) & + (forall kl', LevelMap.MapsTo l kl' a -> kl' ≤ Some kl)]) \/ + (LevelMap.MapsTo l k a /\ (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ k)))) + /\ (forall l k, LevelMap.MapsTo l k a \/ is_in_premise l k n -> is_higher l k map) /\ + a ⩽ map. + (* ~ LevelMap.In l map -> ~ (exists k, LevelExprSet.In (l, k) n) /\ ~ (LevelMap.In l a)). *) +Proof. + eapply LevelExprSetProp.fold_rec. + - intros s' he. cbn. + rewrite /is_in_premise /is_higher. + setoid_rewrite (LevelExprSetProp.empty_is_empty_1 he). + intuition auto. right. split; eauto. + intros kl. now move/LevelExprSet.empty_spec. + exists k; split => //. reflexivity. + destruct H0 as [x [hin ->]]. now apply LevelExprSet.empty_spec in hin. + reflexivity. + - cbn; intros. + destruct x as [xl k']. split. + 2:{ split. + { intros l0 hnin. destruct H2 as [hm [H2 _]]. specialize (H2 l0). + intros [ina|ins'']. + { specialize (H2 hnin (or_introl ina)). eapply is_higher_le; tea. } + { destruct ins'' as [x [ins'' ->]]. + apply H1 in ins'' as [[=]|ins']. + * subst. apply is_higher_add. + * apply is_higher_le, H2. right. eexists; eauto. } } + { destruct H2 as [_ [_ H2]]. + intros l' hin. move/H2 => [k'0 [hm hle]]. + rw add_max_spec. destruct (eq_dec l' xl). + - eexists; split. left; eauto. subst l'. + rewrite (level_value_MapsTo hm). transitivity (k'0) => //. + apply max_opt_of_le_r. + - eexists; split; eauto. } } + intros. + rewrite add_max_spec in H3; destruct H3 as [[<- hk]|[hdiff hm]]. + * destruct H2 as [hin hnin]. symmetry in hk. + have [[leacc eqms]|[len eqms]] := max_opt_of_spec hk. + { depelim leacc. specialize (hin _ (level_value_MapsTo' H3)) as [[kl [inkl [= <-] les' lea]]|]. + { left. exists y. split => //. apply H1; now right. congruence. intros. + apply H1 in H4 as [[=]|ins']. 2:now apply les'. subst kl'. lia. } + { destruct H4. right. split. now rewrite -H3 -eqms in H4. intros. + apply H1 in H6 as [[=]|ins']; subst; trea. rewrite H3; cbn; constructor; lia_f_equal. + rewrite H3; cbn; constructor. apply H5 in ins'. depelim ins'. lia. } } + { left. exists k'. split => //. + * apply H1. now left. + * move=> kl' /H1 [[=]|ins']. lia. depelim len. transitivity x; tea. specialize (hin _ (level_value_MapsTo' H3)) as + [[kl [inkl [= <-] les' lea]]|[]]. + { now eapply les'. } + { specialize (H5 _ ins'). depelim H5. lia. } + { move: H2 hk. rewrite /level_value. destruct (find_spec l a0). + * intros ->. apply hin in H2 as [[kl []]|[hm hkl']] => //. apply hkl' in ins'. depelim ins'. + * intros _; cbn; intros <-. + destruct hnin as [hnin _]. + specialize (hnin l (Some kl')); forward hnin. right. + red. exists kl'. split => //. + destruct hnin as [ka [hma hge]]. elim H2. now exists ka. } + * subst k. intros kl' mt. move: len. case: level_valueP => [k ma0 le|]. + specialize (hin _ ma0) as [[kl []]|[hm hkl']] => //. + + subst k. eapply H5 in mt. now depelim le; depelim mt; constructor; lia. + + transitivity k => //. eapply LevelMapFact.F.MapsTo_fun in mt; tea. subst. reflexivity. + + intros hnin' _. destruct hnin as [hnin _]. specialize (hnin l kl'). + forward hnin. now left. destruct hnin as [? [hm ?]]. elim hnin'. now exists x. } + * destruct H2. eapply H2 in hm as [[kl []]|[hm hkl']] => //. + { left. exists kl. split => //. apply H1. now right. intros kl' h. subst k. + apply H6. apply H1 in h. destruct h as [[=]|?] => //. subst. congruence. } + { right. split => //. intros kl' hin. apply H1 in hin as [[=]|?] => //; subst; try congruence. eauto. } +Qed. + +Lemma min_model_clause_spec l cl a : + let map := min_model_clause cl a in + is_max_of_clause_map map l cl a. +Proof. + intros m. rewrite /is_max_of_clause_map /is_max_of_clause_model. + have h := MapsTo_fold_add_max l (premise cl) (add_max (concl cl) None a). + change (LevelExprSet.fold (fun '(l, k0) (acc : model) => add_max l (Some k0) acc) (premise cl) + (add_max (concl cl) None a)) with (min_model_clause cl a) in h. + cbn in h. destruct h. split. + - intros k hm. specialize (H k hm) as [[kl []]|[hm' hle]]. + * split => //. subst k. red. split. intros kl' hin. constructor. now apply H2. + move=> kl' hm''. specialize (H3 kl'). + rewrite add_max_spec in H3. forward H3. + destruct (eq_dec l (concl cl)). + { subst l. left. split => //. rewrite max_opt_of_r. apply level_value_MapsTo in hm''. now rewrite hm''. } + { right. split => //. } + exact H3. left. + red. left. red. subst k. eauto. + * rewrite add_max_spec in hm'. + rewrite max_opt_of_r in hm'. destruct hm' as [[]|[]]; try subst l. + { repeat split => //. + { intros l hin'. subst k. rewrite (level_value_MapsTo hin'). reflexivity. } + { destruct k. right. symmetry in H1. now apply level_value_MapsTo' in H1. + left. red. right. split => //. } } + { split => //. split => //. + { intros l' hin'. eapply LevelMapFact.F.MapsTo_fun in H1; tea. subst. reflexivity. } + firstorder. } + - intros l' k. destruct H0 as [H0 hext]. specialize (H0 l' k). + intros [hm|hinc]. + { forward H0. left. rewrite add_max_spec. + destruct (eq_dec l' (concl cl)); eauto. + { left. split => //. rewrite max_opt_of_r. + now rewrite (level_value_MapsTo hm). } + destruct H0 as [? [hinm hle]]. + eapply is_higher_mon; tea. exists x. split; eauto. reflexivity. } + { red in hinc. destruct hinc. apply H0. now right. + destruct H1 as [-> ->]. + destruct (eq_dec l (concl cl)). + red. + destruct (LevelMap.find (concl cl) a) eqn:hl. + * apply LevelMap.find_2 in hl. + specialize (hext (concl cl) o). + forward hext. rewrite add_max_spec. left. split => //. + rewrite max_opt_of_r. now rewrite (level_value_MapsTo hl). + destruct hext as [k' []]. exists k'. split => //. constructor. + * specialize (hext (concl cl) None). + forward hext. rewrite add_max_spec. left. split => //. + now rewrite /level_value hl. + destruct cl; unfold clause_conclusion in *. exact hext. + * specialize (hext (concl cl) (level_value a (concl cl))). + forward hext. rewrite add_max_spec. left. split => //. + destruct hext as [l' []]; exists l'; split => //. constructor. } +Qed. + +Lemma min_model_map_acc l cls m : + let map := min_model_map m cls in + (forall k, LevelMap.MapsTo l k map -> max_of_map l k m) /\ + m ⩽ map. +Proof. + cbn. rewrite /min_model_map. + eapply ClausesProp.fold_rec. + 2:{ intros. destruct H2 as [hf hin]. + have [hm hnin] := min_model_clause_spec l x a. + split. + intros k. + move/hm. rewrite /is_max_of_clause_model. intros [[ism' ism] hasm]. + destruct hasm; eauto. intros kl'. move/hin => [k' [hmk' lek']]. + red in ism. specialize (ism _ hmk'). now transitivity k'. + transitivity a => //. + intros l' k ha. specialize (hnin l' k (or_introl ha)). + exact hnin. } + split; [|reflexivity]. + intros k hin k' hin'. + eapply LevelMapFact.F.MapsTo_fun in hin; tea. subst; reflexivity. +Qed. + +Lemma max_of_map_ext l k m m' : m ⩽ m' -> max_of_map l k m' -> max_of_map l k m. +Proof. + intros hext hm l'; move/hext => [k' [hm' le]]. + apply hm in hm'. now transitivity k'. +Qed. + +Lemma mapsto_max_of_map l k m : LevelMap.MapsTo l k m -> max_of_map l k m. +Proof. + intros hm l' k'. eapply LevelMapFact.F.MapsTo_fun in hm; tea. + subst; reflexivity. +Qed. + +Lemma min_model_map_spec l cls m : + let map := min_model_map m cls in + (forall k, LevelMap.MapsTo l k map -> + [/\ (exists cl, Clauses.In cl cls /\ is_in_clause l k cl) \/ LevelMap.MapsTo l k m, + (forall cl, Clauses.In cl cls -> max_of_premises l k (premise cl)) & max_of_map l k m]) /\ + (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l map) /\ + m ⩽ map. +Proof. + cbn. + rewrite /min_model_map. + have hgen : forall cls m, (forall k, LevelMap.MapsTo l k (Clauses.fold min_model_clause cls m) -> + [/\ (exists cl : Clauses.elt, Clauses.In cl cls /\ is_in_clause l k cl) \/ + LevelMap.MapsTo l k m, + forall cl : Clauses.elt, Clauses.In cl cls -> max_of_premises l k (premise cl) + & max_of_map l k (Clauses.fold min_model_clause cls m)]) /\ + (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l (Clauses.fold min_model_clause cls m)) /\ + m ⩽ Clauses.fold min_model_clause cls m. + 2:{ specialize (hgen cls m). destruct hgen as [hgen [hcls H]]; split; eauto. + intros k hm. specialize (hgen k hm) as [] => //. + split => //. eapply max_of_map_ext; tea. } + clear. + intros cls m. + eapply ClausesProp.fold_rec. + - intros s' he. split; [ | split; [|reflexivity]]. + * intros k hin. split => //. now right. + intros cl hin'. clsets. now apply mapsto_max_of_map. + * intros cl ins'; clsets. + - intros x a s' s'' hin hnin hadd [ih [ihcls hext]]. split; [|split]; revgoals. + { transitivity a => //. intros l' hin' hm. + have := min_model_clause_spec l' x a. cbn. + intros [_ hm']. specialize (hm' l' hin'). + now forward hm' by eauto. } + { intros cl ins'' l' inlev. + apply hadd in ins'' as [<-|]. + * have := min_model_clause_spec l' x a. cbn. + intros [_ hm']. eapply clause_levels_spec in inlev as []. + + eapply levelexprset_levels_spec in H as [k' incl]. + specialize (hm' l' (Some k')). forward hm'. right. left. rewrite /is_in_premise. exists k'; eauto. + destruct hm' as [? []]; now eexists. + + subst l'. specialize (hm' (concl x) None). forward hm'. + right. right. split => //. + destruct hm' as [? []]; now eexists. + * specialize (ihcls _ H _ inlev) as [k' ina]. + have := min_model_clause_spec l' x a. cbn. + move=> [] _ /(_ l' k' (or_introl ina)). + clear. firstorder. } + intros k. + have := min_model_clause_spec l x a. cbn. + intros [hm hm'] hmk. destruct (hm _ hmk). + split => //. + { destruct H0; eauto. + { left; exists x. split => //. apply hadd. now left. } + { specialize (ih _ H0) as []. destruct H1; eauto. left. + move: H1 => [] w []; exists w; split; eauto. apply hadd. now right. } } + { move=> cl /hadd => [] [<-|hin']. + { now move: H => []. } + { specialize (hm' l k). forward hm' by (destruct H0; eauto). + intros k' h. + specialize (ihcls _ hin' l). + forward ihcls. + { eapply clause_levels_spec. left. eapply levelexprset_levels_spec. now exists k'. } + destruct ihcls as [ka ihcls]. + specialize (ih _ ihcls) as [ihm ihcls' maxm]. + specialize (ihcls' _ hin' _ h). + transitivity ka => //. + destruct H as [mp mmap]. + now apply mmap. } } + { intros kl inma. eapply LevelMapFact.F.MapsTo_fun in hmk; tea. subst. reflexivity. } +Qed. + +Equations? infer_extension {V W init cls} (m : valid_model V W init cls) + (hincl : only_model_of V init) + (hs : clauses_levels cls ⊂_lset V) + (cls' : clauses) : + result (LevelSet.union (clauses_levels cls') V) LevelSet.empty (Clauses.union cls cls') (min_model_map m.(model_model) cls') := + infer_extension m hincl hs cls' := + infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model_map m.(model_model) cls') cls cls' _. +Proof. + repeat split. + - lsets. + - lsets. + - have ms := min_model_map_spec k cls' (model_model m). + set (map := min_model_map _ _) in *. + destruct ms as [hm [hcls hext]]. + rewrite LevelSet.union_spec => [] []. + * move/clauses_levels_spec. + intros [cl [hin ink]]. + now move: hcls => /(_ _ hin _ ink). + * move/(model_of_V m k). + move=> [] x /hext. firstorder. + - have ms := min_model_map_spec k cls' (model_model m). + set (map := min_model_map _ _) in *. + destruct ms as [hm [hcls hext]]. + rewrite LevelSet.union_spec. + move=> [] v /hm [] [[cl [incl inclv]]|hm'] ihcls mmap. + * left. + red in inclv. eapply clauses_levels_spec. + exists cl. split => //. eapply clause_levels_spec. + destruct inclv as [[? []]|]. + + left. eapply levelexprset_levels_spec. now eexists. + + right. intuition. + * have [_ ho] := valid_model_only_model _ _ _ _ m hincl k. + forward ho by now exists v. now right. +Qed. + +Lemma only_model_of_min_model_map cls V m : + clauses_levels cls ⊂_lset V -> + only_model_of V m -> only_model_of V (min_model_map m cls). +Proof. + intros incl om l. + split. + - move=> /om => [] [k inm]. + have [hmap [hcls hext]] := min_model_map_spec l cls m. + specialize (hext l k inm). firstorder. + - have [hmap [hcls hext]] := min_model_map_spec l cls m. + move=> [] x /hmap => [] [excl allcl maxm]. + red in maxm. + destruct excl as [[cl [incls incl']]|inm]. + * apply incl. apply clauses_levels_spec. exists cl. split => //. + red in incl'. + apply clause_levels_spec. + clear -incl'. firstorder. subst. left. apply levelexprset_levels_spec. + firstorder. + * rewrite (om l). now exists x. +Qed. + +Module CorrectModel. + Record t {V cls} := + { the_model : model; + only_model_of_V : only_model_of V the_model; + model_updates : LevelSet.t; + clauses_declared : clauses_levels cls ⊂_lset V; + model_valid : valid_model V model_updates the_model cls }. + Arguments t : clear implicits. + + Equations? infer_extension_correct {V W init cls} (m : valid_model V W init cls) + (hincl : only_model_of V init) + (hs : clauses_levels cls ⊂_lset V) + (cls' : clauses) + (hs' : clauses_levels cls' ⊂_lset V) : (t V (Clauses.union cls cls')) + univ := + infer_extension_correct m hincl hs cls' hs' with infer_extension m hincl hs cls' := + | Loop u _ => inr u + | Model w m' _ => + inl {| + the_model := min_model_map m.(model_model) cls'; + only_model_of_V := _; + model_updates := w; clauses_declared := _; + model_valid := {| model_model := m'.(model_model) |} |}. + Proof. + - have := valid_model_only_model _ _ _ _ m hincl. + now apply only_model_of_min_model_map. + - intros x; rewrite clauses_levels_spec; rw Clauses.union_spec. + intros [cl [[hin|hin] incl]]. apply hs. apply clauses_levels_spec. clear -hin incl; firstorder. + apply hs'. apply clauses_levels_spec. clear -hin incl; firstorder. + - have vm := model_of_V m'. eapply model_of_subset; tea. lsets. + - apply m'. + - intros ?; rewrite clauses_conclusions_spec. + intros [cl [H H']]. apply Clauses.union_spec in H as [H|H]; + [apply hs|apply hs']; subst a; apply clauses_levels_spec; exists cl; split => //; + eapply clause_levels_spec; auto. + - apply m'. + Qed. + + Equations? infer_extension_valid {V cls} (m : t V cls) cls' : option (t V (Clauses.union cls cls') + univ) := + infer_extension_valid m cls' with inspect (LevelSet.subset (clauses_levels cls') V) := + | exist false heq => None + | exist true heq := Some (infer_extension_correct (model_valid m) _ _ cls' _). + Proof. + - apply only_model_of_V. + - apply m. + - now apply LevelSet.subset_spec in heq. + Qed. +End CorrectModel. + +Module Abstract. + Import CorrectModel. + Record t := + { levels : LevelSet.t; + clauses : Clauses.t; + model : CorrectModel.t levels clauses }. + + Program Definition init_model : t := + {| levels := LevelSet.empty; + clauses := Clauses.empty; + model := _ |}. + Next Obligation. + refine {| the_model := LevelMap.empty _; + only_model_of_V := _; + model_updates := LevelSet.empty; |}. + - intros l. split. lsets. + intros [x hm]. now eapply LevelMapFact.F.empty_mapsto_iff in hm. + - now intros l; rewrite clauses_levels_spec. + - refine {| model_model := LevelMap.empty _ |}. + * red. lsets. + * red. rewrite (proj2 (LevelSet.is_empty_spec _)). lsets. + reflexivity. + * now intros l; rewrite clauses_conclusions_spec. + * rewrite /is_model. eapply Clauses.for_all_spec. tc. + intros x hin. now apply Clauses.empty_spec in hin. + Qed. + + Equations? declare_level (m : t) (l : Level.t) : option t := + declare_level m l with inspect (LevelSet.mem l m.(levels)) := + | exist true _ => None + | exist false hneq => Some {| levels := LevelSet.add l m.(levels); clauses := m.(clauses) |}. + Proof. + refine {| the_model := LevelMap.add l None m.(model).(the_model); + only_model_of_V := _; + model_updates := m.(model).(model_updates); |}. + - intros k. rewrite LevelSet.add_spec /LevelSet.E.eq. + rw LevelMapFact.F.add_mapsto_iff. + have hyp := m.(model).(only_model_of_V) k. + firstorder; subst. all:rewrite /Level.eq. + * now exists None. + * exists x. right; split => //. intros ->. + apply LevelSetFact.not_mem_iff in hneq. contradiction. + - have hyp := m.(model).(clauses_declared). lsets. + - destruct m as [levels clauses vm]; cbn in *. + destruct vm as [init omofV W incl vm]. + destruct vm as [M mofV mupd mcls mok]. cbn in *. + refine {| model_model := LevelMap.add l None M |}. + * intros k. rewrite LevelSet.add_spec LevelMapFact.F.add_in_iff. firstorder. now left. + * move: mupd. + rewrite /is_update_of. + destruct (LevelSet.is_empty) eqn:hw. + now intros ->. + { apply (todo "strict update weakening"). } + * lsets. + * apply (todo "cannot activate more clauses"). + Qed. + + Equations enforce_clauses (m : t) (cls : Clauses.t) : option (t + univ) := + enforce_clauses m cls with infer_extension_valid m.(model) cls := + | None => None + | Some (inl m') => Some (inl {| model := m' |}) + | Some (inr u) => Some (inr u). + +End Abstract. +End LoopCheckingImpl. + +Module LoopChecking + (* Signature of levels: decidable, ordered type *) + (Level : LevelOrderedType) + (LevelSet : LevelSet_fun Level) + (LevelExpr : LevelExprItf Level) + (LevelExprSet : LevelExprSet_fun Level LevelExpr) + (LevelMap : FMapOTInterface Level) <: LoopCheckingItf Level LevelSet LevelExpr LevelExprSet LevelMap. + + Module Impl := LoopCheckingImpl(Level)(LevelSet)(LevelExpr)(LevelExprSet)(LevelMap). + + Definition model := Impl.Abstract.t. + + Notation univ := LevelExprSet.nonEmptyLevelExprSet. + + Inductive constraint_type := UnivEq | UnivLe. + Notation constraint := (univ * constraint_type * univ). + + Definition enforce_constraint (cstr : constraint) (cls : Impl.Clauses.t) : Impl.Clauses.t := + let '(l, d, r) := cstr in + match d with + | UnivLe => + LevelExprSet.fold (fun lk acc => Impl.Clauses.add (r, lk) acc) (LevelExprSet.t_set l) cls + | UnivEq => + let cls := + LevelExprSet.fold (fun lk acc => Impl.Clauses.add (r, lk) acc) (LevelExprSet.t_set l) cls + in + let cls' := + LevelExprSet.fold (fun rk acc => Impl.Clauses.add (l, rk) acc) (LevelExprSet.t_set r) cls + in cls' + end. + + Definition init_model := Impl.Abstract.init_model. + + (* Returns None if already declared *) + Definition declare_level l m := Impl.Abstract.declare_level m l. + + (* Returns either a model or a looping universe, i.e. such that u >= u + 1 is implied + by the constraint *) + Definition enforce c (m : model) : option (model + univ) := + Impl.Abstract.enforce_clauses m (enforce_constraint c Impl.Clauses.empty). + + (* Returns true is the clause is valid in the model and all its possible consistent extensions. + Returns false if the constraint results in an inconsistent set of constraints or it simply + is not valid. *) + Definition check m c := + Impl.check_clauses m.(Impl.Abstract.clauses) (enforce_constraint c Impl.Clauses.empty). + + (* Returns the valuation of the model: a minimal assignement from levels to constraints + that make the enforced clauses valid. *) + Definition valuation m := Impl.valuation_of_model m.(Impl.Abstract.model).(Impl.CorrectModel.the_model). + +End LoopChecking. \ No newline at end of file diff --git a/template-rocq/theories/SemiLattice.v b/template-rocq/theories/SemiLattice.v new file mode 100644 index 000000000..5c2b972b3 --- /dev/null +++ b/template-rocq/theories/SemiLattice.v @@ -0,0 +1,70 @@ +(* Distributed under the terms of the MIT license. *) +From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils. + +From MetaRocq.Common Require Universes. +From Equations Require Import Equations. +Set Equations Transparent. + + +Section Completeness. + Reserved Notation "x ≡ y" (at level 90). + Record semilattice := + { carrier :> Type; + eq : carrier -> carrier -> Prop where "x ≡ y" := (eq x y); + succ : carrier -> carrier; + join : carrier -> carrier -> carrier; + join_assoc x y z : join x (join y z) ≡ join (join x y) z; + join_comm x y : join x y ≡ join y x; + join_idem x : join x x ≡ x; + join_sub x : join x (succ x) ≡ succ x; + succ_inj : forall x y, succ x ≡ succ y -> x ≡ y; + succ_join : forall x y, succ (join x y) ≡ join (succ x) (succ y); + }. + + Notation "x ≡ y" := (eq _ x y). + + Section Derived. + Context (s : semilattice). + Definition le (x y : s) := join s x y ≡ y. + + Fixpoint add (x : s) n : s := + match n with + | 0 => x + | S n => succ _ (add x n) + end. + End Derived. + + Definition term (V : Type) : Type := list (V * nat). + Definition relation (V : Type) := term V -> term V -> Prop. + + Record presented (V : Type) := { + terms : term V -> Prop; + relations : relation V }. + + Definition valid (V : Type) (C : presented V) (t u : term V) := relations _ C t u. + + Section Terms. + Context (V : Type) (pres : presented V). + Definition succV (t : term V) := map (fun '(x, n) => (x, S n)) t. + Definition maxV (t u : term V) := t ++ u. + + Definition presents : semilattice. + Proof. + unshelve refine {| carrier := term V; eq := relations _ pres; succ := succV; join := maxV |}. + (* - intros x y z. *) + all:apply (todo "laws"). + Defined. + + Definition interp_exp (vn : V * nat) : presents := let '(v, n) := vn in [(v, n)]. + Definition interp_term (t : term V) : presents := + match t with + | [] => [] + | hd :: tl => List.fold_left (fun n x => maxV n (interp_exp x)) tl (interp_exp hd) + end. + + Lemma all_terms (x : s) : exists t : term, + + From fc2b321dba155701c36b453f81166c21768316dd Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 10 Sep 2025 18:04:51 +0200 Subject: [PATCH 036/164] Beginning of splitting into appropriate modules --- common/_RocqProject.in | 5 + common/theories/LoopChecking/Common.v | 17 + common/theories/LoopChecking/HornClauses.v | 14 + common/theories/LoopChecking/Interfaces.v | 433 ++++++++++++++ .../LoopChecking/PartialLoopChecking.v | 558 ++---------------- 5 files changed, 529 insertions(+), 498 deletions(-) create mode 100644 common/theories/LoopChecking/Common.v create mode 100644 common/theories/LoopChecking/HornClauses.v create mode 100644 common/theories/LoopChecking/Interfaces.v rename template-rocq/theories/PartialLoopCheckingZ.v => common/theories/LoopChecking/PartialLoopChecking.v (93%) diff --git a/common/_RocqProject.in b/common/_RocqProject.in index 0d0b0f701..0ee9b0f3b 100644 --- a/common/_RocqProject.in +++ b/common/_RocqProject.in @@ -14,3 +14,8 @@ theories/EnvironmentTyping.v theories/EnvironmentReflect.v theories/EnvMap.v theories/Transform.v + +theories/LoopChecking/Common.v +theories/LoopChecking/Interfaces.v +theories/LoopChecking/HornClauses.v +theories/LoopChecking/PartialLoopChecking.v \ No newline at end of file diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v new file mode 100644 index 000000000..efbc2ea75 --- /dev/null +++ b/common/theories/LoopChecking/Common.v @@ -0,0 +1,17 @@ +(* Distributed under the terms of the MIT license. *) +From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils. + +From MetaRocq.Common Require Universes. +From Equations Require Import Equations. +Set Equations Transparent. + +Ltac rw l := rewrite_strat (topdown l). +Ltac rw_in l H := rewrite_strat (topdown l) in H. + + +(* TODO move *) +Arguments exist {A P}. +Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v new file mode 100644 index 000000000..bc963c3f3 --- /dev/null +++ b/common/theories/LoopChecking/HornClauses.v @@ -0,0 +1,14 @@ +(* Distributed under the terms of the MIT license. *) +From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils. + +From MetaRocq.Common Require Universes. +From Equations Require Import Equations. +Set Equations Transparent. + +Ltac rw l := rewrite_strat (topdown l). +Ltac rw_in l H := rewrite_strat (topdown l) in H. + + diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v new file mode 100644 index 000000000..25644ea8f --- /dev/null +++ b/common/theories/LoopChecking/Interfaces.v @@ -0,0 +1,433 @@ +(* Distributed under the terms of the MIT license. *) +From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils. + +From MetaRocq.Common Require Universes. +From MetaRocq.Common Require Import LoopChecking.Common. +From Equations Require Import Equations. +Set Equations Transparent. + +Module FMapOrderedType_from_UsualOrderedType (O : UsualOrderedType). + Import O. + Definition t := O.t. + Definition eq : O.t -> O.t -> Prop := O.eq. + Definition lt : O.t -> O.t -> Prop := O.lt. + Definition eq_refl : forall x : O.t, eq x x := reflexivity. + Definition eq_sym : forall x y : O.t, eq x y -> eq y x := fun x y H => symmetry H. + + Lemma eq_trans : forall x y z, O.eq x y -> O.eq y z -> O.eq x z. + Proof. intros x y z. unfold O.eq. apply transitivity. Qed. + Lemma lt_trans : forall x y z, O.lt x y -> O.lt y z -> O.lt x z. + Proof. intros. eapply O.lt_strorder; tea. Qed. + + Lemma lt_not_eq : forall x y : O.t, lt x y -> ~ eq x y. + Proof. + intros x y H eq. do 2 red in eq. subst x. now eapply lt_strorder in H. + Qed. + + Definition compare : forall x y : O.t, Compare lt eq x y. + Proof. + intros. + case_eq (compare x y); intros. + apply EQ. abstract (destruct (compare_spec x y) => //). + apply LT. abstract (destruct (compare_spec x y) => //). + apply GT. abstract (destruct (compare_spec x y) => //). + Defined. + + Definition eq_dec : forall x y : O.t, {eq x y} + {~ eq x y} := eq_dec. +End FMapOrderedType_from_UsualOrderedType. + +Module Type LevelOrderedType. + Include UsualOrderedType. + + Parameter reflect_eq : ReflectEq t. + #[local] Existing Instance reflect_eq. + Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. + + Parameter to_string : t -> string. + +End LevelOrderedType. + +Module Type FMapOTInterface (E : UsualOrderedType). + Module OT := FMapOrderedType_from_UsualOrderedType E. + Include FMapInterface.Sfun OT. +End FMapOTInterface. + +Module Type LevelSet_fun (Level : LevelOrderedType). + Include SWithLeibniz with Module E := Level. +End LevelSet_fun. + +Module Type LevelExprItf (Level : LevelOrderedType). + Include UsualOrderedType with Definition t := (Level.t * Z)%type. + Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. +End LevelExprItf. + +Module Type LevelExprSet_fun (Level : LevelOrderedType) (LevelExpr : LevelExprItf Level). + Include SWithLeibniz with Module E := LevelExpr. + + Record nonEmptyLevelExprSet + := { t_set :> t ; + t_ne : is_empty t_set = false }. + +End LevelExprSet_fun. + +Module Type LevelSets. + (* Signature of levels: decidable, ordered type *) + Declare Module Import Level : LevelOrderedType. + Declare Module Import LevelSet : LevelSet_fun Level. + Declare Module Import LevelExpr : LevelExprItf Level. + Declare Module Import LevelExprSet : LevelExprSet_fun Level LevelExpr. + Declare Module Import LevelMap : FMapOTInterface Level. +End LevelSets. + + +Module FromLevelSets (LS : LevelSets). + Export LS. + + Definition level (e : LevelExpr.t) : Level.t := fst e. + Coercion level : LevelExpr.t >-> Level.t. + Extraction Inline level. + + Definition levels (e : LevelExprSet.t) := + LevelExprSet.fold (fun le => LevelSet.add (level le)) e LevelSet.empty. + Export LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). + + Existing Instance Level.reflect_eq. + + Module LevelSetFact := WFactsOn Level LevelSet. + Module LevelSetProp := WPropertiesOn Level LevelSet. + Module LevelSetDecide := LevelSetProp.Dec. + Module LevelMapFact := FMapFacts.WProperties_fun LevelMap.OT LevelMap. + + Ltac lsets := LevelSetDecide.fsetdec. + Notation "(=_lset)" := LevelSet.Equal (at level 0). + Infix "=_lset" := LevelSet.Equal (at level 30). + Infix "⊂_lset" := LevelSet.Subset (at level 70). + Infix "∪" := LevelSet.union (at level 70). + + +Definition print_level_nat_map (m : LevelMap.t nat) := + let list := LevelMap.elements m in + print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_nat w) nl list. + +Definition print_lset (l : LevelSet.t) := + let list := LevelSet.elements l in + print_list Level.to_string " " list. + +Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. +Module LevelExprSetProp := WPropertiesOn LevelExpr LevelExprSet. + +(* We have decidable equality w.r.t leibniz equality for sets of levels. *) +#[global, program] Instance levelexprset_reflect : ReflectEq LevelExprSet.t := + { eqb := LevelExprSet.equal }. +Next Obligation. + destruct (LevelExprSet.equal x y) eqn:e; constructor. + eapply LevelExprSet.equal_spec in e. + now eapply LevelExprSet.eq_leibniz. + intros e'. + subst y. + pose proof (@LevelExprSetFact.equal_1 x x). + forward H. reflexivity. congruence. +Qed. + +#[global] Instance levelexprset_eq_dec : Classes.EqDec LevelExprSet.t := Classes.eq_dec. + +Derive NoConfusion for LevelExprSet.nonEmptyLevelExprSet. + +(* We use uip on the is_empty condition *) +#[global, program] Instance nonEmptyLevelExprSet_reflect : ReflectEq nonEmptyLevelExprSet := + { eqb x y := eqb x.(t_set) y.(t_set) }. +Next Obligation. + destruct (eqb_spec (t_set x) (t_set y)); constructor. + destruct x, y; cbn in *. subst. + now rewrite (uip t_ne0 t_ne1). + intros e; subst x; apply H. + reflexivity. +Qed. + +(** This coercion allows to see the non-empty set as a regular [LevelExprSet.t] *) +Coercion t_set : nonEmptyLevelExprSet >-> LevelExprSet.t. +Module LevelExprSetDecide := WDecide (LevelExprSet). +Ltac lesets := LevelExprSetDecide.fsetdec. +Infix "⊂_leset" := LevelExprSet.Subset (at level 70). + +Lemma levelset_not_Empty_is_empty s : + LevelSet.is_empty s = false <-> ~ LevelSet.Empty s. +Proof. + split. + - intros H he. red in he. apply negbT in H. unshelve eapply (contraNnot _ H). + 3:exact he. intros ha. now apply LevelSetFact.is_empty_1. + - intros ne. destruct LevelSet.is_empty eqn:he => //. + eapply LevelSetFact.is_empty_2 in he. contradiction. +Qed. + +Module NonEmptySetFacts. + #[program] Definition singleton (e : LevelExpr.t) : nonEmptyLevelExprSet + := {| t_set := LevelExprSet.singleton e |}. + Next Obligation. + apply negbTE. + eapply (contra_notN (P := LevelExprSet.Empty (LevelExprSet.singleton e))). + apply LevelExprSetFact.is_empty_2. intros ne. red in ne. specialize (ne e). lesets. + Qed. + + Lemma not_Empty_is_empty s : + ~ LevelExprSet.Empty s <-> LevelExprSet.is_empty s = false. + Proof. + split. + - intro H. apply not_true_is_false. intro H'. + apply H. now apply LevelExprSetFact.is_empty_2 in H'. + - intros H he. red in he. apply negbT in H. unshelve eapply (contraNnot _ H). + 3:exact he. intros ha. now apply LevelExprSetFact.is_empty_1. + Qed. + + Program Definition add (e : LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet + := {| t_set := LevelExprSet.add e u |}. + Next Obligation. + apply not_Empty_is_empty; intro H. + eapply H. eapply LevelExprSet.add_spec. + left; reflexivity. + Qed. + + Lemma add_spec e u e' : + LevelExprSet.In e' (add e u) <-> e' = e \/ LevelExprSet.In e' u. + Proof. + apply LevelExprSet.add_spec. + Qed. + + Definition add_list : list LevelExpr.t -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet + := List.fold_left (fun u e => add e u). + + Lemma add_list_spec l u e : + LevelExprSet.In e (add_list l u) <-> In e l \/ LevelExprSet.In e u. + Proof. + unfold add_list. rewrite <- fold_left_rev_right. + etransitivity. 2:{ eapply or_iff_compat_r. etransitivity. + 2: apply @InA_In_eq with (A:=LevelExpr.t). + eapply InA_rev. } + induction (List.rev l); cbn. + - split. intuition. intros [H|H]; tas. invs H. + - split. + + intro H. apply add_spec in H. destruct H as [H|H]. + * left. now constructor. + * apply IHl0 in H. destruct H as [H|H]; [left|now right]. + now constructor 2. + + intros [H|H]. inv H. + * apply add_spec; now left. + * apply add_spec; right. apply IHl0. now left. + * apply add_spec; right. apply IHl0. now right. + Qed. + + Lemma elements_not_empty {u : nonEmptyLevelExprSet} : LevelExprSet.elements u <> []. + Proof. + rewrite -LevelExprSetProp.elements_Empty. + move/LevelExprSetFact.is_empty_1. + destruct u as [u1 u2]; cbn in *. congruence. + Qed. + + Equations to_nonempty_list (u : nonEmptyLevelExprSet) : LevelExpr.t * list LevelExpr.t := + | u with inspect (LevelExprSet.elements u) := { + | exist [] eqel => False_rect _ (elements_not_empty eqel) + | exist (e :: l) _ => (e, l) }. + + Lemma singleton_to_nonempty_list e : to_nonempty_list (singleton e) = (e, []). + Proof. + funelim (to_nonempty_list (singleton e)). bang. + clear H. + pose proof (LevelExprSet.singleton_spec e1 e). + rewrite LevelExprSetFact.elements_iff in H. + rewrite InA_In_eq in H. rewrite e0 in H. + destruct H. forward H. now left. noconf H. f_equal. + pose proof (LevelExprSet.cardinal_spec (LevelExprSet.singleton e1)). rewrite e0 in H. cbn in H. + rewrite LevelExprSetProp.singleton_cardinal in H. + destruct l => //. + Qed. + + Lemma to_nonempty_list_spec u : + let '(e, u') := to_nonempty_list u in + e :: u' = LevelExprSet.elements u. + Proof. + funelim (to_nonempty_list u). bang. now rewrite e0. + Qed. + + Lemma to_nonempty_list_spec' u : + (to_nonempty_list u).1 :: (to_nonempty_list u).2 = LevelExprSet.elements u. + Proof. + pose proof (to_nonempty_list_spec u). + now destruct (to_nonempty_list u). + Qed. + + Lemma In_to_nonempty_list (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : + LevelExprSet.In e u + <-> e = (to_nonempty_list u).1 \/ In e (to_nonempty_list u).2. + Proof. + etransitivity. symmetry. apply LevelExprSet.elements_spec1. + pose proof (to_nonempty_list_spec' u) as H. + destruct (to_nonempty_list u) as [e' l]; cbn in *. + rewrite <- H; clear. etransitivity. apply InA_cons. + eapply or_iff_compat_l. apply InA_In_eq. + Qed. + + Lemma In_to_nonempty_list_rev (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : + LevelExprSet.In e u + <-> e = (to_nonempty_list u).1 \/ In e (List.rev (to_nonempty_list u).2). + Proof. + etransitivity. eapply In_to_nonempty_list. + apply or_iff_compat_l. apply in_rev. + Qed. + + Program Definition map (f : LevelExpr.t -> LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + {| t_set := LevelExprSetProp.of_list (List.map f (LevelExprSet.elements u)) |}. + Next Obligation. + have hs := to_nonempty_list_spec u. + destruct (to_nonempty_list u). rewrite -hs. cbn. + apply not_Empty_is_empty => he. apply (he (f t)). + lesets. + Qed. + + Lemma map_spec f u e : + LevelExprSet.In e (map f u) <-> exists e0, LevelExprSet.In e0 u /\ e = (f e0). + Proof. + unfold map; cbn. + rewrite LevelExprSetProp.of_list_1 InA_In_eq in_map_iff. + split. + - intros [x [<- hin]]. exists x. split => //. + rewrite -InA_In_eq in hin. now apply LevelExprSet.elements_spec1 in hin. + - intros [x [hin ->]]. exists x. split => //. + rewrite -InA_In_eq. now apply LevelExprSet.elements_spec1. + Qed. + + Program Definition non_empty_union (u v : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + {| t_set := LevelExprSet.union u v |}. + Next Obligation. + apply not_Empty_is_empty; intro H. + assert (HH: LevelExprSet.Empty u). { + intros x Hx. apply (H x). + eapply LevelExprSet.union_spec. now left. } + apply LevelExprSetFact.is_empty_1 in HH. + rewrite t_ne in HH; discriminate. + Qed. + + + Lemma eq_univ (u v : nonEmptyLevelExprSet) : + u = v :> LevelExprSet.t -> u = v. + Proof. + destruct u as [u1 u2], v as [v1 v2]; cbn. intros X; destruct X. + now rewrite (uip_bool _ _ u2 v2). + Qed. + + Lemma eq_univ_equal (u v : nonEmptyLevelExprSet) : + LevelExprSet.Equal u v <-> u = v. + Proof. + split. + - intro H. now apply eq_univ, LevelExprSet.eq_leibniz. + - intros ->; reflexivity. + Qed. + + Lemma eq_univ_elements (u v : nonEmptyLevelExprSet) : + LevelExprSet.elements u = LevelExprSet.elements v -> u = v. + Proof. + intro H. apply eq_univ. + destruct u as [u1 u2], v as [v1 v2]; cbn in *; clear u2 v2. + eapply LevelExprSet.eq_leibniz. red. + intros x. rewrite -!LevelExprSet.elements_spec1 H //. + Qed. + + Lemma univ_expr_eqb_true_iff (u v : nonEmptyLevelExprSet) : + LevelExprSet.equal u v <-> u = v. + Proof. + split. + - intros. + apply eq_univ_equal. now apply LevelExprSet.equal_spec. + - intros ->. now apply LevelExprSet.equal_spec. + Qed. + + Lemma univ_expr_eqb_comm (u v : nonEmptyLevelExprSet) : + LevelExprSet.equal u v <-> LevelExprSet.equal v u. + Proof. + transitivity (u = v). 2: transitivity (v = u). + - apply univ_expr_eqb_true_iff. + - split; apply eq_sym. + - split; apply univ_expr_eqb_true_iff. + Qed. + + + Lemma LevelExprSet_for_all_false f u : + LevelExprSet.for_all f u = false -> LevelExprSet.exists_ (negb ∘ f) u. + Proof. + intro H. rewrite LevelExprSetFact.exists_b. + rewrite LevelExprSetFact.for_all_b in H. + all: try now intros x y []. + induction (LevelExprSet.elements u); cbn in *; [discriminate|]. + apply andb_false_iff in H; apply orb_true_iff; destruct H as [H|H]. + left; now rewrite H. + right; now rewrite IHl. + Qed. + + Lemma LevelExprSet_For_all_exprs (P : LevelExpr.t -> Prop) (u : nonEmptyLevelExprSet) + : LevelExprSet.For_all P u + <-> P (to_nonempty_list u).1 /\ Forall P (to_nonempty_list u).2. + Proof. + etransitivity. + - eapply iff_forall; intro e. eapply imp_iff_compat_r. + apply In_to_nonempty_list. + - cbn; split. + + intro H. split. apply H. now left. + apply Forall_forall. intros x H0. apply H; now right. + + intros [H1 H2] e [He|He]. subst e; tas. + eapply Forall_forall in H2; tea. + Qed. + + Lemma add_comm {le le' e} : add le (add le' e) = add le' (add le e). + Proof. + apply eq_univ_equal. intros x. + rewrite !LevelExprSet.add_spec. firstorder. + Qed. + + #[program] + Definition univ_union (prems prems' : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + {| t_set := LevelExprSet.union prems prems' |}. + Next Obligation. + destruct prems, prems'; cbn. + destruct (LevelExprSet.is_empty (LevelExprSet.union _ _)) eqn:ise => //. + eapply LevelExprSetFact.is_empty_2 in ise. + eapply not_Empty_is_empty in t_ne0, t_ne1. + destruct t_ne0. lesets. + Qed. + + Lemma univ_union_spec u u' l : + LevelExprSet.In l (univ_union u u') <-> + LevelExprSet.In l u \/ LevelExprSet.In l u'. + Proof. + destruct u, u'; unfold univ_union; cbn. + apply LevelExprSet.union_spec. + Qed. + + Lemma univ_union_add_singleton u le : univ_union u (singleton le) = add le u. + Proof. + apply eq_univ_equal. + intros x. rewrite univ_union_spec LevelExprSet.singleton_spec add_spec. + intuition auto. + Qed. + + Lemma univ_union_comm {u u'} : univ_union u u' = univ_union u' u. + Proof. + apply eq_univ_equal. + intros x. rewrite !univ_union_spec. + intuition auto. + Qed. + + Lemma univ_union_add_distr {le u u'} : univ_union (add le u) u' = add le (univ_union u u'). + Proof. + apply eq_univ_equal. + intros x. rewrite !univ_union_spec !add_spec !univ_union_spec. + intuition auto. + Qed. + +End NonEmptySetFacts. +Export NonEmptySetFacts. + + + +End FromLevelSets. \ No newline at end of file diff --git a/template-rocq/theories/PartialLoopCheckingZ.v b/common/theories/LoopChecking/PartialLoopChecking.v similarity index 93% rename from template-rocq/theories/PartialLoopCheckingZ.v rename to common/theories/LoopChecking/PartialLoopChecking.v index 38567e39e..75f5fdcb8 100644 --- a/template-rocq/theories/PartialLoopCheckingZ.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -6,93 +6,16 @@ From MetaRocq.Utils Require Import utils. From MetaRocq.Common Require Universes. From Equations Require Import Equations. -Set Equations Transparent. - -Ltac rw l := rewrite_strat (topdown l). -Ltac rw_in l H := rewrite_strat (topdown l) in H. - - -(* TODO move *) -Arguments exist {A P}. -Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. - -Module FMapOrderedType_from_UsualOrderedType (O : UsualOrderedType). - Import O. - Definition t := O.t. - Definition eq : O.t -> O.t -> Prop := O.eq. - Definition lt : O.t -> O.t -> Prop := O.lt. - Definition eq_refl : forall x : O.t, eq x x := reflexivity. - Definition eq_sym : forall x y : O.t, eq x y -> eq y x := fun x y H => symmetry H. - - Lemma eq_trans : forall x y z, O.eq x y -> O.eq y z -> O.eq x z. - Proof. intros x y z. unfold O.eq. apply transitivity. Qed. - Lemma lt_trans : forall x y z, O.lt x y -> O.lt y z -> O.lt x z. - Proof. intros. eapply O.lt_strorder; tea. Qed. - - Lemma lt_not_eq : forall x y : O.t, lt x y -> ~ eq x y. - Proof. - intros x y H eq. do 2 red in eq. subst x. now eapply lt_strorder in H. - Qed. - - Definition compare : forall x y : O.t, Compare lt eq x y. - Proof. - intros. - case_eq (compare x y); intros. - apply EQ. abstract (destruct (compare_spec x y) => //). - apply LT. abstract (destruct (compare_spec x y) => //). - apply GT. abstract (destruct (compare_spec x y) => //). - Defined. - - Definition eq_dec : forall x y : O.t, {eq x y} + {~ eq x y} := eq_dec. -End FMapOrderedType_from_UsualOrderedType. - -Module Type LevelOrderedType. - Include UsualOrderedType. - - Parameter reflect_eq : ReflectEq t. - #[local] Existing Instance reflect_eq. - Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. - - Parameter to_string : t -> string. - -End LevelOrderedType. - -Module Type FMapOTInterface (E : UsualOrderedType). - Module OT := FMapOrderedType_from_UsualOrderedType E. - Include FMapInterface.Sfun OT. -End FMapOTInterface. - -Module Type LevelSet_fun (Level : LevelOrderedType). - Include SWithLeibniz with Module E := Level. -End LevelSet_fun. -Module Type LevelExprItf (Level : LevelOrderedType). - Include UsualOrderedType with Definition t := (Level.t * Z)%type. - Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. -End LevelExprItf. +From MetaRocq.Common.LoopChecking Require Import Common Interfaces. -Module Type LevelExprSet_fun (Level : LevelOrderedType) (LevelExpr : LevelExprItf Level). - Include SWithLeibniz with Module E := LevelExpr. - - Record nonEmptyLevelExprSet - := { t_set :> t ; - t_ne : is_empty t_set = false }. - - (* Parameter map : (LevelExpr.t -> LevelExpr.t) -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet. *) - - (* Parameter map_spec : forall e f u, In e (map f u) <-> exists e0, In e0 u /\ e = (f e0). *) - -End LevelExprSet_fun. +Set Equations Transparent. -Module Type LoopCheckingItf (Level : LevelOrderedType) - (LevelSet : LevelSet_fun Level) - (LevelExpr : LevelExprItf Level) - (LevelExprSet : LevelExprSet_fun Level LevelExpr) - (LevelMap : FMapOTInterface Level). +Module Type LoopCheckingItf (LS : LevelSets). (* Type of consistent models of a set of universe constraints *) Parameter model : Type. - Notation univ := LevelExprSet.nonEmptyLevelExprSet. + Notation univ := LS.LevelExprSet.nonEmptyLevelExprSet. Inductive constraint_type := UnivEq | UnivLe. Notation constraint := (univ * constraint_type * univ). @@ -100,7 +23,7 @@ Module Type LoopCheckingItf (Level : LevelOrderedType) Parameter init_model : model. (* Returns None if already declared *) - Parameter declare_level : Level.t -> model -> option model. + Parameter declare_level : LS.Level.t -> model -> option model. (* If the constraints mention undeclared universes, returns None, otherwise, returns either a model or a looping universe, i.e. such that u >= u + 1 is implied @@ -114,356 +37,11 @@ Module Type LoopCheckingItf (Level : LevelOrderedType) (* Returns the valuation of the model: a minimal assignement from levels to constraints that make the enforced clauses valid. *) - Parameter valuation : model -> LevelMap.t nat. - + Parameter valuation : model -> LS.LevelMap.t nat. End LoopCheckingItf. -Module LoopCheckingImpl - (* Signature of levels: decidable, ordered type *) - (Level : LevelOrderedType) - (LevelSet : LevelSet_fun Level) - (LevelExpr : LevelExprItf Level) - (LevelExprSet : LevelExprSet_fun Level LevelExpr) - (LevelMap : FMapOTInterface Level). - -Definition level (e : LevelExpr.t) : Level.t := fst e. -Definition levels (e : LevelExprSet.t) := - LevelExprSet.fold (fun le => LevelSet.add (level le)) e LevelSet.empty. - Import LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). - - -Local Existing Instance Level.reflect_eq. - -Module LevelSetFact := WFactsOn Level LevelSet. -Module LevelSetProp := WPropertiesOn Level LevelSet. -Module LevelSetDecide := LevelSetProp.Dec. -Module LevelMapFact := FMapFacts.WProperties_fun LevelMap.OT LevelMap. - -Ltac lsets := LevelSetDecide.fsetdec. -Notation "(=_lset)" := LevelSet.Equal (at level 0). -Infix "=_lset" := LevelSet.Equal (at level 30). -Infix "⊂_lset" := LevelSet.Subset (at level 70). -Infix "∪" := LevelSet.union (at level 70). - -Definition print_level_nat_map (m : LevelMap.t nat) := - let list := LevelMap.elements m in - print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_nat w) nl list. - -Definition print_lset (l : LevelSet.t) := - let list := LevelSet.elements l in - print_list Level.to_string " " list. - -Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. -Module LevelExprSetProp := WPropertiesOn LevelExpr LevelExprSet. - -(* We have decidable equality w.r.t leibniz equality for sets of levels. *) -#[global, program] Instance levelexprset_reflect : ReflectEq LevelExprSet.t := - { eqb := LevelExprSet.equal }. -Next Obligation. - destruct (LevelExprSet.equal x y) eqn:e; constructor. - eapply LevelExprSet.equal_spec in e. - now eapply LevelExprSet.eq_leibniz. - intros e'. - subst y. - pose proof (@LevelExprSetFact.equal_1 x x). - forward H. reflexivity. congruence. -Qed. - -#[global] Instance levelexprset_eq_dec : Classes.EqDec LevelExprSet.t := Classes.eq_dec. - -Derive NoConfusion for LevelExprSet.nonEmptyLevelExprSet. - -(* We use uip on the is_empty condition *) -#[global, program] Instance nonEmptyLevelExprSet_reflect : ReflectEq nonEmptyLevelExprSet := - { eqb x y := eqb x.(t_set) y.(t_set) }. -Next Obligation. - destruct (eqb_spec (t_set x) (t_set y)); constructor. - destruct x, y; cbn in *. subst. - now rewrite (uip t_ne0 t_ne1). - intros e; subst x; apply H. - reflexivity. -Qed. - -(** This coercion allows to see the non-empty set as a regular [LevelExprSet.t] *) -Coercion t_set : nonEmptyLevelExprSet >-> LevelExprSet.t. -Module LevelExprSetDecide := WDecide (LevelExprSet). -Ltac lesets := LevelExprSetDecide.fsetdec. -Infix "⊂_leset" := LevelExprSet.Subset (at level 70). - -Lemma levelset_not_Empty_is_empty s : - LevelSet.is_empty s = false <-> ~ LevelSet.Empty s. -Proof. - split. - - intros H he. red in he. apply negbT in H. unshelve eapply (contraNnot _ H). - 3:exact he. intros ha. now apply LevelSetFact.is_empty_1. - - intros ne. destruct LevelSet.is_empty eqn:he => //. - eapply LevelSetFact.is_empty_2 in he. contradiction. -Qed. - -Module NonEmptySetFacts. - #[program] Definition singleton (e : LevelExpr.t) : nonEmptyLevelExprSet - := {| t_set := LevelExprSet.singleton e |}. - Next Obligation. - apply negbTE. - eapply (contra_notN (P := LevelExprSet.Empty (LevelExprSet.singleton e))). - apply LevelExprSetFact.is_empty_2. intros ne. red in ne. specialize (ne e). lesets. - Qed. - - Lemma not_Empty_is_empty s : - ~ LevelExprSet.Empty s <-> LevelExprSet.is_empty s = false. - Proof. - split. - - intro H. apply not_true_is_false. intro H'. - apply H. now apply LevelExprSetFact.is_empty_2 in H'. - - intros H he. red in he. apply negbT in H. unshelve eapply (contraNnot _ H). - 3:exact he. intros ha. now apply LevelExprSetFact.is_empty_1. - Qed. - - Program Definition add (e : LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet - := {| t_set := LevelExprSet.add e u |}. - Next Obligation. - apply not_Empty_is_empty; intro H. - eapply H. eapply LevelExprSet.add_spec. - left; reflexivity. - Qed. - - Lemma add_spec e u e' : - LevelExprSet.In e' (add e u) <-> e' = e \/ LevelExprSet.In e' u. - Proof. - apply LevelExprSet.add_spec. - Qed. - - Definition add_list : list LevelExpr.t -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet - := List.fold_left (fun u e => add e u). - - Lemma add_list_spec l u e : - LevelExprSet.In e (add_list l u) <-> In e l \/ LevelExprSet.In e u. - Proof. - unfold add_list. rewrite <- fold_left_rev_right. - etransitivity. 2:{ eapply or_iff_compat_r. etransitivity. - 2: apply @InA_In_eq with (A:=LevelExpr.t). - eapply InA_rev. } - induction (List.rev l); cbn. - - split. intuition. intros [H|H]; tas. invs H. - - split. - + intro H. apply add_spec in H. destruct H as [H|H]. - * left. now constructor. - * apply IHl0 in H. destruct H as [H|H]; [left|now right]. - now constructor 2. - + intros [H|H]. inv H. - * apply add_spec; now left. - * apply add_spec; right. apply IHl0. now left. - * apply add_spec; right. apply IHl0. now right. - Qed. - - Lemma elements_not_empty {u : nonEmptyLevelExprSet} : LevelExprSet.elements u <> []. - Proof. - rewrite -LevelExprSetProp.elements_Empty. - move/LevelExprSetFact.is_empty_1. - destruct u as [u1 u2]; cbn in *. congruence. - Qed. - - Equations to_nonempty_list (u : nonEmptyLevelExprSet) : LevelExpr.t * list LevelExpr.t := - | u with inspect (LevelExprSet.elements u) := { - | exist [] eqel => False_rect _ (elements_not_empty eqel) - | exist (e :: l) _ => (e, l) }. - - Lemma singleton_to_nonempty_list e : to_nonempty_list (singleton e) = (e, []). - Proof. - funelim (to_nonempty_list (singleton e)). bang. - clear H. - pose proof (LevelExprSet.singleton_spec e1 e). - rewrite LevelExprSetFact.elements_iff in H. - rewrite InA_In_eq in H. rewrite e0 in H. - destruct H. forward H. now left. noconf H. f_equal. - pose proof (LevelExprSet.cardinal_spec (LevelExprSet.singleton e1)). rewrite e0 in H. cbn in H. - rewrite LevelExprSetProp.singleton_cardinal in H. - destruct l => //. - Qed. - - Lemma to_nonempty_list_spec u : - let '(e, u') := to_nonempty_list u in - e :: u' = LevelExprSet.elements u. - Proof. - funelim (to_nonempty_list u). bang. now rewrite e0. - Qed. - - Lemma to_nonempty_list_spec' u : - (to_nonempty_list u).1 :: (to_nonempty_list u).2 = LevelExprSet.elements u. - Proof. - pose proof (to_nonempty_list_spec u). - now destruct (to_nonempty_list u). - Qed. - - Lemma In_to_nonempty_list (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : - LevelExprSet.In e u - <-> e = (to_nonempty_list u).1 \/ In e (to_nonempty_list u).2. - Proof. - etransitivity. symmetry. apply LevelExprSet.elements_spec1. - pose proof (to_nonempty_list_spec' u) as H. - destruct (to_nonempty_list u) as [e' l]; cbn in *. - rewrite <- H; clear. etransitivity. apply InA_cons. - eapply or_iff_compat_l. apply InA_In_eq. - Qed. - - Lemma In_to_nonempty_list_rev (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : - LevelExprSet.In e u - <-> e = (to_nonempty_list u).1 \/ In e (List.rev (to_nonempty_list u).2). - Proof. - etransitivity. eapply In_to_nonempty_list. - apply or_iff_compat_l. apply in_rev. - Qed. - - Program Definition map (f : LevelExpr.t -> LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := - {| t_set := LevelExprSetProp.of_list (List.map f (LevelExprSet.elements u)) |}. - Next Obligation. - have hs := to_nonempty_list_spec u. - destruct (to_nonempty_list u). rewrite -hs. cbn. - apply not_Empty_is_empty => he. apply (he (f t)). - lesets. - Qed. - - Lemma map_spec f u e : - LevelExprSet.In e (map f u) <-> exists e0, LevelExprSet.In e0 u /\ e = (f e0). - Proof. - unfold map; cbn. - rewrite LevelExprSetProp.of_list_1 InA_In_eq in_map_iff. - split. - - intros [x [<- hin]]. exists x. split => //. - rewrite -InA_In_eq in hin. now apply LevelExprSet.elements_spec1 in hin. - - intros [x [hin ->]]. exists x. split => //. - rewrite -InA_In_eq. now apply LevelExprSet.elements_spec1. - Qed. - - Program Definition non_empty_union (u v : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := - {| t_set := LevelExprSet.union u v |}. - Next Obligation. - apply not_Empty_is_empty; intro H. - assert (HH: LevelExprSet.Empty u). { - intros x Hx. apply (H x). - eapply LevelExprSet.union_spec. now left. } - apply LevelExprSetFact.is_empty_1 in HH. - rewrite t_ne in HH; discriminate. - Qed. - - - Lemma eq_univ (u v : nonEmptyLevelExprSet) : - u = v :> LevelExprSet.t -> u = v. - Proof. - destruct u as [u1 u2], v as [v1 v2]; cbn. intros X; destruct X. - now rewrite (uip_bool _ _ u2 v2). - Qed. - - Lemma eq_univ_equal (u v : nonEmptyLevelExprSet) : - LevelExprSet.Equal u v <-> u = v. - Proof. - split. - - intro H. now apply eq_univ, LevelExprSet.eq_leibniz. - - intros ->; reflexivity. - Qed. - - Lemma eq_univ_elements (u v : nonEmptyLevelExprSet) : - LevelExprSet.elements u = LevelExprSet.elements v -> u = v. - Proof. - intro H. apply eq_univ. - destruct u as [u1 u2], v as [v1 v2]; cbn in *; clear u2 v2. - eapply LevelExprSet.eq_leibniz. red. - intros x. rewrite -!LevelExprSet.elements_spec1 H //. - Qed. - - Lemma univ_expr_eqb_true_iff (u v : nonEmptyLevelExprSet) : - LevelExprSet.equal u v <-> u = v. - Proof. - split. - - intros. - apply eq_univ_equal. now apply LevelExprSet.equal_spec. - - intros ->. now apply LevelExprSet.equal_spec. - Qed. - - Lemma univ_expr_eqb_comm (u v : nonEmptyLevelExprSet) : - LevelExprSet.equal u v <-> LevelExprSet.equal v u. - Proof. - transitivity (u = v). 2: transitivity (v = u). - - apply univ_expr_eqb_true_iff. - - split; apply eq_sym. - - split; apply univ_expr_eqb_true_iff. - Qed. - - - Lemma LevelExprSet_for_all_false f u : - LevelExprSet.for_all f u = false -> LevelExprSet.exists_ (negb ∘ f) u. - Proof. - intro H. rewrite LevelExprSetFact.exists_b. - rewrite LevelExprSetFact.for_all_b in H. - all: try now intros x y []. - induction (LevelExprSet.elements u); cbn in *; [discriminate|]. - apply andb_false_iff in H; apply orb_true_iff; destruct H as [H|H]. - left; now rewrite H. - right; now rewrite IHl. - Qed. - - Lemma LevelExprSet_For_all_exprs (P : LevelExpr.t -> Prop) (u : nonEmptyLevelExprSet) - : LevelExprSet.For_all P u - <-> P (to_nonempty_list u).1 /\ Forall P (to_nonempty_list u).2. - Proof. - etransitivity. - - eapply iff_forall; intro e. eapply imp_iff_compat_r. - apply In_to_nonempty_list. - - cbn; split. - + intro H. split. apply H. now left. - apply Forall_forall. intros x H0. apply H; now right. - + intros [H1 H2] e [He|He]. subst e; tas. - eapply Forall_forall in H2; tea. - Qed. - - Lemma add_comm {le le' e} : add le (add le' e) = add le' (add le e). - Proof. - apply eq_univ_equal. intros x. - rewrite !LevelExprSet.add_spec. firstorder. - Qed. - - #[program] - Definition univ_union (prems prems' : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := - {| t_set := LevelExprSet.union prems prems' |}. - Next Obligation. - destruct prems, prems'; cbn. - destruct (LevelExprSet.is_empty (LevelExprSet.union _ _)) eqn:ise => //. - eapply LevelExprSetFact.is_empty_2 in ise. - eapply not_Empty_is_empty in t_ne0, t_ne1. - destruct t_ne0. lesets. - Qed. - - Lemma univ_union_spec u u' l : - LevelExprSet.In l (univ_union u u') <-> - LevelExprSet.In l u \/ LevelExprSet.In l u'. - Proof. - destruct u, u'; unfold univ_union; cbn. - apply LevelExprSet.union_spec. - Qed. - - Lemma univ_union_add_singleton u le : univ_union u (singleton le) = add le u. - Proof. - apply eq_univ_equal. - intros x. rewrite univ_union_spec LevelExprSet.singleton_spec add_spec. - intuition auto. - Qed. - - Lemma univ_union_comm {u u'} : univ_union u u' = univ_union u' u. - Proof. - apply eq_univ_equal. - intros x. rewrite !univ_union_spec. - intuition auto. - Qed. - - Lemma univ_union_add_distr {le u u'} : univ_union (add le u) u' = add le (univ_union u u'). - Proof. - apply eq_univ_equal. - intros x. rewrite !univ_union_spec !add_spec !univ_union_spec. - intuition auto. - Qed. - -End NonEmptySetFacts. -Import NonEmptySetFacts. +Module LoopCheckingImpl (LS : LevelSets). + Module Import FLS := FromLevelSets(LS). Notation univ := nonEmptyLevelExprSet. Definition clause : Type := univ × LevelExpr.t. @@ -574,10 +152,6 @@ Proof. rewrite Clauses.filter_spec. intuition auto. Qed. -Definition levelexpr_level : LevelExpr.t -> Level.t := fst. -Coercion levelexpr_level : LevelExpr.t >-> Level.t. -Extraction Inline levelexpr_level. - Definition strict_subset (s s' : LevelSet.t) := LevelSet.Subset s s' /\ ~ LevelSet.Equal s s'. @@ -608,7 +182,7 @@ Definition concl (cl : clause) := snd cl. Extraction Inline premise concl. Definition clause_levels cl := - LevelSet.union (levels (premise cl)) (LevelSet.singleton (levelexpr_level (concl cl))). + LevelSet.union (levels (premise cl)) (LevelSet.singleton (level (concl cl))). Definition clauses_levels (cls : clauses) : LevelSet.t := Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls LevelSet.empty. @@ -661,13 +235,13 @@ Qed. Lemma clause_levels_spec l cl : LevelSet.In l (clause_levels cl) <-> - LevelSet.In l (levels (premise cl)) \/ l = levelexpr_level (concl cl). + LevelSet.In l (levels (premise cl)) \/ l = level (concl cl). Proof. unfold clause_levels. now rewrite LevelSet.union_spec LevelSet.singleton_spec. Qed. -Definition clause_conclusion cl := levelexpr_level (concl cl). +Definition clause_conclusion cl := level (concl cl). Local Open Scope Z_scope. @@ -680,7 +254,7 @@ Definition level_value (m : model) (level : Level.t) : option Z := end. Definition levelexpr_value (m : model) (atom : LevelExpr.t) := - level_value m (levelexpr_level atom). + level_value m (level atom). Extraction Inline levelexpr_value. @@ -1229,22 +803,16 @@ Definition v_minus_w_bound (W : LevelSet.t) (m : model) := LevelMap.fold (fun w v acc => Z.max (option_get 0 v) acc) (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0%Z. -Definition levelexpr_k : LevelExpr.t -> Z := snd. -Coercion levelexpr_k : LevelExpr.t >-> Z. - -Definition level_expr_elt : LevelExprSet.elt -> LevelExpr.t := fun x => x. -Coercion level_expr_elt : LevelExprSet.elt >-> LevelExpr.t. - Definition premise_min (l : nonEmptyLevelExprSet) : Z := let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (B:=LevelExpr.t) (fun min atom => Z.min atom min) tl hd. + fold_left (B:=LevelExpr.t) (fun min atom => Z.min atom.2 min) tl (hd.2). Definition premise_max (l : nonEmptyLevelExprSet) : Z := let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (B:=LevelExpr.t) (fun min atom => Z.max atom min) tl hd. + fold_left (B:=LevelExpr.t) (fun min atom => Z.max atom.2 min) tl (hd.2). Definition gain (cl : clause) : Z := - (levelexpr_k (concl cl)) - (premise_min (premise cl)). + (concl cl).2 - (premise_min (premise cl)). Definition max_gain (cls : clauses) := Clauses.fold (fun cl acc => Nat.max (Z.to_nat (gain cl)) acc) cls 0%nat. @@ -1719,7 +1287,7 @@ Proof. rewrite LevelSet.add_spec. split. * intros [->|]. - left. exists (levelexpr_k x). red in H. subst. + left. exists x.2. red in H. subst. apply hadd. cbn. left. now destruct x. apply ih in H. intuition auto. @@ -1822,11 +1390,11 @@ Section MoreNonEmpty. induction l. - cbn. split. intros x [->|] => //. reflexivity. - now exists t0; split => //. + now exists p; split => //. - destruct IHl as [ha hex]. split. * intros x hin. - eapply (in_elt_inv x a [t0]) in hin as [<-|inih]. + eapply (in_elt_inv x a [p]) in hin as [<-|inih]. { cbn. rewrite fold_left_comm. { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } apply Zmin_opt_left. } @@ -1863,8 +1431,8 @@ Section MoreNonEmpty. Lemma premise_min_spec_aux s k : premise_min s = k -> - (forall x, LevelExprSet.In x s -> (k <= x)%Z) /\ - (exists x, LevelExprSet.In x s /\ k = x). + (forall x, LevelExprSet.In x s -> (k <= x.2)%Z) /\ + (exists x, LevelExprSet.In x s /\ k = x.2). Proof. unfold premise_min. move: (to_nonempty_list_spec s). @@ -1874,32 +1442,32 @@ Section MoreNonEmpty. induction l. - cbn. split. intros x [->|] => //. reflexivity. - now exists t0; split => //. + now exists p; split => //. - destruct IHl as [ha hex]. split; intros. - eapply (in_elt_inv x a [t0]) in H as [<-|inih]. - cbn. rewrite fold_left_comm. unfold level_expr_elt in *; lia. unfold level_expr_elt in *; lia. + eapply (in_elt_inv x a [p]) in H as [<-|inih]. + cbn. rewrite fold_left_comm. lia. lia. specialize (ha _ inih). cbn. rewrite fold_left_comm. lia. lia. destruct hex as [minval [inmin ih]]. cbn. rewrite fold_left_comm. lia. - destruct (Z.leb_spec a minval). - exists a. split; [intuition|]. rewrite -ih in H. unfold level_expr_elt in *; lia. + destruct (Z.leb_spec a.2 minval.2). + exists a. split; [intuition|]. rewrite -ih in H. lia. exists minval. cbn in inmin; split; [intuition auto|]. lia. Qed. Lemma premise_min_spec (s : nonEmptyLevelExprSet) : - (forall x, LevelExprSet.In x s -> premise_min s <= x) /\ - (exists x, LevelExprSet.In x s /\ premise_min s = x). + (forall x, LevelExprSet.In x s -> premise_min s <= x.2) /\ + (exists x, LevelExprSet.In x s /\ premise_min s = x.2). Proof. now apply premise_min_spec_aux. Qed. Lemma premise_max_spec_aux s k : premise_max s = k -> - (forall x, LevelExprSet.In x s -> x <= k) /\ - (exists x, LevelExprSet.In x s /\ k = x). + (forall x, LevelExprSet.In x s -> x.2 <= k) /\ + (exists x, LevelExprSet.In x s /\ k = x.2). Proof. unfold premise_max. move: (to_nonempty_list_spec s). @@ -1909,24 +1477,25 @@ Section MoreNonEmpty. induction l. - cbn. split. intros x [->|] => //. reflexivity. - now exists t0; split => //. + now exists p; split => //. - destruct IHl as [ha hex]. split; intros. - eapply (in_elt_inv x a [t0]) in H as [<-|inih]. - cbn. rewrite fold_left_comm. unfold level_expr_elt in *; lia. unfold level_expr_elt in *; lia. + eapply (in_elt_inv x a [p]) in H as [<-|inih]. + cbn. rewrite fold_left_comm. lia. lia. specialize (ha _ inih). cbn. rewrite fold_left_comm. lia. lia. destruct hex as [maxval [inmin ih]]. cbn. rewrite fold_left_comm. lia. - destruct (Z.leb_spec a maxval). - exists maxval. cbn in inmin; split; [intuition auto|]. lia. + destruct (Z.leb_spec a.2 maxval.2). + exists maxval. cbn in inmin; split; [intuition auto|]. + lia. exists a. split; [intuition|]. rewrite -ih in H. cbn in inmin. - unfold level_expr_elt in *; lia. + lia. Qed. Lemma premise_max_spec (s : nonEmptyLevelExprSet) : - (forall x, LevelExprSet.In x s -> x <= premise_max s) /\ - (exists x, LevelExprSet.In x s /\ premise_max s = x). + (forall x, LevelExprSet.In x s -> x.2 <= premise_max s) /\ + (exists x, LevelExprSet.In x s /\ premise_max s = x.2). Proof. now apply premise_max_spec_aux. Qed. @@ -1975,12 +1544,12 @@ Section MoreNonEmpty. - cbn. intros eq. split. intros x [->|] => //. exists k. split => //. reflexivity. - now exists t0; split => //. + now exists p; split => //. - cbn. rewrite fold_left_comm. intros; apply fold_comm_assoc. intros heq. apply max_opt_spec in heq as [y' [z' [eqa [eqf ->]]]]. specialize (IHl _ eqf). destruct IHl as [ha hex]. split; intros. - eapply (in_elt_inv x a [t0]) in H as [<-|inih]. + eapply (in_elt_inv x a [p]) in H as [<-|inih]. { exists y'; intuition eauto. constructor; lia. } { specialize (ha _ inih) as [k' []]. exists k'; intuition eauto. constructor. depelim H0; lia. } destruct hex as [maxval [inmax ih]]. @@ -2001,7 +1570,7 @@ End MoreNonEmpty. Lemma min_premise_pos_spec {m prem k} : min_premise m prem = Some k -> - forall x, LevelExprSet.In x prem -> Some (levelexpr_k x + k)%Z ≤Z levelexpr_value m x. + forall x, LevelExprSet.In x prem -> Some (x.2 + k)%Z ≤Z levelexpr_value m x. Proof. pose proof (min_premise_spec m prem) as [amin [exmin [inminpre eqminpre]]]. intros hprem x hin. @@ -2124,7 +1693,7 @@ Definition check_model_invariants cls w m w' m' (modified : bool) := [/\ w ⊂_lset w', w' ⊂_lset (LevelSet.union w (clauses_conclusions cls)), exists cl, - let cll := (levelexpr_level (concl cl)) in + let cll := (level (concl cl)) in [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' & opt_le Z.lt (level_value m cll) (level_value m' cll)], @@ -2198,7 +1767,7 @@ Proof. Qed. Lemma min_atom_value_levelexpr_value m l a lv : min_atom_value m l = Some a -> levelexpr_value m l = Some lv -> - (a <= lv - l). + (a <= lv - l.2). Proof. destruct l as [l k]; cbn. unfold levelexpr_value. cbn. destruct level_value => //. intros [= <-] [= <-]. lia. @@ -2450,10 +2019,10 @@ exists k', { induction l; cbn. - intros x y [= <-]. now eexists. - intros x y. - unfold min_atom_value, levelexpr_value, levelexpr_level. destruct a; cbn. + unfold min_atom_value, levelexpr_value, level. destruct a; cbn. destruct level_value => //=. eapply IHl. cbn. intros H'. exfalso. eapply H; eauto. } - - unfold min_atom_value, levelexpr_value, levelexpr_level. destruct t; cbn. + - unfold min_atom_value, levelexpr_value, level. destruct p; cbn. destruct level_value => //=. apply H0. intros; exfalso. now eapply H. Qed. @@ -2527,10 +2096,10 @@ Proof. pose proof (min_atom_value_levelexpr_value m exmin). specialize (amax _ inminpre) as amax'. rewrite eqmaxpre in amax'. destruct amax' as [vexmin [eqexmin ltexmin]]. - assert (expmin <= exmin). specialize (apmin _ inminpre). lia. + assert (expmin.2 <= exmin.2). specialize (apmin _ inminpre). lia. specialize (H4 _ _ eqminpre eqexmin). depelim ltexmin. etransitivity; tea. rewrite -eqmaxpre in H6. noconf H6. - unfold level_expr_elt in *. lia. } + lia. } transitivity (k + (maxpreml - (premise_min preml)))%Z. lia. (* assert (Z.of_nat (premise_min preml) <= maxpreml)%Z. { rewrite eqmaxpre. @@ -2542,7 +2111,7 @@ Proof. enough (maxpreml <= (v_minus_w_bound W m))%Z. lia. { have vm := v_minus_w_bound_spec W m exmax. unfold levelexpr_value in eqmaxpre. rewrite -eqmaxpre in vm. - have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). + have [hlevels _] := (@levels_exprs_non_W_atoms W prem (level exmax)). rewrite levelexprset_levels_spec in hlevels. forward hlevels. exists exmax.2. now destruct exmax. @@ -3781,8 +3350,8 @@ Section InnerLoop. pose proof (min_atom_value_levelexpr_value m exmin _ _ H2 lk'). rewrite eqminpre H2. constructor. etransitivity; tea. rewrite eqmaxpre in eqmaxp. - assert (expmin <= exmin). specialize (apmin _ inminpre). lia. - unfold level_expr_elt in *. lia. } + assert (expmin.2 <= exmin.2). specialize (apmin _ inminpre). lia. + lia. } apply Z.leb_le. rewrite H1 in H2. depelim H2. transitivity (k + (maxpreml - premise_min preml)). lia. assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff)%nat. @@ -3798,7 +3367,7 @@ Section InnerLoop. (maxpreml + k - premise_min preml)) as ->. lia. assert (maxpreml <= v_minus_w_bound W m). { pose proof (v_minus_w_bound_spec W m exmax). - have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). + have [hlevels _] := (@levels_exprs_non_W_atoms W prem (level exmax)). rewrite levelexprset_levels_spec in hlevels. forward hlevels. exists exmax.2. now destruct exmax. @@ -3975,7 +3544,7 @@ Section InnerLoop. check_model cls (w'', m) = Some (w', m') -> [/\ w'' ⊂_lset w', w' ⊂_lset (w'' ∪ w), exists cl : clause, - let cll := levelexpr_level (concl cl) in + let cll := level (concl cl) in [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' & (opt_le Z.lt (level_value m cll) (level_value m' cll))%Z] & model_extension w' m m']. @@ -4586,8 +4155,7 @@ Section InnerLoop. apply levelmap_level_value_eq => k. rewrite model_update_spec. clear -mW om hin. firstorder. - subst x. apply levelmap_level_value_eq => k. - rewrite model_update_spec. cbn in *. firstorder. cbn in H. - apply om in incl as [x hm]. now apply H in hm. + rewrite model_update_spec. cbn in *. firstorder. Qed. Lemma strictly_updates_defined_model cls W m m' : @@ -4722,7 +4290,7 @@ Section InnerLoop. { eapply model_map_outside_weaken. eapply hext. have incl := model_incl mr. lsets. } { apply hext. } eapply invalid_clause_measure in nvalid; tea. - exists (levelexpr_level (concl cll)). + exists (level (concl cll)). split => //. eapply clauses_conclusions_diff_left; tea. eapply clauses_conclusions_spec. exists cll; split => //. exact hind. @@ -5729,7 +5297,7 @@ Proof. { destruct H1 as [cl [clcls nvalid hcll hv]]. pose proof (model_ok mwc). eapply is_model_invalid_clause in H; tea. - assert (~ LevelSet.In (levelexpr_level (concl cl)) W). + assert (~ LevelSet.In (level (concl cl)) W). { intros hin. rewrite in_clauses_with_concl in H. intuition auto. } exists (concl cl). split => //. } rewrite -!diff_cardinal //. clear -w_incl clsV incl wcls_incl. have hincl := clauses_conclusions_levels cls. lsets. lsets. @@ -6194,7 +5762,7 @@ Proof. destruct to_nonempty_list. pose proof to_nonempty_list_spec'. rewrite In_elements in H. rewrite -he in H. clear H0 he. clear -H. - destruct H. subst t. + destruct H. subst p. - induction l. cbn. auto. cbn. lia. cbn. lia. - induction l in H |- *. @@ -7249,7 +6817,7 @@ Proof. rewrite {1}/min_premise. have hs' := to_nonempty_list_spec (add le prems). destruct to_nonempty_list. - have eqf : (fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (min_atom_value m t)) = + have eqf : (fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (min_atom_value m p)) = (option_map2 Z.min (min_atom_value m le) (min_premise m prems)). 2:{ now rewrite eqf. } rewrite -(to_nonempty_list_spec' (add le prems)) in hs'. noconf hs'. @@ -8101,15 +7669,9 @@ Module Abstract. End Abstract. End LoopCheckingImpl. -Module LoopChecking - (* Signature of levels: decidable, ordered type *) - (Level : LevelOrderedType) - (LevelSet : LevelSet_fun Level) - (LevelExpr : LevelExprItf Level) - (LevelExprSet : LevelExprSet_fun Level LevelExpr) - (LevelMap : FMapOTInterface Level) <: LoopCheckingItf Level LevelSet LevelExpr LevelExprSet LevelMap. - - Module Impl := LoopCheckingImpl(Level)(LevelSet)(LevelExpr)(LevelExprSet)(LevelMap). +Module LoopChecking (LS : LevelSets). + Module Impl := LoopCheckingImpl(LS). + Import Impl.FLS. Definition model := Impl.Abstract.t. From c5d988d87f29e803ba74425abd52476f85ad0756 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 10 Sep 2025 18:15:55 +0200 Subject: [PATCH 037/164] Move Clause stuff to HornClauses --- common/theories/LoopChecking/HornClauses.v | 205 ++++++++++++++++ .../LoopChecking/PartialLoopChecking.v | 227 ++---------------- 2 files changed, 219 insertions(+), 213 deletions(-) diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index bc963c3f3..26897d8c9 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -5,10 +5,215 @@ From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInte From MetaRocq.Utils Require Import utils. From MetaRocq.Common Require Universes. +From MetaRocq.Common Require Import Interfaces. From Equations Require Import Equations. Set Equations Transparent. Ltac rw l := rewrite_strat (topdown l). Ltac rw_in l H := rewrite_strat (topdown l) in H. +Module Clauses (LS : LevelSets). + Module Export FLS := FromLevelSets LS. + Notation univ := nonEmptyLevelExprSet. + Definition clause : Type := univ × LevelExpr.t. + + Module Clause. + + Definition t := clause. + + Definition eq : t -> t -> Prop := eq. + + Definition eq_equiv : RelationClasses.Equivalence eq := _. + + Inductive lt_ : t -> t -> Prop := + | lt_clause1 l e e' : LevelExpr.lt e e' -> lt_ (l, e) (l, e') + | lt_clause2 l l' b b' : LevelExprSet.lt l.(t_set) l'.(t_set) -> lt_ (l, b) (l', b'). + + Definition lt := lt_. + + Global Instance lt_strorder : RelationClasses.StrictOrder lt. + Proof. + constructor. + - intros x X; inversion X; subst. now eapply LevelExpr.lt_strorder in H1. + eapply LevelExprSet.lt_strorder; eassumption. + - intros x y z X1 X2; invs X1; invs X2; constructor; tea. + etransitivity; tea. + etransitivity; tea. + Qed. + + Definition lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt. + intros x x' H1 y y' H2. unfold lt. subst. reflexivity. + Qed. + + Definition compare (x y : t) : comparison := + match x, y with + | (l1, b1), (l2, b2) => + match LevelExprSet.compare l1.(t_set) l2.(t_set) with + | Eq => LevelExpr.compare b1 b2 + | x => x + end + end. + + Definition compare_spec : + forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y). + Proof. + intros [? ?] [? ?]; cbn; repeat constructor. + destruct (LevelExprSet.compare_spec n n0); repeat constructor; tas. + eapply LevelExprSet.eq_leibniz in H. apply NonEmptySetFacts.eq_univ in H. + subst. cbn in *. + destruct (LevelExpr.compare_spec t0 t1); repeat constructor; tas. now subst. + Qed. + + #[program] Global Instance reflect_eq_Z : ReflectEq Z := { + eqb := Z.eqb + }. + Next Obligation. + destruct (Z.eqb_spec x y); constructor => //. + Qed. + + Global Instance reflect_t : ReflectEq t := reflect_prod _ _ . + + Definition eq_dec : forall (l1 l2 : t), {l1 = l2} + {l1 <> l2} := Classes.eq_dec. + + Definition eq_leibniz (x y : t) : eq x y -> x = y := id. + + End Clause. + + Module Clauses := MSetAVL.Make Clause. + Module ClausesFact := WFactsOn Clause Clauses. + Module ClausesProp := WPropertiesOn Clause Clauses. + Module ClausesDecide := WDecide (Clauses). + Ltac clsets := ClausesDecide.fsetdec. + + Definition clauses := Clauses.t. + + Lemma filter_add {p x s} : Clauses.Equal (Clauses.filter p (Clauses.add x s)) (if p x then Clauses.add x (Clauses.filter p s) else Clauses.filter p s). + Proof. + intros i. + rewrite Clauses.filter_spec. + destruct (eqb_spec i x); subst; + destruct (p x) eqn:px; rewrite !Clauses.add_spec !Clauses.filter_spec; intuition auto || congruence. + Qed. + + Local Instance proper_fold_transpose {A} (f : Clauses.elt -> A -> A) : + transpose eq f -> + Proper (Clauses.Equal ==> eq ==> eq) (Clauses.fold f). + Proof. + intros hf s s' Hss' x ? <-. + eapply ClausesProp.fold_equal; tc; tea. + Qed. + Existing Class transpose. + + Lemma clauses_fold_filter {A} (f : Clauses.elt -> A -> A) (p : Clauses.elt -> bool) cls acc : + transpose Logic.eq f -> + Clauses.fold f (Clauses.filter p cls) acc = + Clauses.fold (fun elt acc => if p elt then f elt acc else acc) cls acc. + Proof. + intros hf. + symmetry. eapply ClausesProp.fold_rec_bis. + - intros s s' a eq. intros ->. + eapply ClausesProp.fold_equal; tc. auto. + intros x. + rewrite !Clauses.filter_spec. + now rewrite eq. + - now cbn. + - intros. + rewrite H1. + rewrite filter_add. + destruct (p x) eqn:px => //. + rewrite ClausesProp.fold_add //. + rewrite Clauses.filter_spec. intuition auto. + Qed. + + Definition strict_subset (s s' : LevelSet.t) := + LevelSet.Subset s s' /\ ~ LevelSet.Equal s s'. + + Lemma strict_subset_incl (x y z : LevelSet.t) : LevelSet.Subset x y -> strict_subset y z -> strict_subset x z. + Proof. + intros hs []. split => //. lsets. + intros heq. apply H0. lsets. + Qed. + + Lemma strict_subset_cardinal s s' : strict_subset s s' -> LevelSet.cardinal s < LevelSet.cardinal s'. + Proof. + intros []. + assert (LevelSet.cardinal s <> LevelSet.cardinal s'). + { intros heq. apply H0. + intros x. split; intros. now apply H. + destruct (LevelSet.mem x s) eqn:hin. + eapply LevelSet.mem_spec in hin. + auto. eapply LevelSetProp.FM.not_mem_iff in hin. + exfalso. + eapply LevelSetProp.subset_cardinal_lt in hin; tea. + lia. } + enough (LevelSet.cardinal s <= LevelSet.cardinal s') by lia. + now eapply LevelSetProp.subset_cardinal. + Qed. + + Definition premise (cl : clause) := fst cl. + Definition concl (cl : clause) := snd cl. + Extraction Inline premise concl. + + Definition clause_levels cl := + LevelSet.union (levels (premise cl)) (LevelSet.singleton (level (concl cl))). + + Definition clauses_levels (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls LevelSet.empty. + + Lemma Clauses_In_elements l s : + In l (Clauses.elements s) <-> Clauses.In l s. + Proof. + rewrite ClausesFact.elements_iff. + now rewrite InA_In_eq. + Qed. + + Lemma clauses_levels_spec_aux l cls acc : + LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls acc) <-> + (exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl)) \/ LevelSet.In l acc. + Proof. + eapply ClausesProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k [hin hl]]. clsets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.union_spec. + split. + * intros [hin'|]. + left. exists x. split => //. + apply hadd. now left. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. + * intros [[k [ins'' ?]]|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. + Qed. + + Lemma clauses_levels_spec l cls : + LevelSet.In l (clauses_levels cls) <-> + exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl). + Proof. + unfold clauses_levels. + rewrite clauses_levels_spec_aux. + intuition auto. lsets. + Qed. + + Instance clauses_levels_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_levels. + Proof. + intros cl cl' eq x. + rewrite !clauses_levels_spec. + now setoid_rewrite eq. + Qed. + + Lemma clause_levels_spec l cl : + LevelSet.In l (clause_levels cl) <-> + LevelSet.In l (levels (premise cl)) \/ l = level (concl cl). + Proof. + unfold clause_levels. + now rewrite LevelSet.union_spec LevelSet.singleton_spec. + Qed. + + Definition clause_conclusion cl := level (concl cl). +End Clauses. diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index 75f5fdcb8..35b3fc416 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -7,7 +7,7 @@ From MetaRocq.Utils Require Import utils. From MetaRocq.Common Require Universes. From Equations Require Import Equations. -From MetaRocq.Common.LoopChecking Require Import Common Interfaces. +From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses. Set Equations Transparent. @@ -41,209 +41,9 @@ Module Type LoopCheckingItf (LS : LevelSets). End LoopCheckingItf. Module LoopCheckingImpl (LS : LevelSets). - Module Import FLS := FromLevelSets(LS). + Module Import Clauses := Clauses(LS). -Notation univ := nonEmptyLevelExprSet. -Definition clause : Type := univ × LevelExpr.t. - -Module Clause. - Definition t := clause. - - Definition eq : t -> t -> Prop := eq. - - Definition eq_equiv : RelationClasses.Equivalence eq := _. - - Inductive lt_ : t -> t -> Prop := - | lt_clause1 l e e' : LevelExpr.lt e e' -> lt_ (l, e) (l, e') - | lt_clause2 l l' b b' : LevelExprSet.lt l.(t_set) l'.(t_set) -> lt_ (l, b) (l', b'). - - Definition lt := lt_. - - Global Instance lt_strorder : RelationClasses.StrictOrder lt. - Proof. - constructor. - - intros x X; inversion X; subst. now eapply LevelExpr.lt_strorder in H1. - eapply LevelExprSet.lt_strorder; eassumption. - - intros x y z X1 X2; invs X1; invs X2; constructor; tea. - etransitivity; tea. - etransitivity; tea. - Qed. - - Definition lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt. - intros x x' H1 y y' H2. unfold lt. subst. reflexivity. - Qed. - - Definition compare (x y : t) : comparison := - match x, y with - | (l1, b1), (l2, b2) => - match LevelExprSet.compare l1.(t_set) l2.(t_set) with - | Eq => LevelExpr.compare b1 b2 - | x => x - end - end. - - Definition compare_spec : - forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y). - Proof. - intros [? ?] [? ?]; cbn; repeat constructor. - destruct (LevelExprSet.compare_spec n n0); repeat constructor; tas. - eapply LevelExprSet.eq_leibniz in H. apply NonEmptySetFacts.eq_univ in H. - subst. cbn in *. - destruct (LevelExpr.compare_spec t0 t1); repeat constructor; tas. now subst. - Qed. - - #[program] Global Instance reflect_eq_Z : ReflectEq Z := { - eqb := Z.eqb - }. - Next Obligation. - destruct (Z.eqb_spec x y); constructor => //. - Qed. - - Global Instance reflect_t : ReflectEq t := reflect_prod _ _ . - - Definition eq_dec : forall (l1 l2 : t), {l1 = l2} + {l1 <> l2} := Classes.eq_dec. - - Definition eq_leibniz (x y : t) : eq x y -> x = y := id. -End Clause. - -Module Clauses := MSetAVL.Make Clause. -Module ClausesFact := WFactsOn Clause Clauses. -Module ClausesProp := WPropertiesOn Clause Clauses. -Module ClausesDecide := WDecide (Clauses). -Ltac clsets := ClausesDecide.fsetdec. - -Definition clauses := Clauses.t. - -Lemma filter_add {p x s} : Clauses.Equal (Clauses.filter p (Clauses.add x s)) (if p x then Clauses.add x (Clauses.filter p s) else Clauses.filter p s). -Proof. - intros i. - rewrite Clauses.filter_spec. - destruct (eqb_spec i x); subst; - destruct (p x) eqn:px; rewrite !Clauses.add_spec !Clauses.filter_spec; intuition auto || congruence. -Qed. - -Local Instance proper_fold_transpose {A} (f : Clauses.elt -> A -> A) : - transpose eq f -> - Proper (Clauses.Equal ==> eq ==> eq) (Clauses.fold f). -Proof. - intros hf s s' Hss' x ? <-. - eapply ClausesProp.fold_equal; tc; tea. -Qed. -Existing Class transpose. - -Lemma clauses_fold_filter {A} (f : Clauses.elt -> A -> A) (p : Clauses.elt -> bool) cls acc : - transpose Logic.eq f -> - Clauses.fold f (Clauses.filter p cls) acc = - Clauses.fold (fun elt acc => if p elt then f elt acc else acc) cls acc. -Proof. - intros hf. - symmetry. eapply ClausesProp.fold_rec_bis. - - intros s s' a eq. intros ->. - eapply ClausesProp.fold_equal; tc. auto. - intros x. - rewrite !Clauses.filter_spec. - now rewrite eq. - - now cbn. - - intros. - rewrite H1. - rewrite filter_add. - destruct (p x) eqn:px => //. - rewrite ClausesProp.fold_add //. - rewrite Clauses.filter_spec. intuition auto. -Qed. - -Definition strict_subset (s s' : LevelSet.t) := - LevelSet.Subset s s' /\ ~ LevelSet.Equal s s'. - -Lemma strict_subset_incl (x y z : LevelSet.t) : LevelSet.Subset x y -> strict_subset y z -> strict_subset x z. -Proof. - intros hs []. split => //. lsets. - intros heq. apply H0. lsets. -Qed. - -Lemma strict_subset_cardinal s s' : strict_subset s s' -> LevelSet.cardinal s < LevelSet.cardinal s'. -Proof. - intros []. - assert (LevelSet.cardinal s <> LevelSet.cardinal s'). - { intros heq. apply H0. - intros x. split; intros. now apply H. - destruct (LevelSet.mem x s) eqn:hin. - eapply LevelSet.mem_spec in hin. - auto. eapply LevelSetProp.FM.not_mem_iff in hin. - exfalso. - eapply LevelSetProp.subset_cardinal_lt in hin; tea. - lia. } - enough (LevelSet.cardinal s <= LevelSet.cardinal s') by lia. - now eapply LevelSetProp.subset_cardinal. -Qed. - -Definition premise (cl : clause) := fst cl. -Definition concl (cl : clause) := snd cl. -Extraction Inline premise concl. - -Definition clause_levels cl := - LevelSet.union (levels (premise cl)) (LevelSet.singleton (level (concl cl))). - -Definition clauses_levels (cls : clauses) : LevelSet.t := - Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls LevelSet.empty. - -Lemma Clauses_In_elements l s : - In l (Clauses.elements s) <-> Clauses.In l s. -Proof. - rewrite ClausesFact.elements_iff. - now rewrite InA_In_eq. -Qed. - -Lemma clauses_levels_spec_aux l cls acc : - LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls acc) <-> - (exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl)) \/ LevelSet.In l acc. -Proof. - eapply ClausesProp.fold_rec. - - intros. - intuition auto. destruct H1 as [k [hin hl]]. clsets. - - intros x a s' s'' hin nin hadd ih. - rewrite LevelSet.union_spec. - split. - * intros [hin'|]. - left. exists x. split => //. - apply hadd. now left. - apply ih in H. - intuition auto. - left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. - * intros [[k [ins'' ?]]|inacc]. - eapply hadd in ins''. destruct ins''; subst. - + now left. - + right. apply ih. now left; exists k. - + right. intuition auto. -Qed. - -Lemma clauses_levels_spec l cls : - LevelSet.In l (clauses_levels cls) <-> - exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl). -Proof. - unfold clauses_levels. - rewrite clauses_levels_spec_aux. - intuition auto. lsets. -Qed. - -Instance clauses_levels_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_levels. -Proof. - intros cl cl' eq x. - rewrite !clauses_levels_spec. - now setoid_rewrite eq. -Qed. - -Lemma clause_levels_spec l cl : - LevelSet.In l (clause_levels cl) <-> - LevelSet.In l (levels (premise cl)) \/ l = level (concl cl). -Proof. - unfold clause_levels. - now rewrite LevelSet.union_spec LevelSet.singleton_spec. -Qed. - -Definition clause_conclusion cl := level (concl cl). - -Local Open Scope Z_scope. + Local Open Scope Z_scope. Definition model := LevelMap.t (option Z). @@ -5693,7 +5493,7 @@ Proof. apply In_add_prems. exists (l, k). split => //. } { exists (add_clause n x). rewrite -add_clauses_spec. split => //. apply hadd. now left. rewrite clause_levels_spec. right. - destruct x; cbn. destruct t => //. } + destruct x; cbn. destruct p => //. } { intros [cl [hin hl]]; exists cl. split => //. move/in_add_clauses: hin => [cl' [incl' ->]]. apply add_clauses_spec. now apply hadd. } @@ -6607,7 +6407,7 @@ Lemma valid_model_find {V W cl cls} : ~ LevelMap.find (concl cl).1 (model_model v) = None. Proof. intros v hfind. - destruct cl as [prems [concl k]]; unfold LoopCheckingImpl.concl, snd in *; cbn in *. + destruct cl as [prems [concl k]]; cbn in *. have vmupd := model_of_V v. set (pm := premises_model_map _ _) in *. move/LevelMapFact.F.not_find_in_iff: hfind; apply. @@ -7033,7 +6833,7 @@ Lemma check_entails_false {cls cl} : Proof. funelim (check cls cl) => //. set (V := clause_levels cl ∪ clauses_levels cls) in *. - destruct cl as [prems [concl k]]; unfold LoopCheckingImpl.concl, snd in *. + destruct cl as [prems [concl k]]. rename val into conclval_v => _. clear H Heq0 Heqcall prf. cbn in he. move: (check_atom_value_spec (Some k) conclval_v). rewrite Heq. intros r; depelim r. rename H into nent. intros H. @@ -7671,7 +7471,8 @@ End LoopCheckingImpl. Module LoopChecking (LS : LevelSets). Module Impl := LoopCheckingImpl(LS). - Import Impl.FLS. + Import Impl.Clauses. + Import Impl.Clauses.FLS. Definition model := Impl.Abstract.t. @@ -7680,17 +7481,17 @@ Module LoopChecking (LS : LevelSets). Inductive constraint_type := UnivEq | UnivLe. Notation constraint := (univ * constraint_type * univ). - Definition enforce_constraint (cstr : constraint) (cls : Impl.Clauses.t) : Impl.Clauses.t := + Definition enforce_constraint (cstr : constraint) (cls : Clauses.t) : Clauses.t := let '(l, d, r) := cstr in match d with | UnivLe => - LevelExprSet.fold (fun lk acc => Impl.Clauses.add (r, lk) acc) (LevelExprSet.t_set l) cls + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) (LevelExprSet.t_set l) cls | UnivEq => let cls := - LevelExprSet.fold (fun lk acc => Impl.Clauses.add (r, lk) acc) (LevelExprSet.t_set l) cls + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) (LevelExprSet.t_set l) cls in let cls' := - LevelExprSet.fold (fun rk acc => Impl.Clauses.add (l, rk) acc) (LevelExprSet.t_set r) cls + LevelExprSet.fold (fun rk acc => Clauses.add (l, rk) acc) (LevelExprSet.t_set r) cls in cls' end. @@ -7702,13 +7503,13 @@ Module LoopChecking (LS : LevelSets). (* Returns either a model or a looping universe, i.e. such that u >= u + 1 is implied by the constraint *) Definition enforce c (m : model) : option (model + univ) := - Impl.Abstract.enforce_clauses m (enforce_constraint c Impl.Clauses.empty). + Impl.Abstract.enforce_clauses m (enforce_constraint c Clauses.empty). (* Returns true is the clause is valid in the model and all its possible consistent extensions. Returns false if the constraint results in an inconsistent set of constraints or it simply is not valid. *) Definition check m c := - Impl.check_clauses m.(Impl.Abstract.clauses) (enforce_constraint c Impl.Clauses.empty). + Impl.check_clauses m.(Impl.Abstract.clauses) (enforce_constraint c Clauses.empty). (* Returns the valuation of the model: a minimal assignement from levels to constraints that make the enforced clauses valid. *) From 90444ab49b3d3c2d8c807161b669f7518a0abb2c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 10 Sep 2025 20:06:07 +0200 Subject: [PATCH 038/164] WIP refactoring to separate modules --- .vscode/metarocq.code-workspace | 3 + common/_RocqProject.in | 1 + common/theories/LoopChecking/Common.v | 192 ++ common/theories/LoopChecking/HornClauses.v | 279 ++- common/theories/LoopChecking/Interfaces.v | 130 ++ common/theories/LoopChecking/Model.v | 999 ++++++++++ .../LoopChecking/PartialLoopChecking.v | 1730 +---------------- 7 files changed, 1662 insertions(+), 1672 deletions(-) create mode 100644 common/theories/LoopChecking/Model.v diff --git a/.vscode/metarocq.code-workspace b/.vscode/metarocq.code-workspace index 4d1cba7ae..116df6b11 100644 --- a/.vscode/metarocq.code-workspace +++ b/.vscode/metarocq.code-workspace @@ -113,5 +113,8 @@ "coqtop.binPath": "_opam/bin", "coqtop.coqtopExe": "coqtop", "coqtop.coqidetopExe": "coqidetop", + "cSpell.enabledFileTypes": { + "coq": false + }, } } diff --git a/common/_RocqProject.in b/common/_RocqProject.in index 0ee9b0f3b..f93ce15db 100644 --- a/common/_RocqProject.in +++ b/common/_RocqProject.in @@ -18,4 +18,5 @@ theories/Transform.v theories/LoopChecking/Common.v theories/LoopChecking/Interfaces.v theories/LoopChecking/HornClauses.v +theories/LoopChecking/Model.v theories/LoopChecking/PartialLoopChecking.v \ No newline at end of file diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v index efbc2ea75..0ef9c129f 100644 --- a/common/theories/LoopChecking/Common.v +++ b/common/theories/LoopChecking/Common.v @@ -15,3 +15,195 @@ Ltac rw_in l H := rewrite_strat (topdown l) in H. (* TODO move *) Arguments exist {A P}. Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. + +Definition option_map2 {A} (f : A -> A -> A) (o o' : option A) : option A := + match o, o' with + | Some x, Some y => Some (f x y) + | None, Some _ + | Some _, None + | None, None => None + end. + +Derive Signature for InA. + +Lemma eqlistA_eq {A} (l l' : list A) : eqlistA Logic.eq l l' -> l = l'. +Proof. + induction 1. + - reflexivity. + - now f_equal. +Qed. + +#[export] Instance fold_left_ext {A B} : Proper (`=2` ==> eq ==> eq ==> eq) (@fold_left A B). +Proof. + intros f g hfg ? ? -> ? ? ->. + induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). +Qed. + +(* None is smaller than anything *) +Inductive opt_le {A} (le : relation A) : relation (option A) := +| opt_le_some x y : le x y -> opt_le le (Some x) (Some y) +| opt_le_none_some x : opt_le le None x. +Derive Signature for opt_le. + +Instance opt_le_refl {A} (le : relation A) : Reflexive le -> Reflexive (opt_le le). +Proof. + intros hre x; induction x; constructor; reflexivity. +Qed. + +Instance opt_le_trans {A} (le : relation A) : Transitive le -> Transitive (opt_le le). +Proof. + intros hre x; induction x; destruct y as [y|]; intros z H H'; depelim H; depelim H'; constructor. + now transitivity y. +Qed. + + +Class Commutative {A} (f : A -> A -> A) := comm : forall x y, f x y = f y x. +Instance option_map_2_comm {A} f : @Commutative A f -> @Commutative (option A) (option_map2 f). +Proof. + intros com [x|] [y|] => //=. now rewrite comm. +Qed. + +Instance Zmin_comm : Commutative Z.min := Z.min_comm. +Instance Zmax_comm : Commutative Z.max := Z.max_comm. + +Instance nat_min_comm : Commutative Nat.min := Nat.min_comm. +Instance nat_max_comm : Commutative Nat.max := Nat.max_comm. + +Class Associative {A} (f : A -> A -> A) := assoc : forall x y z, f x (f y z) = f (f x y) z. +Instance option_map_2_assoc {A} f : @Associative A f -> @Associative (option A) (option_map2 f). +Proof. + intros assoc [x|] [y|] [z|]; cbn => //. now rewrite assoc. +Qed. + +Instance nat_min_assoc : Associative Nat.min := Nat.min_assoc. +Instance nat_max_assoc : Associative Nat.max := Nat.max_assoc. + + +Instance Zmin_assoc : Associative Z.min := Z.min_assoc. +Instance Zmax_assoc : Associative Z.max := Z.max_assoc. + +Lemma fold_left_comm {A B} (f : B -> A -> B) (l : list A) (x : A) (acc : B) : + (forall x y z, f (f z x) y = f (f z y) x) -> + fold_left f l (f acc x) = f (fold_left f l acc) x. +Proof. + intros. + induction l in acc, x |- *; cbn. auto. + rewrite -IHl. f_equal. now rewrite H. +Qed. + +Lemma fold_left_min_opt_comm {A} (f : A -> A -> A) l x acc : + Associative f -> Commutative f -> + fold_left (option_map2 f) l (option_map2 f acc x) = option_map2 f (fold_left (option_map2 f) l acc) x. +Proof. + intros ass c. rewrite fold_left_comm => //. + intros. rewrite -(assoc (f := option_map2 f)). + rewrite -(assoc (f := option_map2 f) z y x0). + f_equal. apply comm. +Qed. + +Lemma fold_left_le {A B} {le} (f g : A -> B -> A) l : + (forall acc acc' x, In x l -> le acc acc' -> le (f acc x) (g acc' x)) -> + forall acc acc', le acc acc' -> + le (fold_left f l acc) (fold_left g l acc'). +Proof. + intros hfg. + induction l => //. cbn. intros. + apply IHl. intros. apply hfg => //. now right. apply hfg => //. now left. +Qed. + +Local Open Scope nat_scope. +Lemma fold_left_ne_lt {A} (f g : nat -> A -> nat) l acc : + (forall x y z, f (f z x) y = f (f z y) x) -> + (forall x y z, g (g z x) y = g (g z y) x) -> + l <> [] -> + (forall acc acc' x, In x l -> (acc <= acc') -> (f acc x <= g acc' x)) -> + (forall acc acc' x, In x l -> (acc < acc') -> (f acc x < g acc' x)) -> + (exists x, In x l /\ forall acc acc', (acc <= acc') -> (f acc x < g acc' x)) -> + fold_left f l acc < fold_left g l acc. +Proof. + intros hf hg. + generalize (Nat.le_refl acc). + generalize acc at 2 4. + induction l in acc |- * => //. + intros. + destruct l; cbn. + { destruct H3 as [x []]. cbn in H3. destruct H3; subst => //. + now eapply (H4 acc acc0). } + cbn in IHl. + rewrite hf hg. + rewrite fold_left_comm //. rewrite (fold_left_comm g) //. + destruct H3 as [min [hmin hfg]]. + destruct hmin as [<-|hel]. + - apply hfg. apply fold_left_le => //. intros; eapply H1 => //. now right; right. + apply H1 => //. now right; left. + - apply H2. now left. eapply IHl => //. + * intros acc1 acc' x hin. apply (H1 acc1 acc' x). now right. + * intros acc1 acc' x hin. apply (H2 acc1 acc' x). now right. + * exists min. split => //. +Qed. +Close Scope nat_scope. + +Notation min_opt := (option_map2 Z.min). + +Infix "≤" := (opt_le Z.le) (at level 50). + +Lemma opt_lt_le_trans x y z : + opt_le Z.lt x y -> + opt_le Z.le y z -> + opt_le Z.lt x z. +Proof. + intros [] H'; depelim H'; constructor. lia. +Qed. + +Lemma Zmin_opt_left x y : min_opt x y ≤ x. +Proof. + destruct x as [x|], y as [y|]; constructor. lia. +Qed. + +Lemma Zmin_opt_right x y : min_opt x y ≤ y. +Proof. + destruct x as [x|], y as [y|]; constructor. lia. +Qed. + +Lemma min_opt_spec x y z : min_opt x y = z -> (z = y \/ z = x). +Proof. + destruct x as [x|], y as [y|], z as [z|]; cbn; intuition auto. + - noconf H. pose proof (Zmin_irreducible x y). destruct H; intuition (f_equal; auto). + - noconf H. +Qed. + +Lemma fold_comm_assoc_nat x y z : option_map2 Nat.max x (option_map2 Nat.max y z) = + option_map2 Nat.max y (option_map2 Nat.max x z). +Proof. + now rewrite (assoc (f := option_map2 Nat.max)) (comm (f := option_map2 Nat.max) x y) -assoc. +Qed. + +Lemma fold_comm_assoc x y z : option_map2 Z.max x (option_map2 Z.max y z) = + option_map2 Z.max y (option_map2 Z.max x z). +Proof. + now rewrite (assoc (f := option_map2 Z.max)) (comm (f := option_map2 Z.max) x y) -assoc. +Qed. + +Notation max_opt := (option_map2 Z.max). + +Lemma max_opt_spec x y z : max_opt x y = Some z -> exists x' y', x = Some x' /\ y = Some y' /\ z = Z.max x' y'. +Proof. + destruct x as [x|], y as [y|]; cbn; intuition eauto; try noconf H. + exists x, y. auto. +Qed. + +#[export] Instance And3P_proper : Proper (iff ==> iff ==> iff ==> iff) ssrbool.and3. +Proof. + repeat intro. split; intros []; split; intuition auto. +Qed. + +#[export] Instance And4P_proper : Proper (iff ==> iff ==> iff ==> iff ==> iff) ssrbool.and4. +Proof. + repeat intro. split; intros []; split; intuition auto. +Qed. + +#[export] Instance And5P_proper : Proper (iff ==> iff ==> iff ==> iff ==> iff ==> iff) ssrbool.and5. +Proof. + repeat intro. split; intros []; split; intuition auto. +Qed. + diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 26897d8c9..f7c096b6e 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -15,8 +15,8 @@ Ltac rw_in l H := rewrite_strat (topdown l) in H. Module Clauses (LS : LevelSets). Module Export FLS := FromLevelSets LS. - Notation univ := nonEmptyLevelExprSet. - Definition clause : Type := univ × LevelExpr.t. + Notation premises := nonEmptyLevelExprSet. + Definition clause : Type := premises × LevelExpr.t. Module Clause. @@ -85,6 +85,7 @@ Module Clauses (LS : LevelSets). Module ClausesProp := WPropertiesOn Clause Clauses. Module ClausesDecide := WDecide (Clauses). Ltac clsets := ClausesDecide.fsetdec. + Infix "⊂_clset" := Clauses.Subset (at level 70). Definition clauses := Clauses.t. @@ -216,4 +217,278 @@ Module Clauses (LS : LevelSets). Qed. Definition clause_conclusion cl := level (concl cl). + Definition clauses_conclusions (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.add (level (concl cl)) acc) cls LevelSet.empty. + + #[export] Instance Clauses_For_All_proper : Proper (eq ==> Clauses.Equal ==> iff) Clauses.For_all. + Proof. + intros x y -> cl cl' eqcl. + unfold Clauses.For_all. now setoid_rewrite eqcl. + Qed. + + #[export] Instance Clauses_for_all_proper : Proper (eq ==> Clauses.Equal ==> eq) Clauses.for_all. + Proof. + intros x y -> cl cl' eqcl. + apply iff_is_true_eq_bool. + rewrite /is_true -!ClausesFact.for_all_iff. now rewrite eqcl. + Qed. + + Lemma clauses_conclusions_spec a cls : + LevelSet.In a (clauses_conclusions cls) <-> + exists cl, Clauses.In cl cls /\ level (concl cl) = a. + Proof. + unfold clauses_conclusions. + eapply ClausesProp.fold_rec; clear. + - move=> s' he /=. rewrite LevelSetFact.empty_iff. + firstorder auto. + - move=> cl ls cls' cls'' hin hnin hadd ih. + rewrite LevelSet.add_spec. firstorder eauto. + specialize (H0 x). cbn in H0. + apply hadd in H1. firstorder eauto. + subst. left. now destruct x. + Qed. + + Definition premise_restricted_to W cl := + LevelSet.subset (levels (premise cl)) W. + + Definition clause_restricted_to W cl := + LevelSet.subset (levels (premise cl)) W && + LevelSet.mem (level (concl cl)) W. + + Definition restrict_clauses (cls : clauses) (W : LevelSet.t) := + Clauses.filter (clause_restricted_to W) cls. + Infix "⇂" := restrict_clauses (at level 70). (* \downharpoonright *) + + Definition clauses_with_concl (cls : clauses) (concl : LevelSet.t) := + Clauses.filter (fun '(prem, concla) => LevelSet.mem (level concla) concl) cls. + Infix "↓" := clauses_with_concl (at level 70). (* \downarrow *) + + Notation cls_diff cls W := (Clauses.diff (cls ↓ W) (cls ⇂ W)) (only parsing). + + Lemma in_restrict_clauses (cls : clauses) (concls : LevelSet.t) cl : + Clauses.In cl (restrict_clauses cls concls) <-> + [/\ LevelSet.In (level (concl cl)) concls, + LevelSet.Subset (levels (premise cl)) concls & + Clauses.In cl cls]. + Proof. + unfold restrict_clauses. + rewrite Clauses.filter_spec. + destruct cl. cbn. + rewrite andb_true_iff LevelSet.subset_spec LevelSet.mem_spec. + firstorder auto. + Qed. + + Lemma restrict_clauses_subset (cls : clauses) (concls : LevelSet.t) : Clauses.Subset (restrict_clauses cls concls) cls. + Proof. + intros x; rewrite in_restrict_clauses; now intros []. + Qed. + + Lemma in_clauses_with_concl (cls : clauses) (concls : LevelSet.t) cl : + Clauses.In cl (clauses_with_concl cls concls) <-> + LevelSet.In (level (concl cl)) concls /\ Clauses.In cl cls. + Proof. + unfold clauses_with_concl. + rewrite Clauses.filter_spec. + destruct cl. rewrite LevelSet.mem_spec. cbn. firstorder eauto. + Qed. + + Lemma clauses_conclusions_clauses_with_concl cls concl : + LevelSet.Subset (clauses_conclusions (clauses_with_concl cls concl)) concl. + Proof. + intros x [cl []] % clauses_conclusions_spec. + eapply in_clauses_with_concl in H as []. + now rewrite H0 in H. + Qed. + + Lemma clauses_conclusions_restrict_clauses cls W : + LevelSet.Subset (clauses_conclusions (restrict_clauses cls W)) W. + Proof. + intros x [cl []] % clauses_conclusions_spec. + eapply in_restrict_clauses in H as []. + now rewrite H0 in H. + Qed. + + Definition in_clauses_conclusions (cls : clauses) (x : Level.t): Prop := + exists cl, Clauses.In cl cls /\ (level cl.2) = x. + + Definition premise_min (l : premises) : Z := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (B:=LevelExpr.t) (fun min atom => Z.min atom.2 min) tl (hd.2). + + Definition premise_max (l : premises) : Z := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (B:=LevelExpr.t) (fun min atom => Z.max atom.2 min) tl (hd.2). + + Definition max_clause_premise (cls : clauses) := + Clauses.fold (fun cl acc => Z.max (premise_max (premise cl)) acc) cls 0%Z. + + Definition gain (cl : clause) : Z := + (concl cl).2 - (premise_min (premise cl)). + + Definition max_gain (cls : clauses) := + Clauses.fold (fun cl acc => Nat.max (Z.to_nat (gain cl)) acc) cls 0%nat. + + + Lemma clauses_conclusions_diff cls s : + clauses_conclusions (Clauses.diff cls (clauses_with_concl cls s)) ⊂_lset + LevelSet.diff (clauses_conclusions cls) s. + Proof. + intros a. rewrite LevelSet.diff_spec !clauses_conclusions_spec. + firstorder eauto. + exists x; split => //. + now rewrite Clauses.diff_spec in H. + intros ha. + rewrite Clauses.diff_spec in H; destruct H as []. + apply H1. + rewrite in_clauses_with_concl. split => //. + now rewrite H0. + Qed. + + Lemma clauses_conclusions_diff_left cls W cls' : + clauses_conclusions (Clauses.diff (cls ↓ W) cls') ⊂_lset W. + Proof. + intros l. + rewrite clauses_conclusions_spec. + move=> [] cl. rewrite Clauses.diff_spec => [] [] []. + move/in_clauses_with_concl => [] hin ? ? eq. + now rewrite eq in hin. + Qed. + + Lemma clauses_conclusions_diff_restrict cls W cls' : + clauses_conclusions (Clauses.diff (cls ⇂ W) cls') ⊂_lset W. + Proof. + intros l. + rewrite clauses_conclusions_spec. + move=> [] cl. rewrite Clauses.diff_spec => [] [] []. + move/in_restrict_clauses => [] hin ? ? ? eq. + now rewrite eq in hin. + Qed. + + Lemma clauses_empty_eq {s} : Clauses.Empty s -> Clauses.Equal s Clauses.empty. + Proof. clsets. Qed. + + Lemma clauses_for_all_neg {p s}: + ~~ Clauses.for_all p s <-> ~ Clauses.For_all p s. + Proof. + intuition auto. + rewrite ClausesFact.for_all_iff in H0. red in H. now rewrite H0 in H. + revert H. apply contra_notN. + rewrite ClausesFact.for_all_iff //. + Qed. + + Lemma clauses_for_all_exists {p s}: + ~~ Clauses.for_all p s <-> Clauses.exists_ (fun x => ~~ p x) s. + Proof. + rewrite ClausesFact.for_all_b ClausesFact.exists_b. + induction (Clauses.elements s). + - cbn; auto. reflexivity. + - cbn. rewrite negb_and. intuition auto. + move/orP: H1 => [->|] //. move/H. intros ->. now rewrite orb_true_r. + move/orP: H1 => [->|] //. move/H0. intros ->. now rewrite orb_true_r. + Qed. + + Lemma max_gain_in cl cls : + Clauses.In cl cls -> + (Z.to_nat (gain cl) <= max_gain cls)%nat. + Proof. + intros hin. + unfold max_gain. revert cl hin. + eapply ClausesProp.fold_rec. + - intros s' ise hin. firstorder eauto. + - intros x a s' s'' xs nxs' hadd IH cl' hin'. + eapply hadd in hin' as []. + * subst x. lia. + * specialize (IH _ H). lia. + Qed. + + Definition max_gain_subset (cls cls' : Clauses.t) : + cls ⊂_clset cls' -> + (max_gain cls <= max_gain cls')%nat. + Proof. + unfold max_gain at 1. + revert cls'. + eapply ClausesProp.fold_rec. + - intros s' ise sub. lia. + - intros x a s' s'' xs nxs' hadd IH cls'' hs. + specialize (IH cls''). forward IH. transitivity s'' => //. + intros ??. now apply hadd. + assert (incls'' : Clauses.In x cls''). + { now apply hs, hadd. } + apply max_gain_in in incls''. lia. + Qed. + + Lemma max_clause_premise_spec cl cls : + Clauses.In cl cls -> + (premise_max (premise cl) <= max_clause_premise cls)%Z. + Proof. + intros hin. + unfold max_clause_premise. revert cl hin. + eapply ClausesProp.fold_rec. + - intros s' ise hin. firstorder eauto. + - intros x a s' s'' xs nxs' hadd IH cl' hin'. + eapply hadd in hin' as []. + * subst x. lia. + * specialize (IH _ H). lia. + Qed. + + Lemma non_W_atoms_ne W cl cls : + Clauses.In cl (cls_diff cls W) -> + LevelExprSet.is_empty (non_W_atoms W (premise cl)) = false. + Proof. + intros x. + apply Clauses.diff_spec in x as [clw clr]. + eapply in_clauses_with_concl in clw as [clw incls]. + apply/negbTE. + apply/(contra_notN _ clr). + intros he. rewrite in_restrict_clauses. split => //. + epose proof (@levels_exprs_non_W_atoms W (premise cl)). + eapply LevelExprSetFact.is_empty_2 in he. + intros x hin. eapply levelexprset_empty_levels in he. rewrite H in he. + specialize (he x). rewrite LevelSet.diff_spec in he. intuition auto. + rewrite -LevelSet.mem_spec in H1 |- *. destruct LevelSet.mem; intuition auto. + Qed. + + Lemma clauses_levels_restrict_clauses cls W : + clauses_levels (cls ⇂ W) ⊂_lset W. + Proof. + intros x [cl []] % clauses_levels_spec. + eapply in_restrict_clauses in H as [hconc hprem incl]. + eapply clause_levels_spec in H0 as []. apply hprem, H. now subst x. + Qed. + + Lemma clauses_conclusions_levels cls : + clauses_conclusions cls ⊂_lset clauses_levels cls. + Proof. + intros x. + rewrite clauses_conclusions_spec clauses_levels_spec. + setoid_rewrite clause_levels_spec. + firstorder auto. + Qed. + + #[export] Instance clauses_conclusions_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_conclusions. + Proof. + intros cls cls' eq x. + rewrite !clauses_conclusions_spec. now setoid_rewrite eq. + Qed. + + Lemma clauses_conclusions_add cl cls : + clauses_conclusions (Clauses.add cl cls) =_lset + (LevelSet.singleton (level (concl cl)) ∪ + clauses_conclusions cls). + Proof. + intros x. + rewrite LevelSet.union_spec !clauses_conclusions_spec. + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.singleton_spec. + firstorder eauto. subst. now left. + Qed. + + Lemma clauses_conclusions_subset {cls cls'} : + Clauses.Subset cls cls' -> + clauses_conclusions cls ⊂_lset clauses_conclusions cls'. + Proof. + intros hsub x. rewrite !clauses_conclusions_spec. + intuition eauto. destruct H as [cl []]; exists cl; split; try clsets; auto. + Qed. + + End Clauses. diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 25644ea8f..033a869a7 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -428,6 +428,136 @@ Module NonEmptySetFacts. End NonEmptySetFacts. Export NonEmptySetFacts. +Lemma diff_eq U V : LevelSet.diff V U =_lset V <-> LevelSet.inter V U =_lset LevelSet.empty. +Proof. split. lsets. lsets. Qed. +Lemma levelset_neq U V : LevelSet.equal U V = false -> ~ LevelSet.Equal U V. +Proof. intros eq heq % LevelSet.equal_spec. congruence. Qed. + +Lemma levelset_union_same U : LevelSet.union U U =_lset U. +Proof. lsets. Qed. + + +Lemma LevelSet_In_elements l s : + In l (LevelSet.elements s) <-> LevelSet.In l s. +Proof. + rewrite LevelSetFact.elements_iff. + now rewrite InA_In_eq. +Qed. + +Lemma In_elements {x} {s : LevelExprSet.t} : LevelExprSet.In x s <-> List.In x (LevelExprSet.elements s). +Proof. + split. now move/LevelExprSetFact.elements_1/InA_In_eq. + now move/InA_In_eq/LevelExprSetFact.elements_2. +Qed. + +Lemma not_mem l s : ~~ LevelSet.mem l s <-> ~ LevelSet.In l s. +Proof. + split. apply contraNnot. apply LevelSet.mem_spec. + eapply contra_notN; tea. now move/LevelSet.mem_spec. +Qed. + +Definition non_W_atoms W (l : LevelExprSet.t) := + LevelExprSet.filter (fun lk => ~~ LevelSet.mem lk.1 W) l. + +Lemma non_W_atoms_spec W l : forall x, LevelExprSet.In x (non_W_atoms W l) <-> LevelExprSet.In x l /\ ~ LevelSet.In x.1 W. +Proof. + intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec -not_mem. +Qed. + +Lemma non_W_atoms_subset W l : non_W_atoms W l ⊂_leset l. +Proof. intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec. Qed. + +Lemma levelexprset_levels_spec_aux l (e : LevelExprSet.t) acc : + LevelSet.In l (LevelExprSet.fold (fun le : LevelExprSet.elt => LevelSet.add (level le)) e acc) <-> + (exists k, LevelExprSet.In (l, k) e) \/ LevelSet.In l acc. +Proof. + eapply LevelExprSetProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k hin]. lesets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.add_spec. + split. + * intros [->|]. + left. exists x.2. red in H. subst. + apply hadd. cbn. left. now destruct x. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. apply hadd. now right. + * intros [[k ins'']|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. +Qed. + +Lemma levelexprset_levels_spec l (e : LevelExprSet.t) : + LevelSet.In l (levels e) <-> exists k, LevelExprSet.In (l, k) e. +Proof. + rewrite levelexprset_levels_spec_aux. intuition auto. lsets. +Qed. + +Lemma levels_exprs_non_W_atoms {W prem} : + LevelSet.Equal (levels (non_W_atoms W prem)) (LevelSet.diff (levels prem) W). +Proof. + intros e. unfold non_W_atoms. + rewrite levelexprset_levels_spec LevelSet.diff_spec levelexprset_levels_spec. + firstorder eauto. + rewrite LevelExprSet.filter_spec in H. now exists x. + rewrite LevelExprSet.filter_spec in H. destruct H. + rewrite LevelSetFact.not_mem_iff. + destruct LevelSet.mem => //. + exists x. + rewrite LevelExprSet.filter_spec. split => //. + rewrite LevelSetFact.not_mem_iff in H0. now rewrite H0. +Qed. + +Lemma levelexprset_empty_levels x : LevelExprSet.Empty x <-> LevelSet.Empty (levels x). +Proof. + split. + - intros he. + intros l hin. + eapply levelexprset_levels_spec in hin as [k hin]. lesets. + - intros emp l hin. eapply emp. eapply (levelexprset_levels_spec l.1). exists l.2. + now destruct l. +Qed. + +Lemma nEmpty_exists ls : ~ (LevelSet.Empty ls) -> exists l, LevelSet.In l ls. +Proof. + intros ne. + destruct (LevelSet.choose ls) eqn:isempty. exists e. + now apply LevelSet.choose_spec1 in isempty. + now apply LevelSet.choose_spec2 in isempty. +Qed. + +Lemma inLevelSet (ls : LevelSet.t) l : LevelSet.In l ls \/ ~ (LevelSet.In l ls). +Proof. + lsets. +Qed. + +Lemma premises_elim {P : nonEmptyLevelExprSet -> Prop} : + (forall le, P (singleton le)) -> + (forall le prems, P prems -> ~ LevelExprSet.In le prems -> P (add le prems)) -> + forall prems, P prems. +Proof. + intros hs ha. + intros []. + revert t_set0 t_ne0. + apply: LevelExprSetProp.set_induction; eauto. + - move=> s /LevelExprSetFact.is_empty_1 he ne; exfalso => //. congruence. + - intros s s' IH x nin hadd hne. + destruct (LevelExprSet.is_empty s) eqn:hem in |- . + eapply LevelExprSetFact.is_empty_2 in hem. + assert (singleton x = {| t_set := s'; t_ne := hne |}) as <- => //. + unfold singleton. apply eq_univ_equal. cbn. + intros a. specialize (hadd a). rewrite hadd. + rewrite LevelExprSet.singleton_spec. firstorder. subst. reflexivity. + specialize (IH hem). + specialize (ha x _ IH). + assert (LevelExprSet.Equal (add x {| t_set := s; t_ne := hem|}) {| t_set := s'; t_ne := hne |}). + 2:{ apply eq_univ_equal in H. now rewrite -H. } + intros x'. specialize (hadd x'). rewrite LevelExprSet.add_spec. + cbn. firstorder. subst x'. now left. +Qed. End FromLevelSets. \ No newline at end of file diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v new file mode 100644 index 000000000..502a1eaae --- /dev/null +++ b/common/theories/LoopChecking/Model.v @@ -0,0 +1,999 @@ +(* Distributed under the terms of the MIT license. *) +From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils. + +From MetaRocq.Common Require Universes. +From MetaRocq.Common Require Import Common Interfaces HornClauses. +From Equations Require Import Equations. +Set Equations Transparent. + +Module Model (LS : LevelSets). + Module Export Clauses := Clauses(LS). + + Definition model := LevelMap.t (option Z). + Definition equal_model (m m' : model) := LevelMap.Equal m m'. + + Local Open Scope Z_scope. + + Definition level_value (m : model) (level : Level.t) : option Z := + match LevelMap.find level m with + | Some v => v + | None => None + end. + + Lemma level_value_MapsTo {l k} {m : model} : + LevelMap.MapsTo l k m -> level_value m l = k. + Proof. + unfold level_value. + move=> mapto; rewrite (LevelMap.find_1 mapto) //. + Qed. + + Lemma level_value_MapsTo' {l k} {m : model} : + level_value m l = Some k -> LevelMap.MapsTo l (Some k) m. + Proof. + unfold level_value. destruct LevelMap.find eqn:hfind => //. + eapply LevelMap.find_2 in hfind. now intros [= ->]. + Qed. + + Definition levelexpr_value (m : model) (atom : LevelExpr.t) := + level_value m (level atom). + + Extraction Inline levelexpr_value. + + Definition min_atom_value (m : model) (atom : LevelExpr.t) : option Z := + let '(l, k) := atom in + match level_value m l with + | None => None + | Some val => Some (val - k)%Z + end. + + Definition min_premise (m : model) (l : premises) : option Z := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (fun min atom => option_map2 Z.min (min_atom_value m atom) min) tl (min_atom_value m hd). + + Definition satisfiable_atom (m : model) (atom : Level.t * Z) : bool := + let '(l, k) := atom in + match level_value m l with + | Some val => k <=? val + | None => false + end. + + Definition satisfiable_premise (m : model) (l : premises) := + LevelExprSet.for_all (satisfiable_atom m) l. + + (* Definition valid_clause (m : model) (cl : clause) := *) + (* implb (satisfiable_premise m (premise cl)) (satisfiable_atom m (concl cl)). *) + Definition level_value_above m l k := + match level_value m l with + | Some val => k <=? val + | None => false + end. + + Definition valid_clause (m : model) (cl : clause) := + let k0 := min_premise m (premise cl) in + match k0 with + | None => true + | Some k0 => + let (l, k) := concl cl in + level_value_above m l (k + k0) + end. + + Definition is_model (cls : clauses) (m : model) : bool := + Clauses.for_all (valid_clause m) cls. + + Inductive update_result := + | VacuouslyTrue + | Holds + | DoesntHold (wm : LevelSet.t × model). + + Definition update_model (m : model) l v : model := LevelMap.add l (Some v) m. + + Definition update_value (m : model) (cl : clause) : option model := + let k0 := min_premise m (premise cl) in + match k0 with + | None => None + | Some k0 => + let (l, k) := concl cl in + (* Does the conclusion also hold? + We optimize a bit here, rather than adding k0 in a second stage, + we do it already while checking the clause. In the paper, a second + pass computes this. + *) + if level_value_above m l (k + k0) then None + else Some (update_model m l (k + k0)) + end. + + Definition check_clause_model cl '(modified, m) := + match update_value m cl with + | None => (modified, m) + | Some m => (clause_conclusion cl :: modified, m) + end. + + Definition check_model_aux (cls : clauses) (wm : list Level.t × model) : list Level.t × model := + Clauses.fold check_clause_model cls wm. + + (* If check_model = None then we have a model of all clauses, + othewise, we return Some (W', m') where W ⊂ W' and the model has + been updated for at least one atom l ∈ W'. *) + Definition check_model (cls : clauses) (wm : LevelSet.t × model) : option (LevelSet.t × model) := + let '(modified, m) := check_model_aux cls ([], wm.2) in + match modified return option (LevelSet.t × model) with + | [] => None + | l => Some ((LevelSet.union (LevelSetProp.of_list l) wm.1), m) + end. + + Infix "=m" := LevelMap.Equal (at level 50). + + Definition strict_update m '(prems, (concl, k)) m' := + exists v, + [/\ min_premise m prems = Some v, ~~ level_value_above m concl (k + v) & + m' =m (LevelMap.add concl (Some (k + v)) m)]. + + Inductive strictly_updates cls : LevelSet.t -> model -> model -> Prop := + | update_one m cl m' : Clauses.In cl cls -> + strict_update m cl m' -> strictly_updates cls (LevelSet.singleton (clause_conclusion cl)) m m' + | update_trans {ls ls' m m' m''} : + strictly_updates cls ls m m' -> + strictly_updates cls ls' m' m'' -> + strictly_updates cls (LevelSet.union ls ls') m m''. + + Lemma strictly_updates_step cls w m m' m'' : + strictly_updates cls w m m' -> + forall cl, Clauses.In cl cls -> strict_update m' cl m'' -> + strictly_updates cls (LevelSet.add (clause_conclusion cl) w) m m''. + Proof. + induction 1. + - intros. + replace (LevelSet.add (clause_conclusion cl0) (LevelSet.singleton (clause_conclusion cl))) + with (LevelSet.union (LevelSet.singleton (clause_conclusion cl)) (LevelSet.singleton (clause_conclusion cl0))). + eapply update_trans; eapply update_one; tea. + eapply LevelSet.eq_leibniz. red. lsets. + - intros. + specialize (IHstrictly_updates2 _ H1 H2). + replace (LevelSet.add (clause_conclusion cl) (LevelSet.union ls ls')) + with (LevelSet.union ls (LevelSet.add (clause_conclusion cl) ls')). + eapply update_trans; tea. + eapply LevelSet.eq_leibniz. red. lsets. + Qed. + + Lemma strictly_updates_weaken cls w cls' : + Clauses.Subset cls cls' -> + forall m m', strictly_updates cls w m m' -> strictly_updates cls' w m m'. + Proof. + intros hcls m m'. + induction 1. constructor => //. now eapply hcls. + econstructor 2; tea. + Qed. + + Lemma strictly_updates_W_trans cls m w m' cl m'' : + strictly_updates cls w m m' -> + strict_update m' cl m'' -> + strictly_updates (Clauses.add cl cls) (LevelSet.add (clause_conclusion cl) w) m m''. + Proof. + intros updW su. + destruct cl as [prems [concl k]]. + eapply strictly_updates_step; tea. + - eapply strictly_updates_weaken; tea. clsets. + - rewrite Clauses.add_spec. left; reflexivity. + Qed. + + #[export] Instance is_model_proper : Proper (Clauses.Equal ==> eq ==> eq) is_model. + Proof. + intros cl cl' eqcl x y ->. unfold is_model. now rewrite eqcl. + Qed. + + #[export] Instance equal_model_equiv : Equivalence equal_model. + Proof. unfold equal_model. + split; try econstructor; eauto. + red. intros. now symmetry. + red; intros. now transitivity y. + Qed. + + #[export] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. + Proof. + intros x y eqm l ? <-. unfold level_value. + unfold equal_model in eqm. + destruct LevelMap.find eqn:hl. + - eapply LevelMap.find_2 in hl. + rewrite eqm in hl. + eapply LevelMap.find_1 in hl. now rewrite hl. + - eapply LevelMapFact.F.not_find_in_iff in hl. + rewrite eqm in hl. + eapply LevelMapFact.F.not_find_in_iff in hl. + now rewrite hl. + Qed. + + #[export] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. + Proof. + intros m m' eqm ? ? ->. unfold min_atom_value. + destruct y => //. + now rewrite eqm. + Qed. + + #[export] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. + Proof. + intros m m' eq ? ? ->. + unfold min_premise. + destruct to_nonempty_list. + now setoid_rewrite eq. + Qed. + + #[export] Instance update_model_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> LevelMap.Equal) update_model. + Proof. + intros m m' hm ? ? -> ? ? ->. + unfold update_model. + now rewrite hm. + Qed. + + #[export] Instance level_value_above_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> eq) level_value_above. + Proof. + intros m m' hm ? ? -> ? ? ->. + unfold level_value_above. + now rewrite hm. + Qed. + + Instance clauses_elements_proper : Proper (Clauses.Equal ==> eq) Clauses.elements. + Proof. + intros cl cl' eq. + have sl := Clauses.elements_spec2 cl. + (* have nl := Clauses.elements_spec2w cl. *) + have sl' := Clauses.elements_spec2 cl'. + (* have nl' := Clauses.elements_spec2w cl'. *) + have heq := @SortA_equivlistA_eqlistA _ Logic.eq _ Clause.lt_. + do 3 forward heq by tc. + specialize (heq _ _ sl sl'). + forward heq. + red. intros x. + rewrite -! ClausesProp.Dec.F.elements_iff. apply eq. + now apply eqlistA_eq. + Qed. + + #[export] Instance check_model_aux_proper : Proper (Clauses.Equal ==> eq ==> eq) check_model_aux. + Proof. + intros ? ? eq ? ? ->. + rewrite /check_model_aux. + rewrite !ClausesProp.fold_spec_right. + now rewrite eq. + Qed. + + #[export] Instance check_model_proper : Proper (Clauses.Equal ==> eq ==> eq) check_model. + Proof. + intros cls cls' eq. + intros wm wm' ->. + unfold check_model. + destruct (check_model_aux cls _) eqn:eqc. + destruct (check_model_aux cls' _) eqn:eqc' => //. + pose proof (check_model_aux_proper cls cls' eq ([], wm'.2) _ eq_refl). + rewrite eqc eqc' in H. noconf H. + destruct l => //. + Qed. + + Instance strictly_updates_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) strictly_updates. + Proof. + intros ? ? H ? ? H' ? ? H'' ? ? H'''. + eapply LevelSet.eq_leibniz in H'. subst y0. + split. + induction 1 in y, H, y1, H'', y2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. + now rewrite <- H. move: H1; unfold strict_update. destruct cl as [premse []]. + intros [v []]; exists v; split; + try setoid_rewrite <- H; + try setoid_rewrite <- H''; + try setoid_rewrite <- H'''; firstorder. + eapply IHstrictly_updates1; firstorder. firstorder. + induction 1 in x, H, x1, H'', x2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. + now rewrite H. move: H1; unfold strict_update. destruct cl as [premse []]. + intros [v []]; exists v; split; + try setoid_rewrite H; + try setoid_rewrite H''; + try setoid_rewrite H'''; firstorder. + eapply IHstrictly_updates1; firstorder. firstorder. + Qed. + + Lemma update_value_valid {m cl} : + match update_value m cl with + | None => valid_clause m cl + | Some _ => ~~ valid_clause m cl + end. + Proof. + unfold update_value, valid_clause. + destruct cl as [prem [l k]]; cbn. + destruct min_premise => //. + unfold level_value_above; + destruct level_value => //. + destruct Z.leb => //. + Qed. + + Lemma check_clause_model_spec {cl w m w' m'} : + check_clause_model cl (w, m) = (w', m') -> + (w = w' -> m = m' /\ valid_clause m cl) /\ + (w <> w' -> w' = clause_conclusion cl :: w /\ + strictly_updates (Clauses.singleton cl) (LevelSet.singleton (clause_conclusion cl)) m m'). + Proof. + unfold check_clause_model. + destruct update_value eqn:upd; revgoals. + * intros [= <- <-]. split => //. split => //. + move: (@update_value_valid m cl). now rewrite upd. + * intros [= <- <-]. split => //. + + intros. eapply (f_equal (@List.length _)) in H. cbn in H; lia. + + intros _. split => //. constructor. clsets. unfold strict_update. + move: upd. unfold update_value. + destruct cl as [prems [concl k]]. cbn. + destruct min_premise => //. + destruct level_value_above eqn:hl => //. + intros [= <-]. + exists z. split => //. rewrite hl. split => //. + Qed. + + Lemma check_model_aux_spec {cls w m w' m'} : + check_model_aux cls (w, m) = (w', m') -> + (w = w' -> m = m' /\ is_model cls m) /\ + (w <> w' -> exists pref, w' = pref ++ w /\ strictly_updates cls (LevelSetProp.of_list pref) m m'). + Proof. + rewrite /check_model_aux /is_model. + revert w' m'. + eapply ClausesProp.fold_rec. + - intros s' he w' m' [= <- <-]. split => //. split => //. + eapply Clauses.for_all_spec. tc. intros x hin. now apply he in hin. + - clear. intros x [w'' m''] s' s'' inx nins' hadd ih w' m' cl. + specialize (ih _ _ eq_refl) as[]. + split; intros; subst. + + eapply check_clause_model_spec in cl as []. + destruct (eqb_spec w' w''). + { subst w''. specialize (H eq_refl) as []. specialize (H1 eq_refl) as []. split => //. congruence. + eapply Clauses.for_all_spec in H3. eapply Clauses.for_all_spec. all:tc. + intros ? hin. eapply hadd in hin as []; subst; firstorder. } + forward H0 by auto. forward H2 by auto. + destruct H0 as [pref [-> su]]. + destruct pref; cbn in *; try congruence. + destruct H2. eapply (f_equal (@List.length _)) in H0; cbn in H0. rewrite length_app in H0. lia. + + eapply check_clause_model_spec in cl as []. + destruct (eqb_spec w w''). + { subst w''. specialize (H eq_refl) as []. subst m''. + destruct (eqb_spec w w'); subst; try congruence. + specialize (H3 H) as []. subst w'. exists [clause_conclusion x]. split => //. + replace (LevelSetProp.of_list [clause_conclusion x]) with (LevelSet.singleton (clause_conclusion x)). + eapply ClausesProp.Add_Equal in hadd. rewrite hadd. eapply strictly_updates_weaken; tea. clsets. + eapply LevelSet.eq_leibniz. red. intros ?. rewrite LevelSetProp.of_list_1. firstorder. constructor. + rewrite LevelSet.singleton_spec in H3. firstorder. depelim H3. subst. lsets. depelim H3. } + specialize (H0 H4). + destruct (eqb_spec w'' w'); subst. + { specialize (H2 eq_refl) as []; subst m''. + destruct H0 as [pref []]. subst w'. exists pref; split => //. + eapply strictly_updates_weaken; tea. intros ? ?. eapply hadd. clsets. } + forward H3 by auto. destruct H3 as [->]. + destruct H0 as [pref [-> su]]. eexists (clause_conclusion x :: pref); split => //. + replace (LevelSetProp.of_list (clause_conclusion x :: pref)) with (LevelSet.union (LevelSetProp.of_list pref) (LevelSet.singleton (clause_conclusion x))). + eapply (strictly_updates_weaken _ _ s'') in su; tea; try firstorder. + eapply (strictly_updates_weaken _ _ s'') in H3; tea; try firstorder. + 2:{ intros ?; rewrite Clauses.singleton_spec. intros ->. now apply hadd. } + exact: update_trans _ su H3. + apply LevelSet.eq_leibniz. intros ?. cbn. lsets. + Qed. + + Lemma check_model_spec {cls w m w' m'} : + check_model cls (w, m) = Some (w', m') -> + exists w'', strictly_updates cls w'' m m' /\ w' = LevelSet.union w w''. + Proof. + unfold check_model. + destruct check_model_aux eqn:cm. + apply check_model_aux_spec in cm as []. + destruct l => //. forward H0. auto with datatypes. + intros [= <- <-]. destruct H0 as [pref [heq su]]. + rewrite app_nil_r in heq. subst pref. + exists (LevelSetProp.of_list (t :: l)). split => //. + eapply LevelSet.eq_leibniz. intros ?. cbn. lsets. + Qed. + + + Lemma strict_update_invalid m cl m' : strict_update m cl m' -> ~~ valid_clause m cl. + Proof. + destruct cl as [prems [concl k]]. + cbn. + intros [v [him hna heq]]. + rewrite /valid_clause. rewrite him //=. + Qed. + + Lemma strictly_updates_invalid cls w m m' : strictly_updates cls w m m' -> ~~ is_model cls m. + Proof. + induction 1. + - eapply strict_update_invalid in H0. + apply/negbT. unfold is_model. + destruct Clauses.for_all eqn:fa => //. + eapply Clauses.for_all_spec in fa; tc. eapply fa in H. + now rewrite H in H0. + - auto. + Qed. + + Lemma check_model_None {cls acc} : + check_model cls acc = None <-> is_model cls acc.2. + Proof. + unfold check_model. + destruct check_model_aux eqn:cm. + apply check_model_aux_spec in cm as [ne ex]. + destruct l => //. split => // _. now specialize (ne eq_refl) as []. + split => //. forward ex by auto with datatypes. destruct ex as [pref [eq su]]. + rewrite app_nil_r in eq; subst pref. + intros ism. eapply strictly_updates_invalid in su. + now rewrite ism in su. + Qed. + + Lemma check_model_updates_spec {cls w init_model m w' m'} : + check_model cls (w, m) = Some (w', m') -> + forall cls', strictly_updates cls' w init_model m -> + strictly_updates (Clauses.union cls cls') w' init_model m' /\ w ⊂_lset w'. + Proof. + move/check_model_spec => [w'' [su ->]]. + intros cls' su'. split. + eapply update_trans; eapply strictly_updates_weaken; tea; clsets. lsets. + Qed. + + Lemma strictly_updates_non_empty {cls W m m'} : + strictly_updates cls W m m' -> ~ LevelSet.Empty W. + Proof. + induction 1. + - intros he. specialize (he (clause_conclusion cl)). lsets. + - intros he. apply IHstrictly_updates2. lsets. + Qed. + + Lemma strictly_updates_non_empty_map {cls W m m'} : + strictly_updates cls W m m' -> ~ LevelMap.Empty m'. + Proof. + induction 1. + - intros he. specialize (he (clause_conclusion cl)). + destruct cl as [prems [concl k]]. + destruct H0 as [? [? ? heq]]. + setoid_rewrite heq in he. eapply (he (Some (k + x))); cbn. + rewrite LevelMapFact.F.add_mapsto_iff. firstorder. + - intros he. now apply IHstrictly_updates2. + Qed. + + Lemma strictly_updates_incl {cls W m m'} : + strictly_updates cls W m m' -> W ⊂_lset clauses_conclusions cls. + Proof. + induction 1. + - intros x. rewrite clauses_conclusions_spec. firstorder. exists cl. + eapply LevelSet.singleton_spec in H1; red in H1; subst. split => //. + - lsets. + Qed. + + Lemma check_model_subset {cls v} : + forall w' v', check_model cls v = Some (w', v') -> ~ LevelSet.Empty w'. + Proof. + intros w' v'. + move/check_model_spec => [w'' [su ->]]. + eapply strictly_updates_non_empty in su. intros em. apply su. lsets. + Qed. + + Definition model_same_domain (m m' : model) := + forall l, LevelMap.In l m <-> LevelMap.In l m'. + + #[export] Instance model_same_domain_refl : Reflexive model_same_domain. + Proof. intros m l. reflexivity. Qed. + + #[export] Instance model_same_domain_trans : Transitive model_same_domain. + Proof. intros m m' m'' h h' l. rewrite (h l). apply h'. Qed. + + Definition model_map_outside V (m m' : model) := + forall l, ~ LevelSet.In l V -> + forall k, LevelMap.MapsTo l k m <-> LevelMap.MapsTo l k m'. + + #[export] Instance model_map_outside_refl V : Reflexive (model_map_outside V). + Proof. intros m l. reflexivity. Qed. + + #[export] Instance model_map_outside_trans V : Transitive (model_map_outside V). + Proof. + intros m m' m'' h h' l hnin k. + rewrite (h l hnin k). now apply h'. + Qed. + + Definition model_rel R (m m' : model) := + forall l k, LevelMap.MapsTo l k m -> exists k', LevelMap.MapsTo l k' m' /\ R k k'. + + Infix "⩽" := (model_rel (opt_le Z.le)) (at level 70). (* \leqslant *) + + #[export] Instance model_le_refl R (HR : Reflexive R) : Reflexive (model_rel R). + Proof. intros x l k map. exists k; split => //. Qed. + + #[export] Instance model_le_trans R (HR : Transitive R) : Transitive (model_rel R). + Proof. intros m m' m'' mm' m'm'' l k map. + apply mm' in map as [k' [map ?]]. + apply m'm'' in map as [k'' [map ?]]. exists k''. split => //. + now transitivity k'. + Qed. + + + Lemma valid_update_value {m cl} : + valid_clause m cl -> + match update_value m cl with + | None => true + | Some _ => false + end. + Proof. + unfold update_value, valid_clause. + destruct cl as [prem [l k]]; cbn. + destruct min_premise => //. + unfold level_value_above. + destruct level_value => //. + destruct Z.leb => //. + Qed. + + Lemma update_model_monotone m l k : level_value m l ≤ Some k -> + m ⩽ update_model m l k. + Proof. + intros hl. + intros l' k' maps. + unfold update_model. cbn. + destruct (eqb_spec l l'). + - subst l'. exists (Some k). move: hl. + unfold level_value. + rewrite (LevelMap.find_1 maps). + intros hle. + split => //. eapply LevelMap.add_1. eapply LevelMap.OT.eq_refl. + - exists k'. split => //. apply LevelMap.add_2 => //. reflexivity. + Qed. + + Lemma update_model_not_above m l k : level_value_above m l k = false -> + m ⩽ update_model m l k. + Proof. + unfold level_value_above. + intros hlev. + apply update_model_monotone. + destruct level_value as [v|] eqn:hv; constructor; lia. + Qed. + + + Lemma level_value_not_above_spec m l k : level_value_above m l k = false -> opt_le Z.lt (level_value m l) (Some k). + Proof. + unfold level_value_above; destruct level_value => // hlt; constructor. lia. + Qed. + + Lemma strict_update_ext m cl m' : strict_update m cl m' -> m ⩽ m'. + Proof. + destruct cl as [prems [concl k]]. + unfold strict_update. + intros [v [hm ha heq]]. + intros x k' hin. setoid_rewrite heq. + setoid_rewrite LevelMapFact.F.add_mapsto_iff. + destruct (Level.eq_dec concl x). subst. + move: ha; rewrite /level_value_above. + eapply level_value_MapsTo in hin. rewrite hin. + intros hlt'. + exists (Some (k + v)). + split. left. split; reflexivity. + move/negbTE: hlt'. + destruct k' => //. + elim: Z.leb_spec => //. intros; constructor; lia. constructor. + exists k'. split => //. right; eauto. reflexivity. + Qed. + + Lemma strictly_updates_ext cls w m m' : strictly_updates cls w m m' -> m ⩽ m'. + Proof. + induction 1. + now eapply strict_update_ext in H0. + now transitivity m'. + Qed. + + Lemma check_model_le {cls acc acc'} : + check_model cls acc = Some acc' -> acc.2 ⩽ acc'.2. + Proof. + destruct acc as [w m], acc' as [w' m']. + move/check_model_spec => [w'' [su ->]]. + cbn. now eapply strictly_updates_ext. + Qed. + + Lemma level_value_update_model m l k : + level_value (update_model m l k) l = Some k. + Proof. + unfold level_value, update_model. + cbn -[LevelMap.find LevelMap.add]. + rewrite LevelMapFact.F.add_o. + destruct LevelMap.OT.eq_dec => //. + exfalso. now apply n. + Qed. + + Lemma model_map_outside_weaken {W W'} {m m' : model} : + model_map_outside W m m' -> + W ⊂_lset W' -> + model_map_outside W' m m'. + Proof. + intros hm sub x hin k. + apply hm. intros hin'. apply sub in hin'. now apply hin. + Qed. + + Lemma is_model_union {cls cls' m} : + is_model cls m -> is_model cls' m -> is_model (Clauses.union cls cls') m. + Proof. + rewrite /is_model. rewrite /is_true -!ClausesFact.for_all_iff. + now move=> ism ism' x /Clauses.union_spec []. + Qed. + + Lemma model_le_values {m m' : model} x : m ⩽ m' -> level_value m x ≤ level_value m' x. + Proof. + intros lem. specialize (lem x). + unfold level_value. + destruct LevelMap.find eqn:hl => //. + - apply LevelMap.find_2 in hl. specialize (lem _ hl) as [k' [mapsto leq]]. + now rewrite (LevelMap.find_1 mapsto). + - constructor. + Qed. + + + Lemma min_premise_spec_aux (m : model) s k : + min_premise m s = k -> + (forall x, LevelExprSet.In x s -> (k ≤ min_atom_value m x)) /\ + (exists x, LevelExprSet.In x s /\ k = min_atom_value m x). + Proof. + unfold min_premise. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. reflexivity. + now exists p; split => //. + - destruct IHl as [ha hex]. + split. + * intros x hin. + eapply (in_elt_inv x a [p]) in hin as [<-|inih]. + { cbn. rewrite fold_left_comm. + { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } + apply Zmin_opt_left. } + specialize (ha _ inih). + cbn. rewrite fold_left_comm. + { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } + etransitivity; [apply Zmin_opt_right|assumption]. + * destruct hex as [minval [inmin ih]]. + cbn. rewrite fold_left_comm. + { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } + rewrite ih. + destruct (min_opt_spec (min_atom_value m a) (min_atom_value m minval) _ eq_refl). + { rewrite H. exists minval. cbn in inmin. split; [intuition|reflexivity]. } + { rewrite H. exists a. cbn in inmin. split; [intuition|reflexivity]. } + Qed. + + Lemma min_premise_spec (m : model) (s : premises) : + (forall x, LevelExprSet.In x s -> min_premise m s ≤ min_atom_value m x) /\ + (exists x, LevelExprSet.In x s /\ min_premise m s = min_atom_value m x). + Proof. + now apply min_premise_spec_aux. + Qed. + + Lemma min_premise_subset (m : model) (s s' : premises) : + LevelExprSet.Subset s s' -> + min_premise m s' ≤ min_premise m s. + Proof. + intros sub. + have [has [mins [ins eqs]]] := min_premise_spec m s. + have [has' [mins' [ins' eqs']]] := min_premise_spec m s'. + specialize (sub _ ins). specialize (has' _ sub). + now rewrite eqs. + Qed. + + Lemma premise_min_spec_aux s k : + premise_min s = k -> + (forall x, LevelExprSet.In x s -> (k <= x.2)%Z) /\ + (exists x, LevelExprSet.In x s /\ k = x.2). + Proof. + unfold premise_min. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. reflexivity. + now exists p; split => //. + - destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [p]) in H as [<-|inih]. + cbn. rewrite fold_left_comm. lia. lia. + specialize (ha _ inih). + cbn. rewrite fold_left_comm. lia. lia. + destruct hex as [minval [inmin ih]]. + cbn. rewrite fold_left_comm. lia. + destruct (Z.leb_spec a.2 minval.2). + exists a. split; [intuition|]. rewrite -ih in H. lia. + exists minval. + cbn in inmin; split; [intuition auto|]. lia. + Qed. + + Lemma premise_min_spec (s : premises) : + (forall x, LevelExprSet.In x s -> premise_min s <= x.2) /\ + (exists x, LevelExprSet.In x s /\ premise_min s = x.2). + Proof. + now apply premise_min_spec_aux. + Qed. + + Lemma premise_max_spec_aux s k : + premise_max s = k -> + (forall x, LevelExprSet.In x s -> x.2 <= k) /\ + (exists x, LevelExprSet.In x s /\ k = x.2). + Proof. + unfold premise_max. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + intros <-. + induction l. + - cbn. + split. intros x [->|] => //. reflexivity. + now exists p; split => //. + - destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [p]) in H as [<-|inih]. + cbn. rewrite fold_left_comm. lia. lia. + specialize (ha _ inih). + cbn. rewrite fold_left_comm. lia. lia. + destruct hex as [maxval [inmin ih]]. + cbn. rewrite fold_left_comm. lia. + destruct (Z.leb_spec a.2 maxval.2). + exists maxval. cbn in inmin; split; [intuition auto|]. + lia. + exists a. split; [intuition|]. rewrite -ih in H. cbn in inmin. + lia. + Qed. + + Lemma premise_max_spec (s : premises) : + (forall x, LevelExprSet.In x s -> x.2 <= premise_max s) /\ + (exists x, LevelExprSet.In x s /\ premise_max s = x.2). + Proof. + now apply premise_max_spec_aux. + Qed. + + Lemma premise_min_subset (s s' : premises) : + LevelExprSet.Subset s s' -> + (premise_min s' <= premise_min s). + Proof. + intros sub. + have [has [mins [ins eqs]]] := premise_min_spec s. + have [has' [mins' [ins' eqs']]] := premise_min_spec s'. + specialize (sub _ ins). specialize (has' _ sub). + lia. + Qed. + + Import LevelExprSet. + Import NonEmptySetFacts. + + Definition max_premise_value (m : model) (l : premises) : option Z := + let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + fold_left (fun min atom => option_map2 Z.max (levelexpr_value m atom) min) tl (levelexpr_value m hd). + + Lemma max_premise_value_spec_aux (m : model) s k : + max_premise_value m s = Some k -> + (forall x, LevelExprSet.In x s -> exists k', levelexpr_value m x = Some k' /\ Some k' ≤ Some k) /\ + (exists x, LevelExprSet.In x s /\ Some k = levelexpr_value m x). + Proof. + unfold max_premise_value. + move: (to_nonempty_list_spec s). + destruct (to_nonempty_list s). intros heq. + setoid_rewrite In_elements. rewrite -heq. clear s heq. + induction l in k |- *. + - cbn. + intros eq. + split. intros x [->|] => //. exists k. split => //. reflexivity. + now exists p; split => //. + - cbn. rewrite fold_left_comm. intros; apply fold_comm_assoc. + intros heq. apply max_opt_spec in heq as [y' [z' [eqa [eqf ->]]]]. + specialize (IHl _ eqf). destruct IHl as [ha hex]. + split; intros. + eapply (in_elt_inv x a [p]) in H as [<-|inih]. + { exists y'; intuition eauto. constructor; lia. } + { specialize (ha _ inih) as [k' []]. exists k'; intuition eauto. constructor. depelim H0; lia. } + destruct hex as [maxval [inmax ih]]. + cbn. + destruct (Z.leb_spec z' y'). + exists a. split; [intuition|]. rewrite eqa. f_equal. lia. + exists maxval. cbn in inmax; split; [intuition auto|]. rewrite -ih. f_equal; lia. + Qed. + + Lemma max_premise_value_spec (m : model) (s : premises) k : + max_premise_value m s = Some k -> + (forall x, LevelExprSet.In x s -> exists k', levelexpr_value m x = Some k' /\ Some k' ≤ Some k) /\ + (exists x, LevelExprSet.In x s /\ Some k = levelexpr_value m x). + Proof. + apply (max_premise_value_spec_aux m s). + Qed. + + Lemma min_premise_pos_spec {m prem k} : + min_premise m prem = Some k -> + forall x, LevelExprSet.In x prem -> Some (x.2 + k)%Z ≤ levelexpr_value m x. + Proof. + pose proof (min_premise_spec m prem) as [amin [exmin [inminpre eqminpre]]]. + intros hprem x hin. + specialize (amin _ hin). + unfold min_atom_value in amin. + destruct x as [l k']; cbn in *. unfold levelexpr_value; cbn. + destruct (level_value m l) eqn:he. + - depelim amin. + rewrite H0 in hprem. depelim hprem. constructor. lia. + constructor. + rewrite H in hprem; depelim hprem. + - depelim amin. rewrite H in hprem. depelim hprem. + Qed. + + Record model_extension W m m' := + { model_ext_le : m ⩽ m'; + model_ext_same_domain : model_same_domain m m'; + model_ext_same_outside : model_map_outside W m m' }. + + #[local] Instance model_ext_reflexive W : Reflexive (model_extension W). + Proof. + intros m; split; reflexivity. + Qed. + + #[local] Instance model_ext_transitive W : Transitive (model_extension W). + Proof. + intros m m' m'' h h'; split; (etransitivity; [apply h|apply h']). + Qed. + + Lemma model_extension_weaken W W' m m' : + W ⊂_lset W' -> + model_extension W m m' -> + model_extension W' m m'. + Proof. + intros leW []; split => //. + eapply model_map_outside_weaken; tea. + Qed. + + Lemma model_ext_trans_weaken W W' m m' m'' : + W ⊂_lset W' -> + model_extension W m m' -> + model_extension W' m' m'' -> + model_extension W' m m''. + Proof. + intros leW mext mext'. eapply model_extension_weaken in mext; tea. + now etransitivity; tea. + Qed. + + Definition model_of V (m : model) := + forall k, LevelSet.In k V -> LevelMap.In k m. + + Definition defined_model_of V (m : model) := + forall l, LevelSet.In l V -> exists k, LevelMap.MapsTo l (Some k) m. + + Definition only_model_of V (m : model) := + forall k, LevelSet.In k V <-> exists x, LevelMap.MapsTo k x m. + + Lemma only_model_of_model_of {V m} : only_model_of V m -> model_of V m. + Proof. + intros om l. move/om. intros [k hm]; now exists k. + Qed. + + Coercion only_model_of_model_of : only_model_of >-> model_of. + + Lemma level_value_above_MapsTo m l k : level_value_above m l k -> exists k', LevelMap.MapsTo l k' m /\ (Some k ≤ k'). + Proof. + unfold level_value_above. + destruct level_value eqn:hl => //. + move/Z.leb_le => hle; exists (Some z). + eapply level_value_MapsTo' in hl. split => //. now constructor. + Qed. + + Lemma level_value_above_MapsTo' m l k k' : LevelMap.MapsTo l k' m -> (Some k ≤ k') -> level_value_above m l k. + Proof. + unfold level_value_above. + intros H; apply LevelMap.find_1 in H. rewrite /level_value H. + destruct k'. intros h; depelim h. + now apply Z.leb_le. intros h; depelim h. + Qed. + + Lemma level_value_add m l k : level_value (LevelMap.add l (Some k) m) l = Some k. + Proof. + rewrite /level_value LevelMapFact.F.add_eq_o //. + Qed. + + Definition declared_model_level (m : model) l := LevelMap.In l m. + + Definition update_model_same_domain {m l k} : + declared_model_level m l -> + model_same_domain m (update_model m l k). + Proof. + unfold update_model, declared_model_level. + intros hin x. + rewrite LevelMapFact.F.add_in_iff. intuition auto. now subst. + Qed. + + Definition update_model_outside {m w l k} : + model_map_outside (LevelSet.add l w) m (update_model m l k). + Proof. + unfold update_model, model_map_outside. + intros l'. rewrite LevelSet.add_spec. + intros hin k'. + rewrite LevelMapFact.F.add_neq_mapsto_iff //. + intros heq. red in heq; subst l'. apply hin. now left. + Qed. + + Lemma min_atom_value_levelexpr_value m l a lv : min_atom_value m l = Some a -> levelexpr_value m l = Some lv -> + (a <= lv - l.2). + Proof. + destruct l as [l k]; cbn. unfold levelexpr_value. cbn. destruct level_value => //. + intros [= <-] [= <-]. lia. + Qed. + + Lemma model_of_update w m l k : model_of w m -> model_of (LevelSet.add l w) (update_model m l k). + Proof. + rewrite /model_of => hint l'. rewrite LevelSet.add_spec. + intros [->|hadd]. + - exists (Some k). now apply LevelMap.add_1. + - specialize (hint _ hadd). unfold update_model. + destruct hint as [x hx]. + destruct (eqb_spec l l'). subst. + now exists (Some k); apply LevelMap.add_1. + now exists x; eapply LevelMap.add_2. + Qed. + + #[export] Instance model_map_outside_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) model_map_outside. + Proof. + intros ? ? eqcl ? ? eqm ? ? eqs. + unfold model_map_outside. + setoid_rewrite eqcl. now setoid_rewrite eqm; setoid_rewrite eqs. + Qed. + + #[export] Instance proper_levelexprset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) + levels. + Proof. + intros s s' eq l. + rewrite !levelexprset_levels_spec. + firstorder eauto. + Qed. + + Lemma min_premise_spec' {m prems z} : min_premise m prems = Some z -> + (forall l k, LevelExprSet.In (l, k) prems -> + exists v, level_value m l = Some v /\ z <= (v - k))%Z. + Proof. + intros hmin. + have [hall hhmin'] := min_premise_spec m prems. + intros l k hin; specialize (hall _ hin). rewrite hmin in hall. + depelim hall. destruct level_value => //. noconf H0. exists z0. split => //. + Qed. + + Lemma min_premise_pres {m m'} prems : m ⩽ m' -> min_premise m prems ≤ min_premise m' prems. + Proof. + intros ext. + destruct (min_premise m prems) eqn:hmin. + have leq := min_premise_spec' hmin. 2:constructor. + have [leq' e'] := min_premise_spec m' prems. + destruct (min_premise_spec m prems) as [_ [minz [inminz eqminz]]]. + rewrite hmin in eqminz. + rewrite eqminz. destruct e' as [min' []]. rewrite H0. + transitivity (min_atom_value m min'). + 2:{ unfold min_atom_value. destruct min'. + unfold level_value. destruct (LevelMap.find t0 m) eqn:hfind. 2:constructor. + apply LevelMap.find_2 in hfind. apply ext in hfind as [k' [hfind hle]]. + apply LevelMap.find_1 in hfind. rewrite hfind. depelim hle; constructor. lia. + } + destruct min'. specialize (leq _ _ H) as [? []]. + unfold min_atom_value at 2. rewrite H1. rewrite -eqminz. constructor. lia. + Qed. + + Lemma level_value_above_mon m m' l k : m ⩽ m' -> level_value_above m l k -> level_value_above m' l k. + Proof. + intros ext; move/level_value_above_MapsTo => [v [hm hleq]]. + eapply ext in hm. destruct hm as [v' [hm' leq']]. + eapply level_value_above_MapsTo'; tea. transitivity v => //. + Qed. + + Lemma model_of_subset V V' m : + model_of V m -> V' ⊂_lset V -> model_of V' m. + Proof. + intros ih hv k. specialize (ih k). + now move/hv. + Qed. + + Instance only_model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) only_model_of. + Proof. + intros ? ? eq ? ? eq'. + rewrite /only_model_of. now setoid_rewrite eq; setoid_rewrite eq'. + Qed. + + Lemma only_model_of_eq V V' m : + only_model_of V m -> V' =_lset V -> only_model_of V' m. + Proof. + intros ih hv k. now rewrite hv. + Qed. + + +End Model. \ No newline at end of file diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index 35b3fc416..9ed58d34e 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -7,7 +7,7 @@ From MetaRocq.Utils Require Import utils. From MetaRocq.Common Require Universes. From Equations Require Import Equations. -From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses. +From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model. Set Equations Transparent. @@ -41,1007 +41,16 @@ Module Type LoopCheckingItf (LS : LevelSets). End LoopCheckingItf. Module LoopCheckingImpl (LS : LevelSets). - Module Import Clauses := Clauses(LS). + Module Import Model := Model(LS). Local Open Scope Z_scope. +Definition v_minus_w_bound (W : LevelSet.t) (m : model) := + LevelMap.fold (fun w v acc => Z.max (option_get 0 v) acc) + (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0%Z. -Definition model := LevelMap.t (option Z). - -Definition level_value (m : model) (level : Level.t) : option Z := - match LevelMap.find level m with - | Some v => v - | None => None - end. - -Definition levelexpr_value (m : model) (atom : LevelExpr.t) := - level_value m (level atom). - -Extraction Inline levelexpr_value. - -Definition min_atom_value (m : model) (atom : LevelExpr.t) : option Z := - let '(l, k) := atom in - match level_value m l with - | None => None - | Some val => Some (val - k)%Z - end. - -Definition option_map2 {A} (f : A -> A -> A) (o o' : option A) : option A := - match o, o' with - | Some x, Some y => Some (f x y) - | None, Some _ - | Some _, None - | None, None => None - end. - -Definition min_premise (m : model) (l : nonEmptyLevelExprSet) : option Z := - let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (fun min atom => option_map2 Z.min (min_atom_value m atom) min) tl (min_atom_value m hd). - -Definition satisfiable_atom (m : model) (atom : Level.t * Z) : bool := - let '(l, k) := atom in - match level_value m l with - | Some val => k <=? val - | None => false - end. - -Definition satisfiable_premise (m : model) (l : nonEmptyLevelExprSet) := - LevelExprSet.for_all (satisfiable_atom m) l. - -(* Definition valid_clause (m : model) (cl : clause) := *) - (* implb (satisfiable_premise m (premise cl)) (satisfiable_atom m (concl cl)). *) -Definition level_value_above m l k := - match level_value m l with - | Some val => k <=? val - | None => false - end. - -Definition valid_clause (m : model) (cl : clause) := - let k0 := min_premise m (premise cl) in - match k0 with - | None => true - | Some k0 => - let (l, k) := concl cl in - level_value_above m l (k + k0) - end. - -Definition is_model (cls : clauses) (m : model) : bool := - Clauses.for_all (valid_clause m) cls. - -Inductive update_result := - | VacuouslyTrue - | Holds - | DoesntHold (wm : LevelSet.t × model). - -Definition update_model (m : model) l v : model := LevelMap.add l (Some v) m. - -Definition update_value (m : model) (cl : clause) : option model := - let k0 := min_premise m (premise cl) in - match k0 with - | None => None - | Some k0 => - let (l, k) := concl cl in - (* Does the conclusion also hold? - We optimize a bit here, rather than adding k0 in a second stage, - we do it already while checking the clause. In the paper, a second - pass computes this. - *) - if level_value_above m l (k + k0) then None - else Some (update_model m l (k + k0)) - end. - -Definition check_clause_model cl '(modified, m) := - match update_value m cl with - | None => (modified, m) - | Some m => (clause_conclusion cl :: modified, m) - end. - -Definition check_model_aux (cls : clauses) (wm : list Level.t × model) : list Level.t × model := - Clauses.fold check_clause_model cls wm. - -(* If check_model = None then we have a model of all clauses, - othewise, we return Some (W', m') where W ⊂ W' and the model has - been updated for at least one atom l ∈ W'. *) -Definition check_model (cls : clauses) (wm : LevelSet.t × model) : option (LevelSet.t × model) := - let '(modified, m) := check_model_aux cls ([], wm.2) in - match modified return option (LevelSet.t × model) with - | [] => None - | l => Some ((LevelSet.union (LevelSetProp.of_list l) wm.1), m) - end. - -Infix "=m" := LevelMap.Equal (at level 50). - -Definition strict_update m '(prems, (concl, k)) m' := - exists v, - [/\ min_premise m prems = Some v, ~~ level_value_above m concl (k + v) & - m' =m (LevelMap.add concl (Some (k + v)) m)]. - -Inductive strictly_updates cls : LevelSet.t -> model -> model -> Prop := -| update_one m cl m' : Clauses.In cl cls -> - strict_update m cl m' -> strictly_updates cls (LevelSet.singleton (clause_conclusion cl)) m m' -| update_trans {ls ls' m m' m''} : - strictly_updates cls ls m m' -> - strictly_updates cls ls' m' m'' -> - strictly_updates cls (LevelSet.union ls ls') m m''. - -Lemma strictly_updates_step cls w m m' m'' : - strictly_updates cls w m m' -> - forall cl, Clauses.In cl cls -> strict_update m' cl m'' -> - strictly_updates cls (LevelSet.add (clause_conclusion cl) w) m m''. -Proof. - induction 1. - - intros. - replace (LevelSet.add (clause_conclusion cl0) (LevelSet.singleton (clause_conclusion cl))) - with (LevelSet.union (LevelSet.singleton (clause_conclusion cl)) (LevelSet.singleton (clause_conclusion cl0))). - eapply update_trans; eapply update_one; tea. - eapply LevelSet.eq_leibniz. red. lsets. - - intros. - specialize (IHstrictly_updates2 _ H1 H2). - replace (LevelSet.add (clause_conclusion cl) (LevelSet.union ls ls')) - with (LevelSet.union ls (LevelSet.add (clause_conclusion cl) ls')). - eapply update_trans; tea. - eapply LevelSet.eq_leibniz. red. lsets. -Qed. - -Lemma strictly_updates_weaken cls w cls' : - Clauses.Subset cls cls' -> - forall m m', strictly_updates cls w m m' -> strictly_updates cls' w m m'. -Proof. - intros hcls m m'. - induction 1. constructor => //. now eapply hcls. - econstructor 2; tea. -Qed. - -Lemma strictly_updates_W_trans cls m w m' cl m'' : - strictly_updates cls w m m' -> - strict_update m' cl m'' -> - strictly_updates (Clauses.add cl cls) (LevelSet.add (clause_conclusion cl) w) m m''. -Proof. - intros updW su. - destruct cl as [prems [concl k]]. - eapply strictly_updates_step; tea. - - eapply strictly_updates_weaken; tea. clsets. - - rewrite Clauses.add_spec. left; reflexivity. -Qed. - -#[local] Instance Clauses_For_All_proper : Proper (eq ==> Clauses.Equal ==> iff) Clauses.For_all. -Proof. - intros x y -> cl cl' eqcl. - unfold Clauses.For_all. now setoid_rewrite eqcl. -Qed. - -#[local] Instance Clauses_for_all_proper : Proper (eq ==> Clauses.Equal ==> eq) Clauses.for_all. -Proof. - intros x y -> cl cl' eqcl. - apply iff_is_true_eq_bool. - rewrite /is_true -!ClausesFact.for_all_iff. now rewrite eqcl. -Qed. - -#[local] Instance is_model_proper : Proper (Clauses.Equal ==> eq ==> eq) is_model. -Proof. - intros cl cl' eqcl x y ->. unfold is_model. now rewrite eqcl. -Qed. - - -Definition equal_model (m m' : model) := LevelMap.Equal m m'. - -#[local] Instance equal_model_equiv : Equivalence equal_model. -Proof. unfold equal_model. - split; try econstructor; eauto. - red. intros. now symmetry. - red; intros. now transitivity y. -Qed. - - -#[local] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. -Proof. - intros x y eqm l ? <-. unfold level_value. - unfold equal_model in eqm. - destruct LevelMap.find eqn:hl. - - eapply LevelMap.find_2 in hl. - rewrite eqm in hl. - eapply LevelMap.find_1 in hl. now rewrite hl. - - eapply LevelMapFact.F.not_find_in_iff in hl. - rewrite eqm in hl. - eapply LevelMapFact.F.not_find_in_iff in hl. - now rewrite hl. -Qed. - -#[local] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. -Proof. - intros m m' eqm ? ? ->. unfold min_atom_value. - destruct y => //. - now rewrite eqm. -Qed. - -#[local] Instance fold_left_ext {A B} : Proper (`=2` ==> eq ==> eq ==> eq) (@fold_left A B). -Proof. - intros f g hfg ? ? -> ? ? ->. - induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). -Qed. - -#[local] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. -Proof. - intros m m' eq ? ? ->. - unfold min_premise. - destruct to_nonempty_list. - now setoid_rewrite eq. -Qed. - -#[local] Instance update_model_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> LevelMap.Equal) update_model. -Proof. - intros m m' hm ? ? -> ? ? ->. - unfold update_model. - now rewrite hm. -Qed. - -#[local] Instance level_value_above_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> eq) level_value_above. -Proof. - intros m m' hm ? ? -> ? ? ->. - unfold level_value_above. - now rewrite hm. -Qed. - -Lemma eqlistA_eq {A} (l l' : list A) : eqlistA Logic.eq l l' -> l = l'. -Proof. - induction 1. - - reflexivity. - - now f_equal. -Qed. - -Instance clauses_elements_proper : Proper (Clauses.Equal ==> eq) Clauses.elements. -Proof. - intros cl cl' eq. - have sl := Clauses.elements_spec2 cl. - (* have nl := Clauses.elements_spec2w cl. *) - have sl' := Clauses.elements_spec2 cl'. - (* have nl' := Clauses.elements_spec2w cl'. *) - have heq := @SortA_equivlistA_eqlistA _ Logic.eq _ Clause.lt_. - do 3 forward heq by tc. - specialize (heq _ _ sl sl'). - forward heq. - red. intros x. - rewrite -! ClausesProp.Dec.F.elements_iff. apply eq. - now apply eqlistA_eq. -Qed. - -#[local] Instance check_model_aux_proper : Proper (Clauses.Equal ==> eq ==> eq) check_model_aux. -Proof. - intros ? ? eq ? ? ->. - rewrite /check_model_aux. - rewrite !ClausesProp.fold_spec_right. - now rewrite eq. -Qed. - -#[local] Instance check_model_proper : Proper (Clauses.Equal ==> eq ==> eq) check_model. -Proof. - intros cls cls' eq. - intros wm wm' ->. - unfold check_model. - destruct (check_model_aux cls _) eqn:eqc. - destruct (check_model_aux cls' _) eqn:eqc' => //. - pose proof (check_model_aux_proper cls cls' eq ([], wm'.2) _ eq_refl). - rewrite eqc eqc' in H. noconf H. - destruct l => //. -Qed. - -Instance strictly_updates_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) strictly_updates. -Proof. - intros ? ? H ? ? H' ? ? H'' ? ? H'''. - eapply LevelSet.eq_leibniz in H'. subst y0. - split. - induction 1 in y, H, y1, H'', y2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. - now rewrite <- H. move: H1; unfold strict_update. destruct cl as [premse []]. - intros [v []]; exists v; split; - try setoid_rewrite <- H; - try setoid_rewrite <- H''; - try setoid_rewrite <- H'''; firstorder. - eapply IHstrictly_updates1; firstorder. firstorder. - induction 1 in x, H, x1, H'', x2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. - now rewrite H. move: H1; unfold strict_update. destruct cl as [premse []]. - intros [v []]; exists v; split; - try setoid_rewrite H; - try setoid_rewrite H''; - try setoid_rewrite H'''; firstorder. - eapply IHstrictly_updates1; firstorder. firstorder. -Qed. - -Lemma update_value_valid {m cl} : - match update_value m cl with - | None => valid_clause m cl - | Some _ => ~~ valid_clause m cl - end. -Proof. - unfold update_value, valid_clause. - destruct cl as [prem [l k]]; cbn. - destruct min_premise => //. - unfold level_value_above; - destruct level_value => //. - destruct Z.leb => //. -Qed. - -Lemma check_clause_model_spec {cl w m w' m'} : - check_clause_model cl (w, m) = (w', m') -> - (w = w' -> m = m' /\ valid_clause m cl) /\ - (w <> w' -> w' = clause_conclusion cl :: w /\ - strictly_updates (Clauses.singleton cl) (LevelSet.singleton (clause_conclusion cl)) m m'). -Proof. - unfold check_clause_model. - destruct update_value eqn:upd; revgoals. - * intros [= <- <-]. split => //. split => //. - move: (@update_value_valid m cl). now rewrite upd. - * intros [= <- <-]. split => //. - + intros. eapply (f_equal (@List.length _)) in H. cbn in H; lia. - + intros _. split => //. constructor. clsets. unfold strict_update. - move: upd. unfold update_value. - destruct cl as [prems [concl k]]. cbn. - destruct min_premise => //. - destruct level_value_above eqn:hl => //. - intros [= <-]. - exists z. split => //. rewrite hl. split => //. -Qed. - -Derive Signature for InA. - -Lemma check_model_aux_spec {cls w m w' m'} : - check_model_aux cls (w, m) = (w', m') -> - (w = w' -> m = m' /\ is_model cls m) /\ - (w <> w' -> exists pref, w' = pref ++ w /\ strictly_updates cls (LevelSetProp.of_list pref) m m'). -Proof. - rewrite /check_model_aux /is_model. - revert w' m'. - eapply ClausesProp.fold_rec. - - intros s' he w' m' [= <- <-]. split => //. split => //. - eapply Clauses.for_all_spec. tc. intros x hin. now apply he in hin. - - clear. intros x [w'' m''] s' s'' inx nins' hadd ih w' m' cl. - specialize (ih _ _ eq_refl) as[]. - split; intros; subst. - + eapply check_clause_model_spec in cl as []. - destruct (eqb_spec w' w''). - { subst w''. specialize (H eq_refl) as []. specialize (H1 eq_refl) as []. split => //. congruence. - eapply Clauses.for_all_spec in H3. eapply Clauses.for_all_spec. all:tc. - intros ? hin. eapply hadd in hin as []; subst; firstorder. } - forward H0 by auto. forward H2 by auto. - destruct H0 as [pref [-> su]]. - destruct pref; cbn in *; try congruence. - destruct H2. eapply (f_equal (@List.length _)) in H0; cbn in H0. rewrite length_app in H0. lia. - + eapply check_clause_model_spec in cl as []. - destruct (eqb_spec w w''). - { subst w''. specialize (H eq_refl) as []. subst m''. - destruct (eqb_spec w w'); subst; try congruence. - specialize (H3 H) as []. subst w'. exists [clause_conclusion x]. split => //. - replace (LevelSetProp.of_list [clause_conclusion x]) with (LevelSet.singleton (clause_conclusion x)). - eapply ClausesProp.Add_Equal in hadd. rewrite hadd. eapply strictly_updates_weaken; tea. clsets. - eapply LevelSet.eq_leibniz. red. intros ?. rewrite LevelSetProp.of_list_1. firstorder. constructor. - rewrite LevelSet.singleton_spec in H3. firstorder. depelim H3. subst. lsets. depelim H3. } - specialize (H0 H4). - destruct (eqb_spec w'' w'); subst. - { specialize (H2 eq_refl) as []; subst m''. - destruct H0 as [pref []]. subst w'. exists pref; split => //. - eapply strictly_updates_weaken; tea. intros ? ?. eapply hadd. clsets. } - forward H3 by auto. destruct H3 as [->]. - destruct H0 as [pref [-> su]]. eexists (clause_conclusion x :: pref); split => //. - replace (LevelSetProp.of_list (clause_conclusion x :: pref)) with (LevelSet.union (LevelSetProp.of_list pref) (LevelSet.singleton (clause_conclusion x))). - eapply (strictly_updates_weaken _ _ s'') in su; tea; try firstorder. - eapply (strictly_updates_weaken _ _ s'') in H3; tea; try firstorder. - 2:{ intros ?; rewrite Clauses.singleton_spec. intros ->. now apply hadd. } - exact: update_trans _ su H3. - apply LevelSet.eq_leibniz. intros ?. cbn. lsets. -Qed. - -Lemma check_model_spec {cls w m w' m'} : - check_model cls (w, m) = Some (w', m') -> - exists w'', strictly_updates cls w'' m m' /\ w' = LevelSet.union w w''. -Proof. - unfold check_model. - destruct check_model_aux eqn:cm. - apply check_model_aux_spec in cm as []. - destruct l => //. forward H0. auto with datatypes. - intros [= <- <-]. destruct H0 as [pref [heq su]]. - rewrite app_nil_r in heq. subst pref. - exists (LevelSetProp.of_list (t :: l)). split => //. - eapply LevelSet.eq_leibniz. intros ?. cbn. lsets. -Qed. - - -Lemma strict_update_invalid m cl m' : strict_update m cl m' -> ~~ valid_clause m cl. -Proof. - destruct cl as [prems [concl k]]. - cbn. - intros [v [him hna heq]]. - rewrite /valid_clause. rewrite him //=. -Qed. - -Lemma strictly_updates_invalid cls w m m' : strictly_updates cls w m m' -> ~~ is_model cls m. -Proof. - induction 1. - - eapply strict_update_invalid in H0. - apply/negbT. unfold is_model. - destruct Clauses.for_all eqn:fa => //. - eapply Clauses.for_all_spec in fa; tc. eapply fa in H. - now rewrite H in H0. - - auto. -Qed. - -Lemma check_model_None {cls acc} : - check_model cls acc = None <-> is_model cls acc.2. -Proof. - unfold check_model. - destruct check_model_aux eqn:cm. - apply check_model_aux_spec in cm as [ne ex]. - destruct l => //. split => // _. now specialize (ne eq_refl) as []. - split => //. forward ex by auto with datatypes. destruct ex as [pref [eq su]]. - rewrite app_nil_r in eq; subst pref. - intros ism. eapply strictly_updates_invalid in su. - now rewrite ism in su. -Qed. - -Lemma check_model_updates_spec {cls w init_model m w' m'} : - check_model cls (w, m) = Some (w', m') -> - forall cls', strictly_updates cls' w init_model m -> - strictly_updates (Clauses.union cls cls') w' init_model m' /\ w ⊂_lset w'. -Proof. - move/check_model_spec => [w'' [su ->]]. - intros cls' su'. split. - eapply update_trans; eapply strictly_updates_weaken; tea; clsets. lsets. -Qed. - -Lemma strictly_updates_non_empty {cls W m m'} : - strictly_updates cls W m m' -> ~ LevelSet.Empty W. -Proof. - induction 1. - - intros he. specialize (he (clause_conclusion cl)). lsets. - - intros he. apply IHstrictly_updates2. lsets. -Qed. - -Lemma strictly_updates_non_empty_map {cls W m m'} : - strictly_updates cls W m m' -> ~ LevelMap.Empty m'. -Proof. - induction 1. - - intros he. specialize (he (clause_conclusion cl)). - destruct cl as [prems [concl k]]. - destruct H0 as [? [? ? heq]]. - setoid_rewrite heq in he. eapply (he (Some (k + x))); cbn. - rewrite LevelMapFact.F.add_mapsto_iff. firstorder. - - intros he. now apply IHstrictly_updates2. -Qed. - -Definition clauses_conclusions (cls : clauses) : LevelSet.t := - Clauses.fold (fun cl acc => LevelSet.add (level (concl cl)) acc) cls LevelSet.empty. - -Lemma clauses_conclusions_spec a cls : - LevelSet.In a (clauses_conclusions cls) <-> - exists cl, Clauses.In cl cls /\ level (concl cl) = a. -Proof. - unfold clauses_conclusions. - eapply ClausesProp.fold_rec; clear. - - move=> s' he /=. rewrite LevelSetFact.empty_iff. - firstorder auto. - - move=> cl ls cls' cls'' hin hnin hadd ih. - rewrite LevelSet.add_spec. firstorder eauto. - specialize (H0 x). cbn in H0. - apply hadd in H1. firstorder eauto. - subst. left. now destruct x. -Qed. - -Lemma strictly_updates_incl {cls W m m'} : - strictly_updates cls W m m' -> W ⊂_lset clauses_conclusions cls. -Proof. - induction 1. - - intros x. rewrite clauses_conclusions_spec. firstorder. exists cl. - eapply LevelSet.singleton_spec in H1; red in H1; subst. split => //. - - lsets. -Qed. - -Lemma check_model_subset {cls v} : - forall w' v', check_model cls v = Some (w', v') -> ~ LevelSet.Empty w'. -Proof. - intros w' v'. - move/check_model_spec => [w'' [su ->]]. - eapply strictly_updates_non_empty in su. intros em. apply su. lsets. -Qed. - -Definition premise_restricted_to W cl := - LevelSet.subset (levels (premise cl)) W. - -Definition clause_restricted_to W cl := - LevelSet.subset (levels (premise cl)) W && - LevelSet.mem (level (concl cl)) W. - -Definition restrict_clauses (cls : clauses) (W : LevelSet.t) := - Clauses.filter (clause_restricted_to W) cls. - -Lemma in_restrict_clauses (cls : clauses) (concls : LevelSet.t) cl : - Clauses.In cl (restrict_clauses cls concls) <-> - [/\ LevelSet.In (level (concl cl)) concls, - LevelSet.Subset (levels (premise cl)) concls & - Clauses.In cl cls]. -Proof. - unfold restrict_clauses. - rewrite Clauses.filter_spec. - destruct cl. cbn. - rewrite andb_true_iff LevelSet.subset_spec LevelSet.mem_spec. - firstorder auto. -Qed. - -Lemma restrict_clauses_subset (cls : clauses) (concls : LevelSet.t) : Clauses.Subset (restrict_clauses cls concls) cls. -Proof. - intros x; rewrite in_restrict_clauses; now intros []. -Qed. - -Definition clauses_with_concl (cls : clauses) (concl : LevelSet.t) := - Clauses.filter (fun '(prem, concla) => LevelSet.mem (level concla) concl) cls. - -Lemma in_clauses_with_concl (cls : clauses) (concls : LevelSet.t) cl : - Clauses.In cl (clauses_with_concl cls concls) <-> - LevelSet.In (level (concl cl)) concls /\ Clauses.In cl cls. -Proof. - unfold clauses_with_concl. - rewrite Clauses.filter_spec. - destruct cl. rewrite LevelSet.mem_spec. cbn. firstorder eauto. -Qed. - -Lemma clauses_conclusions_clauses_with_concl cls concl : - LevelSet.Subset (clauses_conclusions (clauses_with_concl cls concl)) concl. -Proof. - intros x [cl []] % clauses_conclusions_spec. - eapply in_clauses_with_concl in H as []. - now rewrite H0 in H. -Qed. - -Lemma clauses_conclusions_restrict_clauses cls W : - LevelSet.Subset (clauses_conclusions (restrict_clauses cls W)) W. -Proof. - intros x [cl []] % clauses_conclusions_spec. - eapply in_restrict_clauses in H as []. - now rewrite H0 in H. -Qed. - -Definition in_clauses_conclusions (cls : clauses) (x : Level.t): Prop := - exists cl, Clauses.In cl cls /\ (level cl.2) = x. - -Definition v_minus_w_bound (W : LevelSet.t) (m : model) := - LevelMap.fold (fun w v acc => Z.max (option_get 0 v) acc) - (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0%Z. - -Definition premise_min (l : nonEmptyLevelExprSet) : Z := - let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (B:=LevelExpr.t) (fun min atom => Z.min atom.2 min) tl (hd.2). - -Definition premise_max (l : nonEmptyLevelExprSet) : Z := - let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (B:=LevelExpr.t) (fun min atom => Z.max atom.2 min) tl (hd.2). - -Definition gain (cl : clause) : Z := - (concl cl).2 - (premise_min (premise cl)). - -Definition max_gain (cls : clauses) := - Clauses.fold (fun cl acc => Nat.max (Z.to_nat (gain cl)) acc) cls 0%nat. - -Definition max_clause_premise (cls : clauses) := - Clauses.fold (fun cl acc => Z.max (premise_max (premise cl)) acc) cls 0%Z. - -Definition model_same_domain (m m' : model) := - forall l, LevelMap.In l m <-> LevelMap.In l m'. - -#[local] Instance model_same_domain_refl : Reflexive model_same_domain. -Proof. intros m l. reflexivity. Qed. - -#[local] Instance model_same_domain_trans : Transitive model_same_domain. -Proof. intros m m' m'' h h' l. rewrite (h l). apply h'. Qed. - - -Inductive opt_le {A} (le : relation A) : relation (option A) := -| opt_le_some x y : le x y -> opt_le le (Some x) (Some y) -| opt_le_none_some x : opt_le le None x. -Derive Signature for opt_le. - -Instance opt_le_refl {A} (le : relation A) : Reflexive le -> Reflexive (opt_le le). -Proof. - intros hre x; induction x; constructor; reflexivity. -Qed. - -Instance opt_le_trans {A} (le : relation A) : Transitive le -> Transitive (opt_le le). -Proof. - intros hre x; induction x; destruct y as [y|]; intros z H H'; depelim H; depelim H'; constructor. - now transitivity y. -Qed. - -Infix "≤" := (opt_le Z.le) (at level 50). - -Infix "≤Z" := (opt_le Z.le) (at level 50). - -Definition model_rel R (m m' : model) := - forall l k, LevelMap.MapsTo l k m -> exists k', LevelMap.MapsTo l k' m' /\ R k k'. - -Infix "⩽" := (model_rel (opt_le Z.le)) (at level 70). (* \leqslant *) - -Definition model_map_outside V (m m' : model) := - forall l, ~ LevelSet.In l V -> - forall k, LevelMap.MapsTo l k m <-> LevelMap.MapsTo l k m'. - -#[local] Instance model_map_outside_refl V : Reflexive (model_map_outside V). -Proof. intros m l. reflexivity. Qed. - -#[local] Instance model_map_outside_trans V : Transitive (model_map_outside V). -Proof. - intros m m' m'' h h' l hnin k. - rewrite (h l hnin k). now apply h'. -Qed. - -(** The termination proof relies on the correctness of check_model: - it does strictly increase a value but not above [max_gain cls]. -*) - -Lemma clauses_conclusions_diff cls s : - clauses_conclusions (Clauses.diff cls (clauses_with_concl cls s)) ⊂_lset - LevelSet.diff (clauses_conclusions cls) s. -Proof. - intros a. rewrite LevelSet.diff_spec !clauses_conclusions_spec. - firstorder eauto. - exists x; split => //. - now rewrite Clauses.diff_spec in H. - intros ha. - rewrite Clauses.diff_spec in H; destruct H as []. - apply H1. - rewrite in_clauses_with_concl. split => //. - now rewrite H0. -Qed. - -Lemma diff_eq U V : LevelSet.diff V U =_lset V <-> LevelSet.inter V U =_lset LevelSet.empty. -Proof. split. lsets. lsets. Qed. - -Lemma levelset_neq U V : LevelSet.equal U V = false -> ~ LevelSet.Equal U V. -Proof. intros eq heq % LevelSet.equal_spec. congruence. Qed. - -Lemma levelset_union_same U : LevelSet.union U U =_lset U. -Proof. lsets. Qed. - -Class Commutative {A} (f : A -> A -> A) := comm : forall x y, f x y = f y x. -Instance option_map_2_comm {A} f : @Commutative A f -> @Commutative (option A) (option_map2 f). -Proof. - intros com [x|] [y|] => //=. now rewrite comm. -Qed. - -Instance Zmin_comm : Commutative Z.min := Z.min_comm. -Instance Zmax_comm : Commutative Z.max := Z.max_comm. - -Instance nat_min_comm : Commutative Nat.min := Nat.min_comm. -Instance nat_max_comm : Commutative Nat.max := Nat.max_comm. - -Class Associative {A} (f : A -> A -> A) := assoc : forall x y z, f x (f y z) = f (f x y) z. -Instance option_map_2_assoc {A} f : @Associative A f -> @Associative (option A) (option_map2 f). -Proof. - intros assoc [x|] [y|] [z|]; cbn => //. now rewrite assoc. -Qed. - -Instance nat_min_assoc : Associative Nat.min := Nat.min_assoc. -Instance nat_max_assoc : Associative Nat.max := Nat.max_assoc. - - -Instance Zmin_assoc : Associative Z.min := Z.min_assoc. -Instance Zmax_assoc : Associative Z.max := Z.max_assoc. - -Lemma fold_left_comm {A B} (f : B -> A -> B) (l : list A) (x : A) (acc : B) : - (forall x y z, f (f z x) y = f (f z y) x) -> - fold_left f l (f acc x) = f (fold_left f l acc) x. -Proof. - intros. - induction l in acc, x |- *; cbn. auto. - rewrite -IHl. f_equal. now rewrite H. -Qed. - -Lemma fold_left_min_opt_comm {A} (f : A -> A -> A) l x acc : - Associative f -> Commutative f -> - fold_left (option_map2 f) l (option_map2 f acc x) = option_map2 f (fold_left (option_map2 f) l acc) x. -Proof. - intros ass c. rewrite fold_left_comm => //. - intros. rewrite -(assoc (f := option_map2 f)). - rewrite -(assoc (f := option_map2 f) z y x0). - f_equal. apply comm. -Qed. - -Lemma fold_left_le {A} {le} (f g : A -> LevelSet.elt -> A) l : - (forall acc acc' x, In x l -> le acc acc' -> le (f acc x) (g acc' x)) -> - forall acc acc', le acc acc' -> - le (fold_left f l acc) (fold_left g l acc'). -Proof. - intros hfg. - induction l => //. cbn. intros. - apply IHl. intros. apply hfg => //. now right. apply hfg => //. now left. -Qed. - -Local Open Scope nat_scope. -Lemma fold_left_ne_lt (f g : nat -> LevelSet.elt -> nat) l acc : - (forall (x y : LevelSet.elt) z, f (f z x) y = f (f z y) x) -> - (forall (x y : LevelSet.elt) z, g (g z x) y = g (g z y) x) -> - l <> [] -> - (forall acc acc' x, In x l -> (acc <= acc') -> (f acc x <= g acc' x)) -> - (forall acc acc' x, In x l -> (acc < acc') -> (f acc x < g acc' x)) -> - (exists x, In x l /\ forall acc acc', (acc <= acc') -> (f acc x < g acc' x)) -> - fold_left f l acc < fold_left g l acc. -Proof. - intros hf hg. - generalize (Nat.le_refl acc). - generalize acc at 2 4. - induction l in acc |- * => //. - intros. - destruct l; cbn. - { destruct H3 as [x []]. cbn in H3. destruct H3; subst => //. - now eapply (H4 acc acc0). } - cbn in IHl. - rewrite hf hg. - rewrite fold_left_comm //. rewrite (fold_left_comm g) //. - destruct H3 as [min [hmin hfg]]. - destruct hmin as [<-|hel]. - - apply hfg. apply fold_left_le => //. intros; eapply H1 => //. now right; right. - apply H1 => //. now right; left. - - apply H2. now left. eapply IHl => //. - * intros acc1 acc' x hin. apply (H1 acc1 acc' x). now right. - * intros acc1 acc' x hin. apply (H2 acc1 acc' x). now right. - * exists min. split => //. -Qed. -Close Scope nat_scope. - -Infix "↓" := clauses_with_concl (at level 70). (* \downarrow *) -Infix "⇂" := restrict_clauses (at level 70). (* \downharpoonright *) - -Lemma clauses_conclusions_diff_left cls W cls' : - clauses_conclusions (Clauses.diff (cls ↓ W) cls') ⊂_lset W. -Proof. - intros l. - rewrite clauses_conclusions_spec. - move=> [] cl. rewrite Clauses.diff_spec => [] [] []. - move/in_clauses_with_concl => [] hin ? ? eq. - now rewrite eq in hin. -Qed. - -Lemma clauses_conclusions_diff_restrict cls W cls' : - clauses_conclusions (Clauses.diff (cls ⇂ W) cls') ⊂_lset W. -Proof. - intros l. - rewrite clauses_conclusions_spec. - move=> [] cl. rewrite Clauses.diff_spec => [] [] []. - move/in_restrict_clauses => [] hin ? ? ? eq. - now rewrite eq in hin. -Qed. - -Lemma LevelSet_In_elements l s : - In l (LevelSet.elements s) <-> LevelSet.In l s. -Proof. - rewrite LevelSetFact.elements_iff. - now rewrite InA_In_eq. -Qed. - -Lemma clauses_empty_eq {s} : Clauses.Empty s -> Clauses.Equal s Clauses.empty. -Proof. clsets. Qed. - -Lemma valid_update_value {m cl} : - valid_clause m cl -> - match update_value m cl with - | None => true - | Some _ => false - end. -Proof. - unfold update_value, valid_clause. - destruct cl as [prem [l k]]; cbn. - destruct min_premise => //. - unfold level_value_above. - destruct level_value => //. - destruct Z.leb => //. -Qed. - -Lemma level_value_not_above_spec m l k : level_value_above m l k = false -> opt_le Z.lt (level_value m l) (Some k). -Proof. - unfold level_value_above; destruct level_value => // hlt; constructor. lia. -Qed. - -Lemma clauses_for_all_neg {p s}: - ~~ Clauses.for_all p s <-> ~ Clauses.For_all p s. -Proof. - intuition auto. - rewrite ClausesFact.for_all_iff in H0. red in H. now rewrite H0 in H. - revert H. apply contra_notN. - rewrite ClausesFact.for_all_iff //. -Qed. - -Lemma clauses_for_all_exists {p s}: - ~~ Clauses.for_all p s <-> Clauses.exists_ (fun x => ~~ p x) s. -Proof. - rewrite ClausesFact.for_all_b ClausesFact.exists_b. - induction (Clauses.elements s). - - cbn; auto. reflexivity. - - cbn. rewrite negb_and. intuition auto. - move/orP: H1 => [->|] //. move/H. intros ->. now rewrite orb_true_r. - move/orP: H1 => [->|] //. move/H0. intros ->. now rewrite orb_true_r. -Qed. -#[local] Instance model_le_refl R (HR : Reflexive R) : Reflexive (model_rel R). -Proof. intros x l k map. exists k; split => //. Qed. - -#[local] Instance model_le_trans R (HR : Transitive R) : Transitive (model_rel R). -Proof. intros m m' m'' mm' m'm'' l k map. - apply mm' in map as [k' [map ?]]. - apply m'm'' in map as [k'' [map ?]]. exists k''. split => //. - now transitivity k'. -Qed. - -Lemma update_model_monotone m l k : level_value m l ≤ Some k -> - m ⩽ update_model m l k. -Proof. - intros hl. - intros l' k' maps. - unfold update_model. cbn. - destruct (eqb_spec l l'). - - subst l'. exists (Some k). move: hl. - unfold level_value. - rewrite (LevelMap.find_1 maps). - intros hle. - split => //. eapply LevelMap.add_1. eapply LevelMap.OT.eq_refl. - - exists k'. split => //. apply LevelMap.add_2 => //. reflexivity. -Qed. - -Lemma update_model_not_above m l k : level_value_above m l k = false -> - m ⩽ update_model m l k. -Proof. - unfold level_value_above. - intros hlev. - apply update_model_monotone. - destruct level_value as [v|] eqn:hv; constructor; lia. -Qed. - -Lemma level_value_MapsTo {l k} {m : model} : - LevelMap.MapsTo l k m -> level_value m l = k. -Proof. - unfold level_value. - move=> mapto; rewrite (LevelMap.find_1 mapto) //. -Qed. - -Lemma level_value_MapsTo' {l k} {m : model} : - level_value m l = Some k -> LevelMap.MapsTo l (Some k) m. -Proof. - unfold level_value. destruct LevelMap.find eqn:hfind => //. - eapply LevelMap.find_2 in hfind. now intros [= ->]. -Qed. - -Lemma strict_update_ext m cl m' : strict_update m cl m' -> m ⩽ m'. -Proof. - destruct cl as [prems [concl k]]. - unfold strict_update. - intros [v [hm ha heq]]. - intros x k' hin. setoid_rewrite heq. - setoid_rewrite LevelMapFact.F.add_mapsto_iff. - destruct (Level.eq_dec concl x). subst. - move: ha; rewrite /level_value_above. - eapply level_value_MapsTo in hin. rewrite hin. - intros hlt'. - exists (Some (k + v)). - split. left. split; reflexivity. - move/negbTE: hlt'. - destruct k' => //. - elim: Z.leb_spec => //. intros; constructor; lia. constructor. - exists k'. split => //. right; eauto. reflexivity. -Qed. - -Lemma strictly_updates_ext cls w m m' : strictly_updates cls w m m' -> m ⩽ m'. -Proof. - induction 1. - now eapply strict_update_ext in H0. - now transitivity m'. -Qed. - -Lemma check_model_le {cls acc acc'} : - check_model cls acc = Some acc' -> acc.2 ⩽ acc'.2. -Proof. - destruct acc as [w m], acc' as [w' m']. - move/check_model_spec => [w'' [su ->]]. - cbn. now eapply strictly_updates_ext. -Qed. - -Lemma level_value_update_model m l k : - level_value (update_model m l k) l = Some k. -Proof. - unfold level_value, update_model. - cbn -[LevelMap.find LevelMap.add]. - rewrite LevelMapFact.F.add_o. - destruct LevelMap.OT.eq_dec => //. - exfalso. now apply n. -Qed. - -Lemma model_map_outside_weaken {W W'} {m m' : model} : - model_map_outside W m m' -> - W ⊂_lset W' -> - model_map_outside W' m m'. -Proof. - intros hm sub x hin k. - apply hm. intros hin'. apply sub in hin'. now apply hin. -Qed. - -Lemma is_model_union {cls cls' m} : - is_model cls m -> is_model cls' m -> is_model (Clauses.union cls cls') m. -Proof. - rewrite /is_model. rewrite /is_true -!ClausesFact.for_all_iff. - now move=> ism ism' x /Clauses.union_spec []. -Qed. - -Lemma model_le_values {m m' : model} x : m ⩽ m' -> level_value m x ≤ level_value m' x. -Proof. - intros lem. specialize (lem x). - unfold level_value. - destruct LevelMap.find eqn:hl => //. - - apply LevelMap.find_2 in hl. specialize (lem _ hl) as [k' [mapsto leq]]. - now rewrite (LevelMap.find_1 mapsto). - - constructor. -Qed. - -Infix "⊂_clset" := Clauses.Subset (at level 70). - -Lemma max_gain_in cl cls : - Clauses.In cl cls -> - (Z.to_nat (gain cl) <= max_gain cls)%nat. -Proof. - intros hin. - unfold max_gain. revert cl hin. - eapply ClausesProp.fold_rec. - - intros s' ise hin. firstorder eauto. - - intros x a s' s'' xs nxs' hadd IH cl' hin'. - eapply hadd in hin' as []. - * subst x. lia. - * specialize (IH _ H). lia. -Qed. - -Definition max_gain_subset (cls cls' : Clauses.t) : - cls ⊂_clset cls' -> - (max_gain cls <= max_gain cls')%nat. -Proof. - unfold max_gain at 1. - revert cls'. - eapply ClausesProp.fold_rec. - - intros s' ise sub. lia. - - intros x a s' s'' xs nxs' hadd IH cls'' hs. - specialize (IH cls''). forward IH. transitivity s'' => //. - intros ??. now apply hadd. - assert (incls'' : Clauses.In x cls''). - { now apply hs, hadd. } - apply max_gain_in in incls''. lia. -Qed. - -Lemma max_clause_premise_spec cl cls : - Clauses.In cl cls -> - (premise_max (premise cl) <= max_clause_premise cls)%Z. -Proof. - intros hin. - unfold max_clause_premise. revert cl hin. - eapply ClausesProp.fold_rec. - - intros s' ise hin. firstorder eauto. - - intros x a s' s'' xs nxs' hadd IH cl' hin'. - eapply hadd in hin' as []. - * subst x. lia. - * specialize (IH _ H). lia. -Qed. - -Notation cls_diff cls W := (Clauses.diff (cls ↓ W) (cls ⇂ W)) (only parsing). - -(* - Equations? extend_model {W cls} (m : valid_model W (cls ⇂ W)) - (r : result W (Clauses.diff (cls ↓ W) (cls ⇂ W))) - : result W (cls ↓ W) := - extend_model _ Loop := Loop; - extend_model m (Model w m' sub) := - Model w {| model_model := m'.(model_model) |} _. - Proof. - - apply LevelSet.subset_spec in sub. now apply clauses_conclusions_clauses_with_concl in H. - - eapply sub. now eapply m.(model_clauses_conclusions). - - apply m. - - eapply LevelSet.subset_spec. eapply LevelSet.subset_spec in sub. - now transitivity V. - Qed. - - *) - -Lemma not_mem l s : ~~ LevelSet.mem l s <-> ~ LevelSet.In l s. -Proof. - split. apply contraNnot. apply LevelSet.mem_spec. - eapply contra_notN; tea. now move/LevelSet.mem_spec. -Qed. +(** The termination proof relies on the correctness of check_model: + it does strictly increase a value but not above [max_gain cls]. +*) Lemma v_minus_w_bound_irrel {W} m m' : model_map_outside W m m' -> @@ -1061,330 +70,8 @@ Proof. - now apply out. Qed. -Definition max_premise_value (m : model) (l : nonEmptyLevelExprSet) : option Z := - let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (fun min atom => option_map2 Z.max (levelexpr_value m atom) min) tl (levelexpr_value m hd). - -Definition non_W_atoms W (l : LevelExprSet.t) := - LevelExprSet.filter (fun lk => ~~ LevelSet.mem lk.1 W) l. - -Lemma non_W_atoms_spec W l : forall x, LevelExprSet.In x (non_W_atoms W l) <-> LevelExprSet.In x l /\ ~ LevelSet.In x.1 W. -Proof. - intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec -not_mem. -Qed. - -Lemma non_W_atoms_subset W l : non_W_atoms W l ⊂_leset l. -Proof. intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec. Qed. - -Lemma levelexprset_levels_spec_aux l (e : LevelExprSet.t) acc : - LevelSet.In l (LevelExprSet.fold (fun le : LevelExprSet.elt => LevelSet.add (level le)) e acc) <-> - (exists k, LevelExprSet.In (l, k) e) \/ LevelSet.In l acc. -Proof. - eapply LevelExprSetProp.fold_rec. - - intros. - intuition auto. destruct H1 as [k hin]. lesets. - - intros x a s' s'' hin nin hadd ih. - rewrite LevelSet.add_spec. - split. - * intros [->|]. - left. exists x.2. red in H. subst. - apply hadd. cbn. left. now destruct x. - apply ih in H. - intuition auto. - left. destruct H0 as [k Hk]. exists k. apply hadd. now right. - * intros [[k ins'']|inacc]. - eapply hadd in ins''. destruct ins''; subst. - + now left. - + right. apply ih. now left; exists k. - + right. intuition auto. -Qed. - -Lemma levelexprset_levels_spec l (e : LevelExprSet.t) : - LevelSet.In l (levels e) <-> exists k, LevelExprSet.In (l, k) e. -Proof. - rewrite levelexprset_levels_spec_aux. intuition auto. lsets. -Qed. - -Lemma levels_exprs_non_W_atoms {W prem} : - LevelSet.Equal (levels (non_W_atoms W prem)) (LevelSet.diff (levels prem) W). -Proof. - intros e. unfold non_W_atoms. - rewrite levelexprset_levels_spec LevelSet.diff_spec levelexprset_levels_spec. - firstorder eauto. - rewrite LevelExprSet.filter_spec in H. now exists x. - rewrite LevelExprSet.filter_spec in H. destruct H. - rewrite LevelSetFact.not_mem_iff. - destruct LevelSet.mem => //. - exists x. - rewrite LevelExprSet.filter_spec. split => //. - rewrite LevelSetFact.not_mem_iff in H0. now rewrite H0. -Qed. - -Lemma levelexprset_empty_levels x : LevelExprSet.Empty x <-> LevelSet.Empty (levels x). -Proof. - split. - - intros he. - intros l hin. - eapply levelexprset_levels_spec in hin as [k hin]. lesets. - - intros emp l hin. eapply emp. eapply (levelexprset_levels_spec l.1). exists l.2. - now destruct l. -Qed. - -Lemma non_W_atoms_ne W cl cls : - Clauses.In cl (cls_diff cls W) -> - LevelExprSet.is_empty (non_W_atoms W (premise cl)) = false. -Proof. - intros x. - apply Clauses.diff_spec in x as [clw clr]. - eapply in_clauses_with_concl in clw as [clw incls]. - apply/negbTE. - apply/(contra_notN _ clr). - intros he. rewrite in_restrict_clauses. split => //. - epose proof (@levels_exprs_non_W_atoms W (premise cl)). - eapply LevelExprSetFact.is_empty_2 in he. - intros x hin. eapply levelexprset_empty_levels in he. rewrite H in he. - specialize (he x). rewrite LevelSet.diff_spec in he. intuition auto. - rewrite -LevelSet.mem_spec in H1 |- *. destruct LevelSet.mem; intuition auto. -Qed. - Local Open Scope Z_scope. -Section MoreNonEmpty. - - Import LevelExprSet. - Lemma In_elements {x} {s : LevelExprSet.t} : In x s <-> List.In x (elements s). - Proof. - split. now move/LevelExprSetFact.elements_1/InA_In_eq. - now move/InA_In_eq/LevelExprSetFact.elements_2. - Qed. - Import NonEmptySetFacts. - - Notation min_opt := (option_map2 Z.min). - Lemma Zmin_opt_left x y : min_opt x y ≤Z x. - Proof. - destruct x as [x|], y as [y|]; constructor. lia. - Qed. - - Lemma Zmin_opt_right x y : min_opt x y ≤Z y. - Proof. - destruct x as [x|], y as [y|]; constructor. lia. - Qed. - - Lemma min_opt_spec x y z : min_opt x y = z -> (z = y \/ z = x). - Proof. - destruct x as [x|], y as [y|], z as [z|]; cbn; intuition auto. - - noconf H. pose proof (Zmin_irreducible x y). destruct H; intuition (f_equal; auto). - - noconf H. - Qed. - - Lemma min_premise_spec_aux (m : model) s k : - min_premise m s = k -> - (forall x, LevelExprSet.In x s -> (k ≤Z min_atom_value m x)) /\ - (exists x, LevelExprSet.In x s /\ k = min_atom_value m x). - Proof. - unfold min_premise. - move: (to_nonempty_list_spec s). - destruct (to_nonempty_list s). intros heq. - setoid_rewrite In_elements. rewrite -heq. clear s heq. - intros <-. - induction l. - - cbn. - split. intros x [->|] => //. reflexivity. - now exists p; split => //. - - destruct IHl as [ha hex]. - split. - * intros x hin. - eapply (in_elt_inv x a [p]) in hin as [<-|inih]. - { cbn. rewrite fold_left_comm. - { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } - apply Zmin_opt_left. } - specialize (ha _ inih). - cbn. rewrite fold_left_comm. - { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } - etransitivity; [apply Zmin_opt_right|assumption]. - * destruct hex as [minval [inmin ih]]. - cbn. rewrite fold_left_comm. - { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } - rewrite ih. - destruct (min_opt_spec (min_atom_value m a) (min_atom_value m minval) _ eq_refl). - { rewrite H. exists minval. cbn in inmin. split; [intuition|reflexivity]. } - { rewrite H. exists a. cbn in inmin. split; [intuition|reflexivity]. } - Qed. - - Lemma min_premise_spec (m : model) (s : nonEmptyLevelExprSet) : - (forall x, LevelExprSet.In x s -> min_premise m s ≤Z min_atom_value m x) /\ - (exists x, LevelExprSet.In x s /\ min_premise m s = min_atom_value m x). - Proof. - now apply min_premise_spec_aux. - Qed. - - Lemma min_premise_subset (m : model) (s s' : nonEmptyLevelExprSet) : - LevelExprSet.Subset s s' -> - min_premise m s' ≤Z min_premise m s. - Proof. - intros sub. - have [has [mins [ins eqs]]] := min_premise_spec m s. - have [has' [mins' [ins' eqs']]] := min_premise_spec m s'. - specialize (sub _ ins). specialize (has' _ sub). - now rewrite eqs. - Qed. - - Lemma premise_min_spec_aux s k : - premise_min s = k -> - (forall x, LevelExprSet.In x s -> (k <= x.2)%Z) /\ - (exists x, LevelExprSet.In x s /\ k = x.2). - Proof. - unfold premise_min. - move: (to_nonempty_list_spec s). - destruct (to_nonempty_list s). intros heq. - setoid_rewrite In_elements. rewrite -heq. clear s heq. - intros <-. - induction l. - - cbn. - split. intros x [->|] => //. reflexivity. - now exists p; split => //. - - destruct IHl as [ha hex]. - split; intros. - eapply (in_elt_inv x a [p]) in H as [<-|inih]. - cbn. rewrite fold_left_comm. lia. lia. - specialize (ha _ inih). - cbn. rewrite fold_left_comm. lia. lia. - destruct hex as [minval [inmin ih]]. - cbn. rewrite fold_left_comm. lia. - destruct (Z.leb_spec a.2 minval.2). - exists a. split; [intuition|]. rewrite -ih in H. lia. - exists minval. - cbn in inmin; split; [intuition auto|]. lia. - Qed. - - Lemma premise_min_spec (s : nonEmptyLevelExprSet) : - (forall x, LevelExprSet.In x s -> premise_min s <= x.2) /\ - (exists x, LevelExprSet.In x s /\ premise_min s = x.2). - Proof. - now apply premise_min_spec_aux. - Qed. - - Lemma premise_max_spec_aux s k : - premise_max s = k -> - (forall x, LevelExprSet.In x s -> x.2 <= k) /\ - (exists x, LevelExprSet.In x s /\ k = x.2). - Proof. - unfold premise_max. - move: (to_nonempty_list_spec s). - destruct (to_nonempty_list s). intros heq. - setoid_rewrite In_elements. rewrite -heq. clear s heq. - intros <-. - induction l. - - cbn. - split. intros x [->|] => //. reflexivity. - now exists p; split => //. - - destruct IHl as [ha hex]. - split; intros. - eapply (in_elt_inv x a [p]) in H as [<-|inih]. - cbn. rewrite fold_left_comm. lia. lia. - specialize (ha _ inih). - cbn. rewrite fold_left_comm. lia. lia. - destruct hex as [maxval [inmin ih]]. - cbn. rewrite fold_left_comm. lia. - destruct (Z.leb_spec a.2 maxval.2). - exists maxval. cbn in inmin; split; [intuition auto|]. - lia. - exists a. split; [intuition|]. rewrite -ih in H. cbn in inmin. - lia. - Qed. - - Lemma premise_max_spec (s : nonEmptyLevelExprSet) : - (forall x, LevelExprSet.In x s -> x.2 <= premise_max s) /\ - (exists x, LevelExprSet.In x s /\ premise_max s = x.2). - Proof. - now apply premise_max_spec_aux. - Qed. - - Lemma premise_min_subset (s s' : nonEmptyLevelExprSet) : - LevelExprSet.Subset s s' -> - (premise_min s' <= premise_min s). - Proof. - intros sub. - have [has [mins [ins eqs]]] := premise_min_spec s. - have [has' [mins' [ins' eqs']]] := premise_min_spec s'. - specialize (sub _ ins). specialize (has' _ sub). - lia. - Qed. - - Lemma fold_comm_assoc_nat x y z : option_map2 Nat.max x (option_map2 Nat.max y z) = - option_map2 Nat.max y (option_map2 Nat.max x z). - Proof. - now rewrite (assoc (f := option_map2 Nat.max)) (comm (f := option_map2 Nat.max) x y) -assoc. - Qed. - - Lemma fold_comm_assoc x y z : option_map2 Z.max x (option_map2 Z.max y z) = - option_map2 Z.max y (option_map2 Z.max x z). - Proof. - now rewrite (assoc (f := option_map2 Z.max)) (comm (f := option_map2 Z.max) x y) -assoc. - Qed. - - Notation max_opt := (option_map2 Z.max). - - Lemma max_opt_spec x y z : max_opt x y = Some z -> exists x' y', x = Some x' /\ y = Some y' /\ z = Z.max x' y'. - Proof. - destruct x as [x|], y as [y|]; cbn; intuition eauto; try noconf H. - exists x, y. auto. - Qed. - - Lemma max_premise_value_spec_aux (m : model) s k : - max_premise_value m s = Some k -> - (forall x, LevelExprSet.In x s -> exists k', levelexpr_value m x = Some k' /\ Some k' ≤ Some k) /\ - (exists x, LevelExprSet.In x s /\ Some k = levelexpr_value m x). - Proof. - unfold max_premise_value. - move: (to_nonempty_list_spec s). - destruct (to_nonempty_list s). intros heq. - setoid_rewrite In_elements. rewrite -heq. clear s heq. - induction l in k |- *. - - cbn. - intros eq. - split. intros x [->|] => //. exists k. split => //. reflexivity. - now exists p; split => //. - - cbn. rewrite fold_left_comm. intros; apply fold_comm_assoc. - intros heq. apply max_opt_spec in heq as [y' [z' [eqa [eqf ->]]]]. - specialize (IHl _ eqf). destruct IHl as [ha hex]. - split; intros. - eapply (in_elt_inv x a [p]) in H as [<-|inih]. - { exists y'; intuition eauto. constructor; lia. } - { specialize (ha _ inih) as [k' []]. exists k'; intuition eauto. constructor. depelim H0; lia. } - destruct hex as [maxval [inmax ih]]. - cbn. - destruct (Z.leb_spec z' y'). - exists a. split; [intuition|]. rewrite eqa. f_equal. lia. - exists maxval. cbn in inmax; split; [intuition auto|]. rewrite -ih. f_equal; lia. - Qed. - - Lemma max_premise_value_spec (m : model) (s : nonEmptyLevelExprSet) k : - max_premise_value m s = Some k -> - (forall x, LevelExprSet.In x s -> exists k', levelexpr_value m x = Some k' /\ Some k' ≤ Some k) /\ - (exists x, LevelExprSet.In x s /\ Some k = levelexpr_value m x). - Proof. - apply (max_premise_value_spec_aux m s). - Qed. -End MoreNonEmpty. - -Lemma min_premise_pos_spec {m prem k} : - min_premise m prem = Some k -> - forall x, LevelExprSet.In x prem -> Some (x.2 + k)%Z ≤Z levelexpr_value m x. -Proof. - pose proof (min_premise_spec m prem) as [amin [exmin [inminpre eqminpre]]]. - intros hprem x hin. - specialize (amin _ hin). - unfold min_atom_value in amin. - destruct x as [l k']; cbn in *. unfold levelexpr_value; cbn. - destruct (level_value m l) eqn:he. - - depelim amin. - rewrite H0 in hprem. depelim hprem. constructor. lia. - constructor. - rewrite H in hprem; depelim hprem. - - depelim amin. rewrite H in hprem. depelim hprem. -Qed. - Lemma v_minus_w_bound_spec W m : forall x, ~ LevelSet.In x W -> level_value m x ≤ Some (v_minus_w_bound W m). Proof. @@ -1421,73 +108,6 @@ Proof. destruct LevelMap.find => hf; depelim hf; constructor; lia. Qed. -Lemma clauses_levels_restrict_clauses cls W : - clauses_levels (cls ⇂ W) ⊂_lset W. -Proof. - intros x [cl []] % clauses_levels_spec. - eapply in_restrict_clauses in H as [hconc hprem incl]. - eapply clause_levels_spec in H0 as []. apply hprem, H. now subst x. -Qed. - -Lemma clauses_conclusions_levels cls : - clauses_conclusions cls ⊂_lset clauses_levels cls. -Proof. - intros x. - rewrite clauses_conclusions_spec clauses_levels_spec. - setoid_rewrite clause_levels_spec. - firstorder auto. -Qed. - -Record model_extension W m m' := - { model_ext_le : m ⩽ m'; - model_ext_same_domain : model_same_domain m m'; - model_ext_same_outside : model_map_outside W m m' }. - -#[local] Instance model_ext_reflexive W : Reflexive (model_extension W). -Proof. - intros m; split; reflexivity. -Qed. - -#[local] Instance model_ext_transitive W : Transitive (model_extension W). -Proof. - intros m m' m'' h h'; split; (etransitivity; [apply h|apply h']). -Qed. - -Lemma model_extension_weaken W W' m m' : - W ⊂_lset W' -> - model_extension W m m' -> - model_extension W' m m'. -Proof. - intros leW []; split => //. - eapply model_map_outside_weaken; tea. -Qed. - -Lemma model_ext_trans_weaken W W' m m' m'' : - W ⊂_lset W' -> - model_extension W m m' -> - model_extension W' m' m'' -> - model_extension W' m m''. -Proof. - intros leW mext mext'. eapply model_extension_weaken in mext; tea. - now etransitivity; tea. -Qed. - -Definition model_of V (m : model) := - forall k, LevelSet.In k V -> LevelMap.In k m. - -Definition defined_model_of V (m : model) := - forall l, LevelSet.In l V -> exists k, LevelMap.MapsTo l (Some k) m. - -Definition only_model_of V (m : model) := - forall k, LevelSet.In k V <-> exists x, LevelMap.MapsTo k x m. - -Lemma only_model_of_model_of {V m} : only_model_of V m -> model_of V m. -Proof. - intros om l. move/om. intros [k hm]; now exists k. -Qed. - -Coercion only_model_of_model_of : only_model_of >-> model_of. - Definition check_model_invariants cls w m w' m' (modified : bool) := if modified then [/\ w ⊂_lset w', @@ -1501,62 +121,7 @@ Definition check_model_invariants cls w m w' m' (modified : bool) := model_of w' m'] else (w, m) = (w', m') /\ model_of w m. -Lemma nEmpty_exists ls : ~ (LevelSet.Empty ls) -> exists l, LevelSet.In l ls. -Proof. - intros ne. - destruct (LevelSet.choose ls) eqn:isempty. exists e. - now apply LevelSet.choose_spec1 in isempty. - now apply LevelSet.choose_spec2 in isempty. -Qed. - -Lemma inLevelSet (ls : LevelSet.t) l : LevelSet.In l ls \/ ~ (LevelSet.In l ls). -Proof. - lsets. -Qed. - -Lemma level_value_above_MapsTo m l k : level_value_above m l k -> exists k', LevelMap.MapsTo l k' m /\ (Some k ≤ k'). -Proof. - unfold level_value_above. - destruct level_value eqn:hl => //. - move/Z.leb_le => hle; exists (Some z). - eapply level_value_MapsTo' in hl. split => //. now constructor. -Qed. - -Lemma level_value_above_MapsTo' m l k k' : LevelMap.MapsTo l k' m -> (Some k ≤ k') -> level_value_above m l k. -Proof. - unfold level_value_above. - intros H; apply LevelMap.find_1 in H. rewrite /level_value H. - destruct k'. intros h; depelim h. - now apply Z.leb_le. intros h; depelim h. -Qed. - -Lemma level_value_add m l k : level_value (LevelMap.add l (Some k) m) l = Some k. -Proof. - rewrite /level_value LevelMapFact.F.add_eq_o //. -Qed. - -#[local] Instance clauses_conclusions_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_conclusions. -Proof. - intros cls cls' eq x. - rewrite !clauses_conclusions_spec. now setoid_rewrite eq. -Qed. - -#[local] Instance And3P_proper : Proper (iff ==> iff ==> iff ==> iff) ssrbool.and3. -Proof. - repeat intro. split; intros []; split; intuition auto. -Qed. - -#[local] Instance And4P_proper : Proper (iff ==> iff ==> iff ==> iff ==> iff) ssrbool.and4. -Proof. - repeat intro. split; intros []; split; intuition auto. -Qed. - -#[local] Instance And5P_proper : Proper (iff ==> iff ==> iff ==> iff ==> iff ==> iff) ssrbool.and5. -Proof. - repeat intro. split; intros []; split; intuition auto. -Qed. - -#[local] Instance check_model_invariants_proper : +#[export] Instance check_model_invariants_proper : Proper (Clauses.Equal ==> eq ==> eq ==> eq ==> eq ==> eq ==> iff) check_model_invariants. Proof. intros cls cls' eqcls. @@ -1566,65 +131,6 @@ Proof. now setoid_rewrite <-eqcls. Qed. -Lemma min_atom_value_levelexpr_value m l a lv : min_atom_value m l = Some a -> levelexpr_value m l = Some lv -> - (a <= lv - l.2). -Proof. - destruct l as [l k]; cbn. unfold levelexpr_value. cbn. destruct level_value => //. - intros [= <-] [= <-]. lia. -Qed. - -Lemma clauses_conclusions_add cl cls : - clauses_conclusions (Clauses.add cl cls) =_lset - (LevelSet.singleton (level (concl cl)) ∪ - clauses_conclusions cls). -Proof. - intros x. - rewrite LevelSet.union_spec !clauses_conclusions_spec. - setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.singleton_spec. - firstorder eauto. subst. now left. -Qed. - -Definition declared_model_level (m : model) l := LevelMap.In l m. - -Definition update_model_same_domain {m l k} : - declared_model_level m l -> - model_same_domain m (update_model m l k). -Proof. - unfold update_model, declared_model_level. - intros hin x. - rewrite LevelMapFact.F.add_in_iff. intuition auto. now subst. -Qed. - -Definition update_model_outside {m w l k} : - model_map_outside (LevelSet.add l w) m (update_model m l k). -Proof. - unfold update_model, model_map_outside. - intros l'. rewrite LevelSet.add_spec. - intros hin k'. - rewrite LevelMapFact.F.add_neq_mapsto_iff //. - intros heq. red in heq; subst l'. apply hin. now left. -Qed. - -Lemma opt_lt_le_trans x y z : - opt_le Z.lt x y -> - opt_le Z.le y z -> - opt_le Z.lt x z. -Proof. - intros [] H'; depelim H'; constructor. lia. -Qed. - -Lemma model_of_update w m l k : model_of w m -> model_of (LevelSet.add l w) (update_model m l k). -Proof. - rewrite /model_of => hint l'. rewrite LevelSet.add_spec. - intros [->|hadd]. - - exists (Some k). now apply LevelMap.add_1. - - specialize (hint _ hadd). unfold update_model. - destruct hint as [x hx]. - destruct (eqb_spec l l'). subst. - now exists (Some k); apply LevelMap.add_1. - now exists x; eapply LevelMap.add_2. -Qed. - Definition levelset_m_eq : list Level.t × model -> list Level.t × model -> Prop := fun x y => x.1 = y.1 /\ LevelMap.Equal x.2 y.2. @@ -1636,121 +142,6 @@ Proof. all:etransitivity; tea. Qed. -(* Definition optm := optm *) - -(* #[local] Instance update_value_proper : Proper (LevelMap.Equal ==> eq ==> opt ) update_value. *) - -#[local] Instance check_clause_model_proper : Proper (eq ==> levelset_m_eq ==> levelset_m_eq) check_clause_model. -Proof. - intros x y eq [] [] []; cbn in *; subst. - unfold levelset_m_eq. - replace (update_value m y) with (update_value m0 y). split => //; destruct update_value => //. - unfold update_value. setoid_rewrite H0. -Abort. - -Instance model_map_outside_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) model_map_outside. -Proof. - intros ? ? eqcl ? ? eqm ? ? eqs. - unfold model_map_outside. - setoid_rewrite eqcl. now setoid_rewrite eqm; setoid_rewrite eqs. -Qed. - -#[local] Instance proper_levelexprset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) - levels. -Proof. - intros s s' eq l. - rewrite !levelexprset_levels_spec. - firstorder eauto. -Qed. - -Lemma min_premise_spec' {m prems z} : min_premise m prems = Some z -> - (forall l k, LevelExprSet.In (l, k) prems -> - exists v, level_value m l = Some v /\ z <= (v - k))%Z. -Proof. - intros hmin. - have [hall hhmin'] := min_premise_spec m prems. - intros l k hin; specialize (hall _ hin). rewrite hmin in hall. - depelim hall. destruct level_value => //. noconf H0. exists z0. split => //. -Qed. - -Lemma nonEmptyLevelExprSet_elim {P : nonEmptyLevelExprSet -> Prop} : - (forall le, P (singleton le)) -> - (forall le prems, P prems -> ~ LevelExprSet.In le prems -> P (add le prems)) -> - forall prems, P prems. -Proof. - intros hs ha. - intros []. - revert t_set0 t_ne0. - apply: LevelExprSetProp.set_induction; eauto. - - move=> s /LevelExprSetFact.is_empty_1 he ne; exfalso => //. congruence. - - intros s s' IH x nin hadd hne. - destruct (LevelExprSet.is_empty s) eqn:hem in |- . - eapply LevelExprSetFact.is_empty_2 in hem. - assert (singleton x = {| t_set := s'; t_ne := hne |}) as <- => //. - unfold singleton. apply eq_univ_equal. cbn. - intros a. specialize (hadd a). rewrite hadd. - rewrite LevelExprSet.singleton_spec. firstorder. subst. reflexivity. - specialize (IH hem). - specialize (ha x _ IH). - assert (LevelExprSet.Equal (add x {| t_set := s; t_ne := hem|}) {| t_set := s'; t_ne := hne |}). - 2:{ apply eq_univ_equal in H. now rewrite -H. } - intros x'. specialize (hadd x'). rewrite LevelExprSet.add_spec. - cbn. firstorder. subst x'. now left. -Qed. - -Lemma min_premise_pres {m m'} prems : m ⩽ m' -> min_premise m prems ≤Z min_premise m' prems. -Proof. - intros ext. - destruct (min_premise m prems) eqn:hmin. - have leq := min_premise_spec' hmin. 2:constructor. - have [leq' e'] := min_premise_spec m' prems. - destruct (min_premise_spec m prems) as [_ [minz [inminz eqminz]]]. - rewrite hmin in eqminz. - rewrite eqminz. destruct e' as [min' []]. rewrite H0. - transitivity (min_atom_value m min'). - 2:{ unfold min_atom_value. destruct min'. - unfold level_value. destruct (LevelMap.find t m) eqn:hfind. 2:constructor. - apply LevelMap.find_2 in hfind. apply ext in hfind as [k' [hfind hle]]. - apply LevelMap.find_1 in hfind. rewrite hfind. depelim hle; constructor. lia. - } - destruct min'. specialize (leq _ _ H) as [? []]. - unfold min_atom_value at 2. rewrite H1. rewrite -eqminz. constructor. lia. -Qed. - -Lemma level_value_above_mon m m' l k : m ⩽ m' -> level_value_above m l k -> level_value_above m' l k. -Proof. - intros ext; move/level_value_above_MapsTo => [v [hm hleq]]. - eapply ext in hm. destruct hm as [v' [hm' leq']]. - eapply level_value_above_MapsTo'; tea. transitivity v => //. -Qed. - -Lemma model_of_subset V V' m : - model_of V m -> V' ⊂_lset V -> model_of V' m. -Proof. - intros ih hv k. specialize (ih k). - now move/hv. -Qed. - -Instance only_model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) only_model_of. -Proof. - intros ? ? eq ? ? eq'. - rewrite /only_model_of. now setoid_rewrite eq; setoid_rewrite eq'. -Qed. - -Lemma only_model_of_eq V V' m : - only_model_of V m -> V' =_lset V -> only_model_of V' m. -Proof. - intros ih hv k. now rewrite hv. -Qed. - -Lemma clauses_conclusions_subset {cls cls'} : - Clauses.Subset cls cls' -> - clauses_conclusions cls ⊂_lset clauses_conclusions cls'. -Proof. - intros hsub x. rewrite !clauses_conclusions_spec. - intuition eauto. destruct H as [cl []]; exists cl; split; try clsets; auto. -Qed. - Lemma check_model_ext {cls w init_model m w' m'} : check_model cls (w, m) = Some (w', m') -> strictly_updates cls w init_model m -> @@ -1879,7 +270,7 @@ Proof. now apply in_clauses_with_concl in hin as [hin _]. } depelim hlt. enough (k + z <= (v_minus_w_bound W m) + k - premise_min preml)%Z. lia. - assert (min_premise m prem ≤Z min_premise m preml)%Z. + assert (min_premise m prem ≤ min_premise m preml)%Z. { eapply min_premise_subset. eapply non_W_atoms_subset. } rewrite hmin in H1. depelim H1. transitivity (k + y)%Z. lia. @@ -1977,7 +368,7 @@ Lemma add_expr_add_expr n n' lk : add_expr n (add_expr n' lk) = add_expr (n + n' Proof. destruct lk; unfold add_expr. f_equal; lia. Qed. Definition add_prems n s := map (add_expr n) s. -Lemma In_add_prems k (prems : nonEmptyLevelExprSet): +Lemma In_add_prems k (prems : premises): forall le, LevelExprSet.In le (add_prems k prems) <-> exists le', LevelExprSet.In le' prems /\ le = add_expr k le'. Proof. @@ -2080,7 +471,7 @@ Variant in_pred_closure cls : clause -> Prop := Derive Signature for in_pred_closure. Inductive entails (cls : clauses) : clause -> Prop := -| clause_in (prems : nonEmptyLevelExprSet) (concl : LevelExpr.t) : +| clause_in (prems : premises) (concl : LevelExpr.t) : LevelExprSet.In concl prems -> entails cls (prems, concl) | clause_cut prems' concl' prems concl : in_pred_closure cls (prems', concl') -> @@ -2088,20 +479,20 @@ Inductive entails (cls : clauses) : clause -> Prop := LevelExprSet.Subset prems' prems -> entails cls (prems, concl). -Definition entails_all cls (prems concls : nonEmptyLevelExprSet) := +Definition entails_all cls (prems concls : premises) := LevelExprSet.For_all (fun le => entails cls (prems, le)) concls. Notation " cls ⊢ prems → concl " := (entails cls (prems, concl)) (at level 20). Notation " cls ⊢a prems → concl " := (entails_all cls prems concl) (at level 20). -Lemma in_pred_closure_equal cls (prems prems' : nonEmptyLevelExprSet) concl : +Lemma in_pred_closure_equal cls (prems prems' : premises) concl : LevelExprSet.Equal prems prems' -> in_pred_closure cls (prems, concl) -> in_pred_closure cls (prems', concl). Proof. intros eq. apply NonEmptySetFacts.eq_univ_equal in eq. now subst prems. Qed. -Lemma entails_equal cls (prems prems' : nonEmptyLevelExprSet) concl : +Lemma entails_equal cls (prems prems' : premises) concl : LevelExprSet.Equal prems prems' -> entails cls (prems, concl) -> entails cls (prems', concl). Proof. @@ -2235,7 +626,7 @@ Proof. eapply (in_pred_closure_shift _ H). Qed. -Lemma entails_subset cls (prems prems' : nonEmptyLevelExprSet) concl : LevelExprSet.Subset prems prems' -> +Lemma entails_subset cls (prems prems' : premises) concl : LevelExprSet.Subset prems prems' -> entails cls (prems, concl) -> entails cls (prems', concl). Proof. @@ -2284,7 +675,7 @@ Lemma entails_weak_union {cls prem concl concl'} : Proof. intros hyp. move: concl'. - apply: nonEmptyLevelExprSet_elim. + apply: premises_elim. - intros le. rewrite univ_union_comm univ_union_add_singleton. now apply entails_weak. - intros le prems ih. @@ -2332,7 +723,7 @@ Proof. now apply he in hin. Qed. -Lemma entails_all_subset {cls} {prems prems' prems'' : nonEmptyLevelExprSet} : +Lemma entails_all_subset {cls} {prems prems' prems'' : premises} : prems'' ⊂_leset prems' -> cls ⊢a prems → prems' -> cls ⊢a prems → prems''. @@ -2389,7 +780,7 @@ Lemma entails_cumul_one {cls prems prems' concl} : entails cls (prems, concl). Proof. revert prems' prems concl. - apply: nonEmptyLevelExprSet_elim. + apply: premises_elim. - intros. specialize (H le). forward H by now apply LevelExprSet.singleton_spec. cbn in H. eapply entails_add; tea. @@ -2481,7 +872,7 @@ Proof. Qed. -Lemma entails_all_shift {cls : clauses} {prems concl : univ} (n : Z) : +Lemma entails_all_shift {cls : clauses} {prems concl : premises} (n : Z) : cls ⊢a prems → concl -> cls ⊢a add_prems n prems → add_prems n concl. Proof. @@ -2524,10 +915,10 @@ Proof. Qed. -Definition to_clauses (prems : nonEmptyLevelExprSet) (concl : nonEmptyLevelExprSet) : clauses := +Definition to_clauses (prems : premises) (concl : premises) : clauses := LevelExprSet.fold (fun lk cls => Clauses.add (prems, lk) cls) concl Clauses.empty. -Definition is_loop (cls : clauses) (t : nonEmptyLevelExprSet) := +Definition is_loop (cls : clauses) (t : premises) := let cls' := to_clauses t (succ_prems t) in Clauses.For_all (fun cl' => entails cls cl') cls'. @@ -2552,7 +943,7 @@ Proof. Qed. #[program] -Definition of_level_set (ls : LevelSet.t) n (hne : ~ LevelSet.Empty ls) : nonEmptyLevelExprSet := +Definition of_level_set (ls : LevelSet.t) n (hne : ~ LevelSet.Empty ls) : premises := {| t_set := levelexprset_of_levels ls n |}. Next Obligation. apply not_Empty_is_empty => he. apply hne. @@ -2584,7 +975,7 @@ Proof. Qed. Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := - | Loop (v : univ) (islooping : loop_on_univ cls v) + | Loop (v : premises) (islooping : loop_on_univ cls v) | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). Arguments Loop {V U cls m}. Arguments Model {V U cls m}. @@ -3134,7 +1525,7 @@ Section InnerLoop. assert (ne : LevelExprSet.is_empty prem' = false). { now eapply (non_W_atoms_ne W (prem, (l, k)) cls). } set (preml := {| t_set := prem'; t_ne := ne |}). - assert (min_premise m prem ≤Z min_premise m preml). + assert (min_premise m prem ≤ min_premise m preml). { eapply min_premise_subset. eapply non_W_atoms_subset. } (* min_i (f(x_i)-k_i) <= max_i(f(x_i)) - min(k_i) *) pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. @@ -3143,7 +1534,7 @@ Section InnerLoop. pose proof (max_premise_value_spec m preml _ eqmaxp) as [amax [exmax [inmaxpre eqmaxpre]]]. rewrite -eqmaxp in eqmaxpre. pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. - assert (min_premise m preml ≤Z Some (maxpreml - premise_min preml))%Z. + assert (min_premise m preml ≤ Some (maxpreml - premise_min preml))%Z. { rewrite eqminpre in H1. specialize (amax _ inminpre). destruct amax as [k' [lk' hk']]. depelim hk'. @@ -3518,7 +1909,7 @@ Section InnerLoop. Qed. - Lemma min_premise_preserved {m m'} {prems : univ} : + Lemma min_premise_preserved {m m'} {prems : premises} : (forall x, LevelSet.In x (levels prems) -> level_value m x = level_value m' x) -> min_premise m prems = min_premise m' prems. Proof. @@ -3583,7 +1974,7 @@ Section InnerLoop. apply LevelMapFact.F.not_find_in_iff in he'. firstorder. Qed. - Lemma min_premise_restrict m W (prems : univ) v : + Lemma min_premise_restrict m W (prems : premises) v : (forall l k, LevelExprSet.In (l, k) prems -> LevelSet.In l W) -> min_premise (restrict_model W m) prems = Some v -> min_premise m prems = Some v. @@ -4563,7 +2954,7 @@ Proof. Qed. #[program] -Definition of_level_map (m : LevelMap.t (option Z)) (hne : defined_map m) : nonEmptyLevelExprSet := +Definition of_level_map (m : LevelMap.t (option Z)) (hne : defined_map m) : premises := {| t_set := LevelMap.fold (fun l k acc => if k is (Some k') return _ then LevelExprSet.add (l, k') acc else acc) m LevelExprSet.empty |}. Next Obligation. apply not_Empty_is_empty. @@ -4635,7 +3026,7 @@ Proof. Qed. -Definition premise_values (prems : univ) m := +Definition premise_values (prems : premises) m := NonEmptySetFacts.map (fun '(l, k) => (l, option_get 0 (level_value m l))) prems. Lemma premise_values_spec prems m : @@ -4648,10 +3039,10 @@ Proof. exists z. split => //. exists(l, x); split => //. now rewrite -H0. Qed. -Definition hyps_map (hyps : univ) m := +Definition hyps_map (hyps : premises) m := (forall (l : Level.t) k, LevelExprSet.In (l, k) hyps <-> LevelMap.MapsTo l (Some k) m). -Lemma model_hyps_entails cls m hyps (prems : univ) concl : +Lemma model_hyps_entails cls m hyps (prems : premises) concl : Clauses.In (prems, concl) cls -> (forall l k, LevelExprSet.In (l,k) prems -> exists z, Some z ≤ level_value m l) -> hyps_map hyps m -> @@ -4667,7 +3058,7 @@ Proof. now eapply level_value_MapsTo'. Qed. -Lemma entails_succ cls (u v : univ) : +Lemma entails_succ cls (u v : premises) : (forall l k, LevelExprSet.In (l, k) v -> exists k', LevelExprSet.In (l, k') u /\ k <= k') -> cls ⊢a u → v. Proof. @@ -4678,7 +3069,7 @@ Proof. constructor. rewrite Z2Nat.id. lia. assumption. Qed. -Lemma hyps_entails (hyps : univ) m cls : +Lemma hyps_entails (hyps : premises) m cls : hyps_map hyps m -> forall prems conclk, Clauses.In (prems, conclk) cls -> forall v, min_premise m prems = Some v -> @@ -5193,14 +3584,14 @@ Proof. now constructor. Qed. -Lemma univ_non_empty (u : univ) : ~ LevelSet.Empty (levels u). +Lemma univ_non_empty (u : premises) : ~ LevelSet.Empty (levels u). Proof. intros he. have := t_ne u. move/not_Empty_is_empty. intros he'. apply he'. intros [l k] hin. red in he. specialize (he l). apply he. rewrite levelexprset_levels_spec. now exists k. Qed. (* -Lemma loop_max cls (u : univ) : +Lemma loop_max cls (u : premises) : cls ⊢a of_level_set (levels u) (premise_max u) (univ_non_empty u) → u. Proof. intros [l k] hin. @@ -5254,11 +3645,11 @@ Definition max_opt_of {A} (max : A -> A -> A) (x : option A) (y : option A) : op | _, _ => y end. -Definition max_premise_of l (u : univ) : option Z := +Definition max_premise_of l (u : premises) : option Z := LevelExprSet.fold (fun '(l', k) acc => if eqb l l' then max_opt_of Z.max (Some k) acc else acc) u None. -Lemma max_premise_of_spec l k (u : univ) : LevelExprSet.In (l, k) u -> Some k ≤ max_premise_of l u. +Lemma max_premise_of_spec l k (u : premises) : LevelExprSet.In (l, k) u -> Some k ≤ max_premise_of l u. Proof. rewrite /max_premise_of. eapply LevelExprSetProp.fold_rec. @@ -5372,7 +3763,7 @@ Definition valuation_of_result {V cls} (m : infer_result V cls) := Definition to_string_expr (e : LevelExpr.t) : string := let '(l, n) := e in Level.to_string l ^ (if n is Z0 then "" else "+" ^ string_of_Z n). -Definition print_premise (l : nonEmptyLevelExprSet) : string := +Definition print_premise (l : premises) : string := let (e, exprs) := NonEmptySetFacts.to_nonempty_list l in to_string_expr e ^ match exprs with @@ -5552,7 +3943,7 @@ Proof. rewrite heq in hp. depelim hp. now exists y. Qed. -Lemma interp_prems_ge v (prems : nonEmptyLevelExprSet) : +Lemma interp_prems_ge v (prems : premises) : forall prem, LevelExprSet.In prem prems -> interp_expr v prem <= interp_prems v prems. Proof. @@ -5823,7 +4214,7 @@ Proof. rewrite (IHl a). congruence. lia. Qed. -Lemma interp_prems_add V le (u : univ) : +Lemma interp_prems_add V le (u : premises) : interp_prems V (add le u) = Z.max (interp_expr V le) (interp_prems V u). Proof. rewrite 2!interp_prems_elements. @@ -5835,13 +4226,13 @@ Proof. destruct to_nonempty_list. rewrite -he //=. Qed. -Lemma interp_prems_eq (P : univ -> Z -> Prop) V : +Lemma interp_prems_eq (P : premises -> Z -> Prop) V : (forall le, P (singleton le) (interp_expr V le)) -> (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (add le u) (Z.max (interp_expr V le) k)) -> forall u, P u (interp_prems V u). Proof. intros hs hadd. - eapply nonEmptyLevelExprSet_elim. + eapply premises_elim. - intros le. rewrite interp_prems_singleton. apply hs. - intros le prems ih hnin. rewrite interp_prems_add. now apply hadd. @@ -5888,7 +4279,7 @@ Proof. cbn. lia. Qed. -Lemma interp_prems_in {V le} {u : univ} : LevelExprSet.In le u -> interp_prems V u >= interp_expr V le. +Lemma interp_prems_in {V le} {u : premises} : LevelExprSet.In le u -> interp_prems V u >= interp_expr V le. Proof. revert u. refine (interp_prems_eq (fun u z => LevelExprSet.In le u -> z >= interp_expr V le) V _ _). @@ -5898,12 +4289,12 @@ Proof. specialize (hz hin). lia. Qed. -Lemma clauses_sem_subset {u u' : univ} : u ⊂_leset u' -> +Lemma clauses_sem_subset {u u' : premises} : u ⊂_leset u' -> forall V, interp_prems V u' >= interp_prems V u. Proof. intros hsub V. revert u u' hsub. - refine (interp_prems_eq (fun u z => forall u' : univ, u ⊂_leset u' -> interp_prems V u' >= z) V _ _). + refine (interp_prems_eq (fun u z => forall u' : premises, u ⊂_leset u' -> interp_prems V u' >= z) V _ _). - intros le u' hsing. specialize (hsing le). forward hsing by now apply LevelExprSet.singleton_spec. now apply interp_prems_in. @@ -6262,7 +4653,7 @@ Proof. exists k. now eapply LevelExprSet.singleton_spec. Qed. -Lemma max_premise_of_spec2 l k (u : univ) : LevelExprSet.In (l, k) u -> +Lemma max_premise_of_spec2 l k (u : premises) : LevelExprSet.In (l, k) u -> exists k', LevelExprSet.In (l, k') u /\ max_premise_of l u = Some k'. Proof. remember (max_premise_of l u) as mp. symmetry in Heqmp. @@ -6271,7 +4662,7 @@ Proof. destruct H as [nein ->]. elim nein. now exists k. Qed. -Lemma max_premise_of_spec_in l (u : univ) : LevelSet.In l (levels u) -> +Lemma max_premise_of_spec_in l (u : premises) : LevelSet.In l (levels u) -> exists k, max_premise_of l u = Some k /\ LevelExprSet.In (l, k) u. Proof. intros hexi. @@ -6382,7 +4773,7 @@ Proof. Qed. Variant check_result {cls} := - | IsLooping (v : univ) (islooping : loop_on_univ cls v) + | IsLooping (v : premises) (islooping : loop_on_univ cls v) | Invalid | Valid. Arguments check_result : clear implicits. @@ -6467,7 +4858,7 @@ Qed. Definition invalid_entailment cls cl := forall V, clauses_sem V cls -> clause_sem V cl -> False. -Definition infers_univ (m : model) (u : univ) := +Definition infers_univ (m : model) (u : premises) := exists z, min_premise m u = Some z /\ (0 <= z)%Z. Definition infers_expr (m : model) (le : LevelExpr.t) := @@ -6561,7 +4952,7 @@ Qed. Local Notation fn := (fold_left (option_map2 Z.min)). Lemma fold_left_impl n l : - (forall x, In x (n :: l) -> fn l n ≤Z x) /\ + (forall x, In x (n :: l) -> fn l n ≤ x) /\ (exists x, In x (n :: l) /\ fn l n = x). Proof. induction l in n |- *. @@ -6651,19 +5042,19 @@ Proof. now rewrite option_map2_comm. Qed. -Lemma min_premise_elim m (P : univ -> option Z -> Prop): +Lemma min_premise_elim m (P : premises -> option Z -> Prop): (forall le, P (singleton le) (min_atom_value m le)) -> (forall prems acc le, P prems acc -> ~ LevelExprSet.In le prems -> P (add le prems) (option_map2 Z.min (min_atom_value m le) acc)) -> forall prems, P prems (min_premise m prems). Proof. intros hs hadd. - eapply nonEmptyLevelExprSet_elim. + eapply premises_elim. - intros le. rewrite /min_premise. rewrite singleton_to_nonempty_list. cbn. apply hs. - intros le prems hp. now rewrite min_premise_add. Qed. -Lemma min_premise_add_down {m} {prems : univ} {l k} : +Lemma min_premise_add_down {m} {prems : premises} {l k} : LevelExprSet.In (l, k + 1) prems -> forall z, min_premise m prems = Some z -> min_premise m (add (l, k) prems) = Some z. @@ -6914,7 +5305,7 @@ add_max l k m with level_value m l := | false => LevelMap.add l k m } | None => LevelMap.add l k m }. -Lemma nleq k k' : ~ k ≤Z Some k' -> exists z, k = Some z /\ k' < z. +Lemma nleq k k' : ~ k ≤ Some k' -> exists z, k = Some z /\ k' < z. Proof. destruct k. - exists z. split => //. eapply Znot_ge_lt => hl; apply H. constructor. lia. @@ -7368,7 +5759,7 @@ Module CorrectModel. (hincl : only_model_of V init) (hs : clauses_levels cls ⊂_lset V) (cls' : clauses) - (hs' : clauses_levels cls' ⊂_lset V) : (t V (Clauses.union cls cls')) + univ := + (hs' : clauses_levels cls' ⊂_lset V) : (t V (Clauses.union cls cls')) + premises := infer_extension_correct m hincl hs cls' hs' with infer_extension m hincl hs cls' := | Loop u _ => inr u | Model w m' _ => @@ -7392,7 +5783,7 @@ Module CorrectModel. - apply m'. Qed. - Equations? infer_extension_valid {V cls} (m : t V cls) cls' : option (t V (Clauses.union cls cls') + univ) := + Equations? infer_extension_valid {V cls} (m : t V cls) cls' : option (t V (Clauses.union cls cls') + premises) := infer_extension_valid m cls' with inspect (LevelSet.subset (clauses_levels cls') V) := | exist false heq => None | exist true heq := Some (infer_extension_correct (model_valid m) _ _ cls' _). @@ -7460,7 +5851,7 @@ Module Abstract. * apply (todo "cannot activate more clauses"). Qed. - Equations enforce_clauses (m : t) (cls : Clauses.t) : option (t + univ) := + Equations enforce_clauses (m : t) (cls : Clauses.t) : option (t + premises) := enforce_clauses m cls with infer_extension_valid m.(model) cls := | None => None | Some (inl m') => Some (inl {| model := m' |}) @@ -7471,12 +5862,11 @@ End LoopCheckingImpl. Module LoopChecking (LS : LevelSets). Module Impl := LoopCheckingImpl(LS). - Import Impl.Clauses. - Import Impl.Clauses.FLS. + Import Impl.Model. Definition model := Impl.Abstract.t. - Notation univ := LevelExprSet.nonEmptyLevelExprSet. + Notation univ := LS.LevelExprSet.nonEmptyLevelExprSet. Inductive constraint_type := UnivEq | UnivLe. Notation constraint := (univ * constraint_type * univ). From 9e90ea317e588c93093f5270a6ca3c648ae7e143 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 10 Sep 2025 22:30:46 +0200 Subject: [PATCH 039/164] Split into 7 files. Deciders remains to sort out. --- common/_RocqProject.in | 3 +- common/theories/LoopChecking/Common.v | 31 +- common/theories/LoopChecking/Deciders.v | 2027 +++++++ common/theories/LoopChecking/HornClauses.v | 924 ++- common/theories/LoopChecking/Interfaces.v | 104 + common/theories/LoopChecking/Model.v | 1573 ++++- .../LoopChecking/PartialLoopChecking.v | 5072 +---------------- 7 files changed, 4592 insertions(+), 5142 deletions(-) create mode 100644 common/theories/LoopChecking/Deciders.v diff --git a/common/_RocqProject.in b/common/_RocqProject.in index f93ce15db..05ae0e787 100644 --- a/common/_RocqProject.in +++ b/common/_RocqProject.in @@ -19,4 +19,5 @@ theories/LoopChecking/Common.v theories/LoopChecking/Interfaces.v theories/LoopChecking/HornClauses.v theories/LoopChecking/Model.v -theories/LoopChecking/PartialLoopChecking.v \ No newline at end of file +theories/LoopChecking/PartialLoopChecking.v +theories/LoopChecking/Deciders.v \ No newline at end of file diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v index 0ef9c129f..0232fd684 100644 --- a/common/theories/LoopChecking/Common.v +++ b/common/theories/LoopChecking/Common.v @@ -141,7 +141,6 @@ Proof. * intros acc1 acc' x hin. apply (H2 acc1 acc' x). now right. * exists min. split => //. Qed. -Close Scope nat_scope. Notation min_opt := (option_map2 Z.min). @@ -155,6 +154,36 @@ Proof. intros [] H'; depelim H'; constructor. lia. Qed. +Lemma opt_le_lt_trans {x y z} : opt_le Z.le x y -> opt_le Z.lt y z -> opt_le Z.lt x z. +Proof. + destruct 1; intros H'; depelim H'; constructor. lia. +Qed. + + +Definition max_opt_of {A} (max : A -> A -> A) (x : option A) (y : option A) : option A := + match x, y with + | Some x, Some y => Some (max x y) + | Some x, None => Some x + | _, _ => y + end. + +Lemma max_opt_of_l {A} {f : A -> A -> A} l : max_opt_of f l None = l. +Proof. + destruct l => //. +Qed. + +Lemma max_opt_of_r {A} {f : A -> A -> A} l : max_opt_of f None l = l. +Proof. + destruct l => //. +Qed. + +Lemma pair_inj {A B} (x x' : A) (y y' : B) P : + (x = x' -> y = y' -> P) -> + ((x, y) = (x', y') -> P). +Proof. + now intros h [=]. +Qed. + Lemma Zmin_opt_left x y : min_opt x y ≤ x. Proof. destruct x as [x|], y as [y|]; constructor. lia. diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v new file mode 100644 index 000000000..a17b0319e --- /dev/null +++ b/common/theories/LoopChecking/Deciders.v @@ -0,0 +1,2027 @@ +(* Distributed under the terms of the MIT license. *) +From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils. + +From MetaRocq.Common Require Universes. +From Equations Require Import Equations. + +From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model PartialLoopChecking. + +Set Equations Transparent. + +Module Type LoopCheckingItf (LS : LevelSets). + + (* Type of consistent models of a set of universe constraints *) + Parameter model : Type. + Notation univ := LS.LevelExprSet.nonEmptyLevelExprSet. + + Inductive constraint_type := UnivEq | UnivLe. + Notation constraint := (univ * constraint_type * univ). + + Parameter init_model : model. + + (* Returns None if already declared *) + Parameter declare_level : LS.Level.t -> model -> option model. + + (* If the constraints mention undeclared universes, returns None, + otherwise, returns either a model or a looping universe, i.e. such that u >= u + 1 is implied + by the constraint *) + Parameter enforce : constraint -> model -> option (model + univ). + + (* Returns true is the clause is valid in the model and all its possible consistent extensions. + Returns false if the constraint results in an inconsistent set of constraints or it simply + is not valid. *) + Parameter check : model -> constraint -> bool. + + (* Returns the valuation of the model: a minimal assignement from levels to constraints + that make the enforced clauses valid. *) + Parameter valuation : model -> LS.LevelMap.t nat. +End LoopCheckingItf. + +Module Deciders (LS : LevelSets). + +Module Import I := LoopCheckingImpl LS. +Import LS. + +Local Open Scope Z_scope. + +Definition init_model cls := max_clause_premises cls. + +Lemma init_model_levels cls k : + LevelMap.In k (init_model cls) <-> LevelSet.In k (clauses_levels cls). +Proof. + split. + - now move => [] k' /max_clause_premises_spec. + - move/max_clause_premises_spec_inv. now eexists. +Qed. + +Definition init_w (levels : LevelSet.t) : LevelSet.t := LevelSet.empty. + +(* We don't need predecessor clauses as they are trivially satisfied *) +(* Definition add_predecessors (V : LevelSet.t) cls := + LevelSet.fold (fun l acc => + Clauses.add (NonEmptySetFacts.singleton (l, 1), (l, 0)) acc) V cls. *) + +Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). + +Equations? infer (cls : clauses) : infer_result (clauses_levels cls) cls := + infer cls := loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (init_model cls) (And3 _ _ _). +Proof. + - now rewrite -init_model_levels. + - apply is_update_of_empty. +Qed. + +Local Open Scope string_scope2. + +Definition print_level_Z_map (m : LevelMap.t (option Z)) := + let list := LevelMap.elements m in + print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_option string_of_Z w) nl list. + +Definition print_result {V cls} (m : infer_result V cls) := + match m return string with + | Loop _ _ => "looping on " + | Model w m _ => "satisfiable with model: " ^ print_level_Z_map m.(model_model) ^ nl ^ " W = " ^ + print_lset w + ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model m.(model_model)) + end. + +Definition valuation_of_result {V cls} (m : infer_result V cls) := + match m with + | Loop _ _ => "looping" + | Model w m _ => print_level_nat_map (valuation_of_model m.(model_model)) + end. + +Definition to_string_expr (e : LevelExpr.t) : string := + let '(l, n) := e in Level.to_string l ^ (if n is Z0 then "" else "+" ^ string_of_Z n). + +Definition print_premise (l : premises) : string := + let (e, exprs) := NonEmptySetFacts.to_nonempty_list l in + to_string_expr e ^ + match exprs with + | [] => "" + | _ => ", " ^ print_list to_string_expr ", " exprs + end. + +Definition print_clauses (cls : clauses) := + let list := Clauses.elements cls in + print_list (fun '(l, r) => + print_premise l ^ " → " ^ to_string_expr r) nl list. + +Definition valuation := LevelMap.t nat. + +Equations? infer_model (cls : clauses) : option model := +infer_model cls with loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (init_model cls) _ := + | Loop _ _ => None + | Model w vm heq => Some vm.(model_model). +Proof. + split. + - reflexivity. + - apply infer_obligation_2. + - apply is_update_of_empty. +Qed. + +Definition enabled_clause (m : model) (cl : clause) := + exists z, min_premise m (premise cl) = Some z. + +Definition enabled_clauses (m : model) (cls : clauses) := + Clauses.For_all (enabled_clause m) cls. + +Definition correct_model (cls : clauses) (m : model) := + enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. + +Definition infer_correctness cls := + match infer_model cls with + | Some m => correct_model cls m + | None => ~ exists v, clauses_sem v cls + end. + +Lemma enabled_clauses_ext m m' cls : m ⩽ m' -> enabled_clauses m cls -> enabled_clauses m' cls. +Proof. + intros hext. + rewrite /enabled_clauses. + intros ha cl; move/ha. + unfold enabled_clause. + intros [minp heq]. + have hp := min_premise_pres (premise cl) hext. + rewrite heq in hp. depelim hp. now exists y. +Qed. + +Lemma interp_prems_ge v (prems : premises) : + forall prem, LevelExprSet.In prem prems -> + interp_expr v prem <= interp_prems v prems. +Proof. + intros. + unfold interp_prems. + have he := to_nonempty_list_spec prems. + destruct to_nonempty_list. + pose proof to_nonempty_list_spec'. + rewrite In_elements in H. rewrite -he in H. clear H0 he. clear -H. + destruct H. subst p. + - induction l. cbn. auto. + cbn. lia. cbn. lia. + - induction l in H |- *. + now cbn in H. + cbn in H. destruct H; subst; cbn. + * cbn. lia. + * specialize (IHl H). lia. +Qed. + +(** Enabled and valid clauses are satisfied by valuation *) +Lemma valid_clause_model model cl : + enabled_clause model cl -> + valid_clause model cl -> + clause_sem (valuation_of_model model) cl. +Proof. + unfold enabled_clause, valid_clause. + destruct min_premise eqn:hmin => //= => //. + 2:{ intros [k' eq]. congruence. } + intros [k' eq]. noconf eq. + destruct cl as [prems [concl k]]; cbn. + unfold level_value_above. + destruct level_value eqn:hl => //. + unfold interp_level. unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. + move/Z.leb_le => hrel. + eapply LevelMap.find_2 in hfind. + have conclm := valuation_of_model_spec _ _ _ hfind. + set (v := (model_max _ - _)) in *. + cbn in conclm. + eapply LevelMap.find_1 in conclm. rewrite conclm. + subst v. + pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. + rewrite hmin in premeq. + eapply Z.le_ge. + eapply Z.le_trans. 2:{ eapply interp_prems_ge; tea. } + unfold interp_expr. destruct prem as [prem k']. + symmetry in premeq. + move: premeq. unfold min_atom_value. + unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. + destruct o => //. + intros [= <-]. + eapply LevelMap.find_2 in findp. + have premm := valuation_of_model_spec _ _ _ findp. + unfold interp_level. + eapply LevelMap.find_1 in premm. rewrite premm. + assert (z1 - k' <= z0 - k). lia. + have hm : z0 <= model_max model. + { eapply model_max_spec in hfind; tea. now depelim hfind. } + have hm' : z1 <= model_max model. + { eapply model_max_spec in findp; tea. now depelim findp. } + have hmi : model_min model <= z0. + { eapply model_min_spec; tea. } + have hmi' : model_min model <= z1. + { eapply model_min_spec; tea. } + assert (0 <= model_max model)%Z by apply model_max_spec2. + assert (model_min model <= 0)%Z by apply model_min_spec2. + lia. +Qed. + +Lemma init_model_enabled cls : enabled_clauses (init_model cls) cls. +Proof. + unfold enabled_clauses. + intros x hin. unfold enabled_clause. + pose proof (@min_premise_spec (init_model cls) (premise x)) as [premmin [prem [premin premeq]]]. + have inV : LevelSet.In prem (clauses_levels cls). + { rewrite clauses_levels_spec. exists x; split => //. rewrite /clause_levels. + eapply LevelSet.union_spec; left. rewrite levelexprset_levels_spec. exists prem.2. + destruct prem. exact premin. } + unfold init_model. rewrite premeq. unfold min_atom_value. + destruct prem as [l k]. + have hm := max_clause_premises_spec_inv cls l inV. + rewrite (level_value_MapsTo hm). + have hs := max_clause_premise_of_spec l k _ _ hin premin. + depelim hs. rewrite H0. + eexists => //. +Qed. + +Lemma interp_add_expr V n e : interp_expr V (add_expr n e) = n + interp_expr V e. +Proof. + destruct e as [l k]; cbn. lia. +Qed. + +Lemma interp_prems_singleton V e : + interp_prems V (singleton e) = interp_expr V e. +Proof. + rewrite /interp_prems. + now rewrite singleton_to_nonempty_list /=. +Qed. + +Lemma fold_right_max_in {a l} n : In a l -> a <= fold_right Z.max n l. +Proof. + induction l. + - now cbn. + - intros [eq|inl]. subst a0. cbn. lia. + cbn. specialize (IHl inl). lia. +Qed. + +Lemma fold_right_max_acc {n l} : n <= fold_right Z.max n l. +Proof. + induction l. + - now cbn. + - cbn. lia. +Qed. + +Lemma fold_right_impl n l l' : + (forall x, In x l -> In x l') -> fold_right Z.max n l <= fold_right Z.max n l'. +Proof. + induction l in l' |- *. + - cbn. destruct l'; cbn. lia. + intros. have := @fold_right_max_acc n l'. lia. + - cbn; intros h. + have inal' := (h a (or_introl eq_refl)). + have := fold_right_max_in n inal'. + specialize (IHl l'). + forward IHl. + intros. apply h. now right. + lia. +Qed. + +Lemma fold_right_equivlist n l l' : + equivlistA eq l l' -> fold_right Z.max n l = fold_right Z.max n l'. +Proof. + intros eq. + have h := fold_right_impl n l l'. + forward h. intros x; rewrite -!InA_In_eq. apply eq. + have h' := fold_right_impl n l' l. + forward h'. intros x; rewrite -!InA_In_eq. apply eq. + lia. +Qed. + +Fixpoint max_list (l : list Z) : option Z := + match l with + | [] => None + | x :: xs => match max_list xs with + | Some m => Some (Z.max x m) + | None => Some x end + end. + +Lemma max_list_fold_right n l : max_list (n :: l) = Some (fold_right Z.max n l). +Proof. + induction l; cbn. + - reflexivity. + - cbn in IHl. destruct max_list. f_equal. noconf IHl. lia. + f_equal; noconf IHl. lia. +Qed. + +Lemma fold_right_max_spec n l : + let fn := fold_right Z.max in + (forall x, In x (n :: l) -> x <= fn n l) /\ + (exists x, In x (n :: l) /\ fn n l = x). +Proof. + induction l; cbn. + - split. intros x [] => //. now subst. + exists n. firstorder. + - cbn in IHl. destruct IHl as [h h']. + split. + intros x [|[]]; subst. + * specialize (h x). forward h by auto. lia. + * lia. + * specialize (h x). forward h by auto. lia. + * destruct h' as [x []]. exists (Z.max a x). rewrite -{4}H0. split => //. + destruct H; subst. + destruct (Z.max_spec a x) as [[]|[]]; firstorder; subst. + destruct (Z.max_spec a (fold_right Z.max n l)) as [[]|[]]; firstorder; subst. rewrite H1. + auto. +Qed. + +Lemma fold_right_equivlist_all n n' l l' : + equivlistA eq (n :: l) (n' :: l') -> fold_right Z.max n l = fold_right Z.max n' l'. +Proof. + intros eq. + have [hla [maxl [inmaxl eqmaxl]]] := fold_right_max_spec n l. + have [hra [maxr [inmaxr eqmaxr]]] := fold_right_max_spec n' l'. + rewrite eqmaxl eqmaxr. + red in eq; setoid_rewrite InA_In_eq in eq. + apply (eq _) in inmaxl. apply hra in inmaxl. + apply eq in inmaxr. apply hla in inmaxr. lia. +Qed. + +Lemma interp_prems_elements V u : + interp_prems V u = fold_right Z.max (interp_expr V (to_nonempty_list u).1) (List.map (interp_expr V) (to_nonempty_list u).2). +Proof. + rewrite /interp_prems. + have he := to_nonempty_list_spec u. + destruct to_nonempty_list. + now rewrite Universes.fold_right_map. +Qed. + +Lemma fold_right_interp {V x l x' l'} : + equivlistA eq (x :: l) (x' :: l') -> + fold_right Z.max (interp_expr V x) (List.map (interp_expr V) l) = fold_right Z.max (interp_expr V x') (List.map (interp_expr V) l'). +Proof. + intros eq. apply fold_right_equivlist_all. + intros a. rewrite !InA_In_eq. + rewrite !(in_map_iff (interp_expr V) (_ :: _)). + setoid_rewrite <-InA_In_eq. + split. + - move=> [b [<- ]]. + eexists; split; trea. now apply eq in b0. + - move=> [b [<- ]]. + eexists; split; trea. now apply eq in b0. +Qed. + +Lemma equivlistA_add le u : let l := to_nonempty_list (add le u) in + equivlistA eq (l.1 :: l.2) (le :: LevelExprSet.elements u). +Proof. + have he := to_nonempty_list_spec (add le u). + destruct to_nonempty_list. cbn. + intros x. rewrite he. + rewrite !LevelExprSet.elements_spec1. + split. + - move/LevelExprSet.add_spec => [->|hin]. + now constructor. constructor 2. now apply LevelExprSet.elements_spec1. + - intros h; depelim h; subst. now apply LevelExprSet.add_spec; left. + apply LevelExprSet.add_spec. now apply LevelExprSet.elements_spec1 in h. +Qed. + +Lemma fold_right_comm acc l : l <> [] -> fold_right Z.max acc l = Z.max acc (fold_right Z.max (List.hd acc l) (List.tl l)). +Proof. + induction l in acc |- *. + - intros; congruence. + - intros _. cbn. destruct l; cbn. lia. + cbn in IHl. rewrite (IHl acc). congruence. + rewrite (IHl a). congruence. lia. +Qed. + +Lemma interp_prems_add V le (u : premises) : + interp_prems V (add le u) = Z.max (interp_expr V le) (interp_prems V u). +Proof. + rewrite 2!interp_prems_elements. + erewrite fold_right_interp. 2:apply equivlistA_add. + rewrite fold_right_comm. + { apply map_nil, elements_not_empty. } + f_equal. eapply fold_right_equivlist_all. + have he := to_nonempty_list_spec u. + destruct to_nonempty_list. rewrite -he //=. +Qed. + +Lemma interp_prems_eq (P : premises -> Z -> Prop) V : + (forall le, P (singleton le) (interp_expr V le)) -> + (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (add le u) (Z.max (interp_expr V le) k)) -> + forall u, P u (interp_prems V u). +Proof. + intros hs hadd. + eapply premises_elim. + - intros le. rewrite interp_prems_singleton. apply hs. + - intros le prems ih hnin. + rewrite interp_prems_add. now apply hadd. +Qed. + +Lemma add_prems_singleton n cl : add_prems n (singleton cl) = singleton (add_expr n cl). +Proof. + apply eq_univ_equal => [] [l k]. + rewrite In_add_prems LevelExprSet.singleton_spec. + firstorder. + - destruct x; noconf H0. + eapply LevelExprSet.singleton_spec in H. + now red in H; noconf H. + - destruct cl. exists (t, z). split => //. + red in H; noconf H. now apply LevelExprSet.singleton_spec. +Qed. + +Lemma interp_add_prems V n e : interp_prems V (add_prems n e) = n + interp_prems V e. +Proof. + revert e. + refine (interp_prems_eq (fun u z => interp_prems V (add_prems n u) = n + z) _ _ _). + - intros le. + rewrite add_prems_singleton interp_prems_singleton //=. + destruct le; cbn. lia. + - intros le u k heq hnin. + rewrite add_prems_add. + rewrite interp_prems_add heq interp_add_expr. lia. +Qed. + +Lemma in_pred_closure_entails cls cl : + in_pred_closure cls cl -> + (forall V, clauses_sem V cls -> clause_sem V cl). +Proof. + induction 1. + - intros V. rewrite /clauses_sem. intros ha. + apply ha in H. + move: H; rewrite /clause_sem. + destruct cl as [prems concl]. + cbn. rewrite interp_add_prems. + destruct concl as [concl conclk]. + rewrite /add_expr; cbn. lia. + - intros V clsm. cbn. + rewrite interp_prems_singleton. + cbn. lia. +Qed. + +Lemma interp_prems_in {V le} {u : premises} : LevelExprSet.In le u -> interp_prems V u >= interp_expr V le. +Proof. + revert u. + refine (interp_prems_eq (fun u z => LevelExprSet.In le u -> z >= interp_expr V le) V _ _). + - intros le' u'. + apply LevelExprSet.singleton_spec in u'. red in u'; subst. lia. + - move=> le' u z hz hnin /LevelExprSet.add_spec [->|hin]. lia. + specialize (hz hin). lia. +Qed. + +Lemma clauses_sem_subset {u u' : premises} : u ⊂_leset u' -> + forall V, interp_prems V u' >= interp_prems V u. +Proof. + intros hsub V. + revert u u' hsub. + refine (interp_prems_eq (fun u z => forall u' : premises, u ⊂_leset u' -> interp_prems V u' >= z) V _ _). + - intros le u' hsing. + specialize (hsing le). forward hsing by now apply LevelExprSet.singleton_spec. + now apply interp_prems_in. + - intros le u k ih hin u' sub. + have hle := sub le. + specialize (ih u'). + forward ih. intros x hin'. apply sub. now apply LevelExprSet.add_spec; right. + forward hle by now apply LevelExprSet.add_spec; left. + have hi := interp_prems_in (V := V) hle. lia. +Qed. + +#[refine] Instance ge_refl : Reflexive Z.ge := _. +Proof. red. lia. Qed. + +#[refine] Instance ge_trans : Transitive Z.ge := _. +Proof. red. lia. Qed. + +Lemma clauses_sem_entails {cls cl} : + entails cls cl -> + (forall V, clauses_sem V cls -> clause_sem V cl). +Proof. + induction 1. + - intros v clls. red. + destruct concl0 as [concl k]. + have hge := interp_prems_ge v prems _ H. + by lia. + - move=> V Hcls. + move: {IHentails} (IHentails _ Hcls). + unfold clause_sem. unfold ge => hyp. + etransitivity; tea. rewrite interp_prems_add. + rewrite interp_prems_add in hyp. + eapply in_pred_closure_entails in H; tea. + move: H; rewrite /clause_sem. unfold ge. + have ssub := clauses_sem_subset H1 V. lia. +Qed. + +Lemma clauses_sem_entails_all {cls prems concl} : + cls ⊢a prems → concl -> + (forall V, clauses_sem V cls -> interp_prems V prems >= interp_prems V concl). +Proof. + intros ha V hcls. + red in ha. + move: ha. + revert concl. + refine (@interp_prems_eq (fun concl z => _ -> interp_prems V prems >= z) V _ _). + - move=> le //=. move/(_ le). + intros h; forward h by now apply LevelExprSet.singleton_spec. + now have ent := (clauses_sem_entails h _ hcls). + - intros le u k ih hnin. + intros hf. + forward ih. intros x hin; apply (hf x). + rewrite LevelExprSet.add_spec; now right. + specialize (hf le). + forward hf by now apply LevelExprSet.add_spec; left. + cbn in hf. + have ent := (clauses_sem_entails hf _ hcls). cbn in ent. + lia. +Qed. + +Lemma infer_correct cls : infer_correctness cls. +Proof. + unfold infer_correctness. + destruct infer_model as [m|] eqn:hi. + - (* Correct *) move: hi. + funelim (infer_model cls) => //. + intros [= <-]. + set (obl := infer_model_obligation_1 cls). clearbody obl. + clear Heq Heqcall. + have mincl := model_incl vm. + destruct vm as [model ofV isupd clsconcl ism]; cbn in *. + set (V := clauses_levels cls) in *. + unfold correct_model. + have encl : enabled_clauses model cls. + { eapply enabled_clauses_ext. apply is_update_of_ext in isupd. exact isupd. + apply init_model_enabled. } + split => //. + unfold clauses_sem. + intros cl hin. + eapply valid_clause_model. now eapply encl in hin. + eapply Clauses.for_all_spec in ism; tc. now specialize (ism _ hin). + - intros [v clssem]. + move: hi. + funelim (infer_model cls) => //. intros _. + red in islooping. + have sem := clauses_sem_entails_all islooping v0. + specialize (sem clssem). + rewrite interp_add_prems in sem. lia. +Qed. + +Definition valid_entailment cls cl := forall V, clauses_sem V cls -> clause_sem V cl. + +Program Definition loop_check cls (cl : clause) : result (premises_model (clauses_levels cls) cl).1 LevelSet.empty cls (premises_model (clauses_levels cls) cl).2 := + let V := clauses_levels cls in + loop (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 (premises_model V cl).2 _. +Next Obligation. + split => //. + - lsets. + - intros l. rewrite LevelSet.union_spec. + rewrite -/(LevelMap.In l (premises_model (clauses_levels cls) cl).2). + rewrite in_premises_model. intuition auto. + - apply is_update_of_empty. +Qed. + +Definition premises_of_level_set (l : LevelSet.t) := + LevelSet.fold (fun l acc => (l, 0) :: acc) l []. + +Definition extendV V (cl : clause) := + let '(prems, concl) := cl in + (add_list (premises_of_level_set V) prems, concl). + +Lemma premises_model_map_min_premise {levels cls prems z} : + min_premise (premises_model_map (zero_model levels) cls) prems = Some z -> + (exists minp mink, LevelExprSet.In (minp, mink) prems /\ + exists maxp, max_clause_premise_of minp cls = Some maxp /\ + z = maxp - mink) \/ + (exists minp mink, LevelExprSet.In (minp, mink) prems /\ z + mink <= 0)%Z. +Proof. + set (m := premises_model_map _ _). + have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m prems. + rewrite mineq. rewrite /min_atom_value. + destruct level_value eqn:hl => //. intros [= <-]. + eapply level_value_MapsTo' in hl. + eapply premises_model_map_spec in hl as [[inpcls [hm _]]|[ninpcls h']]. left. + 2:{ apply zero_model_spec in h' as [h' [= ->]]. } + exists minp, mink. split => //. noconf hm. rewrite -hm. + eexists; split => //. +Qed. + +Lemma premises_model_map_min_premise_inv {levels cls} : + forall cl, Clauses.In cl cls -> + exists z, min_premise (premises_model_map (zero_model levels) cls) (premise cl) = Some z /\ (0 <= z)%Z. +Proof. + set (m := premises_model_map _ _). + move=> cl hin. + have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m (premise cl). + rewrite mineq. rewrite /min_atom_value. + destruct level_value eqn:hl => //. + - eexists. split; trea. + have ps := proj1 (premises_model_map_spec _ cls minp (Some z)) (level_value_MapsTo' hl). + destruct ps as [[minpsl [eq _]]|]. + * symmetry in eq. + have sp := (max_clause_premise_of_spec _ _ _ _ hin inminp). + depelim sp. rewrite eq in H0. noconf H0. lia. + * destruct H. elim H. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. + - unfold level_value in hl. + destruct LevelMap.find eqn:hl'. subst o. + 2:{ move/LevelMapFact.F.not_find_in_iff: hl'. elim. + rewrite premises_model_map_in. left. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. } + eapply LevelMap.find_2 in hl'. + move/premises_model_map_spec: hl' => [[]|[nin hm]] => //. + * now intros hnminp [_ hn]. + * move: nin; elim. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. +Qed. + +Lemma is_update_of_entails {cls V m m' hne hne'} : is_update_of cls V m m' -> + cls ⊢a of_level_map m hne → of_level_map m' hne'. +Proof. + rewrite /is_update_of. + destruct LevelSet.is_empty. + - intros heq []. + rewrite !of_level_map_spec. rewrite -heq. + constructor. now apply of_level_map_spec. + - eapply strictly_updates_entails. +Qed. + +Lemma is_update_of_non_empty {cls V m m'} : ~ LevelMap.Empty m -> + is_update_of cls V m m' -> + ~ LevelMap.Empty m'. +Proof. + rewrite /is_update_of. destruct LevelSet.is_empty. + - now intros he <-. + - intros he su. now eapply strictly_updates_non_empty_map in su. +Qed. + +Instance defined_map_proper : Proper (LevelMap.Equal ==> iff) defined_map. +Proof. + intros x y eq; rewrite /defined_map. + now setoid_rewrite eq. +Qed. + +Lemma is_update_of_defined_map {cls V m m'} : defined_map m -> + is_update_of cls V m m' -> + defined_map m'. +Proof. + rewrite /is_update_of. destruct LevelSet.is_empty. + - now intros he <-. + - intros he su. now eapply strictly_updates_defined_map in su. +Qed. + +Lemma inj_add_prems_sub {n u u'} : add_prems n u ⊂_leset add_prems n u' -> u ⊂_leset u'. +Proof. + rewrite /add_prems. + intros hm [l k]. specialize (hm (l, k + n)). + rewrite !map_spec in hm. + intros hin. + forward hm. exists (l, k); split => //. + destruct hm as [[] [hin' eq]]. + apply (@add_expr_inj n (l, k)) in eq. now noconf eq. +Qed. + +Lemma premises_of_level_set_spec l k V : LevelSet.In l V /\ k = 0 <-> In (l, k) (premises_of_level_set V). +Proof. + rewrite /premises_of_level_set. + eapply LevelSetProp.fold_rec. + - intros s' he. firstorder. + - intros x a s' s'' hin hnin hadd ih. + red in hadd. rewrite {}hadd. + cbn. firstorder. subst. now left. noconf H1. now left. now noconf H1. +Qed. + +Lemma in_succ_add_premises {V u x k} : LevelExprSet.In (x, Z.of_nat (k + 1)) (add_list (premises_of_level_set V) u) -> LevelExprSet.In (x, Z.of_nat (k + 1)) u. +Proof. + rewrite add_list_spec. intros [hn|hn] => //. + eapply premises_of_level_set_spec in hn as []. lia. +Qed. + +(* Lemma inj_succ_prems {V u u'} : succ_prems u ⊂_leset add_list (premises_of_level_set V) u' -> succ_prems u ⊂_leset u'. +Proof. + intros sub x. rewrite In_add_prems => [] [[l k] [hin ->]]. + specialize (sub (l, Z.of_nat (k + 1))). + forward sub. + apply In_add_prems. exists (l, k). split => //. + now apply in_succ_add_premises in sub. +Qed. *) + +Lemma succ_clauses_equiv cls prems concl : + succ_clauses cls ⊢ succ_prems prems → succ_expr concl -> + cls ⊢ prems → concl. +Proof. + intros ha; depind ha. + - constructor. + move: H. + rewrite In_add_prems => [] [le [hin heq]]. + move/add_expr_inj: heq. now intros ->. + - depelim H. + + destruct cl as [prems concl]. noconf H0. + eapply in_add_clauses in H as [[prems' concl'] [hin heq]]. + noconf heq. + eapply (clause_cut _ (add_prems n prems') (add_expr n concl')). 2:eapply IHha. + 2:{ f_equal. rewrite !add_expr_add_expr. now rewrite add_prems_add add_expr_add_expr Z.add_comm. } + exact: (incls cls (prems', concl') n hin). + rewrite add_prems_add_prems in H1. rewrite Z.add_comm in H1. + rewrite -(add_prems_add_prems 1 n prems') in H1. + now move/inj_add_prems_sub: H1. + + specialize (H0 (x, k + 1)). forward H0. now apply LevelExprSet.singleton_spec. + eapply In_add_prems in H0 as [[l' k'] [hin heq]]. noconf heq. + have eq: k' = k by lia. subst k'. clear H. + eapply clause_cut. 2:eapply IHha. eapply (predcl _ x (k - 1)). + 2:{ intros x'. move/LevelExprSet.singleton_spec => ->. now have -> : k - 1 + 1 = k by lia. } + f_equal. rewrite add_prems_add. f_equal. + rewrite /succ_expr //=. lia_f_equal. +Qed. + +Lemma entails_weak_list {cls prem concl concl'} : + cls ⊢ prem → concl -> + cls ⊢ add_list concl' prem → concl. +Proof. + intros hcl. + induction concl' in prem, hcl |- *. + - exact hcl. + - cbn. eapply IHconcl'. now eapply entails_weak. +Qed. + +Lemma entails_all_weak_list {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (add_list concl' prem) concl. +Proof. + intros hcl x hin. + specialize (hcl _ hin). cbn in hcl. + now eapply entails_weak_list. +Qed. + +Lemma premises_of_level_set_empty : premises_of_level_set LevelSet.empty = []. +Proof. + now rewrite /premises_of_level_set LevelSetProp.fold_empty. +Qed. + +(* Lemma succ_clauses_equiv_weak cls prems concl : + succ_clauses cls ⊢ succ_prems prems → succ_expr concl -> + cls ⊢ prems → concl. +Proof. + move/(entails_weak_list (concl' := [])) => he. + eapply (succ_clauses_equiv _ LevelSet.empty). + cbn. now rewrite premises_of_level_set_empty. +Qed. *) + +Lemma entails_all_succ_clauses cls prems concl : + succ_clauses cls ⊢a succ_prems prems → succ_prems concl -> + cls ⊢a prems → concl. +Proof. + intros ha l hin. specialize (ha (succ_expr l)). forward ha. + eapply In_add_prems. exists l. split => //. cbn in ha. + now eapply succ_clauses_equiv in ha. +Qed. + +Definition entails_equiv cls u u' := + cls ⊢a u → u' /\ cls ⊢a u' → u. + +Notation "cls '⊢a' u ↔ u'" := (entails_equiv cls u u') (at level 90). + +Lemma max_premise_of_spec_aux s l k : + max_premise_of l s = k -> + (forall k', LevelExprSet.In (l, k') s -> (Some k' ≤ k)) /\ + ((exists k', LevelExprSet.In (l, k') s /\ k = Some k') \/ + ((~ exists k', LevelExprSet.In (l, k') s) /\ k = None)). +Proof. + unfold max_premise_of. + revert k. + eapply LevelExprSetProp.fold_rec. + - intros s' he k <-. cbn. split => //. + * now move=> k' /he. + * right; split => //. now move=> [] k' /he. + - intros [l' k'] a s' s'' hin hnin hadd ih k. + specialize (ih _ eq_refl) as [hle hex]. + intros hmax. + split. move=> k'0 /hadd => [] []. + { move=> [=] eq eq'. subst l' k'. rewrite eqb_refl in hmax. + destruct a; cbn in hmax; subst; constructor; lia. } + { move/hle. move: hmax. destruct (eqb_spec l l'); subst. + intros <-. intros h; depelim h; cbn. constructor; lia. + intros -> h; depelim h; constructor; lia. } + destruct hex as [[k'' [hin' heq]]|nex]. subst a. + { left. destruct (eqb_spec l l'). subst. exists (Z.max k' k''); split; trea. + 2:{ subst k. eexists; split => //. apply hadd. now right. } + eapply hadd. + destruct (Z.max_spec k' k'') as [[hlt ->]|[hle' ->]] => //. now right. now left. } + destruct nex as [nex ->]. + destruct (eqb_spec l l'). subst. left. exists k'. split => //. apply hadd; now left. + subst k. right. split => //. + intros [k'' hin']. apply hadd in hin' as []. noconf H0. congruence. + apply nex. now exists k''. +Qed. + +Lemma max_premise_of_prems_max {l prems k} : + max_premise_of l prems = Some k -> LevelExprSet.In (l, k) prems. +Proof. + destruct max_premise_of eqn:maxp => //. intros [= ->]. + apply max_premise_of_spec_aux in maxp as [hle hex]. + destruct hex as [[k' [hin [= ->]]]|hne] => //. + destruct hne; congruence. +Qed. + +Lemma max_premise_of_singleton l k : max_premise_of l (singleton (l, k)) = Some k. +Proof. + remember (max_premise_of l (singleton (l, k))) as mp. symmetry in Heqmp. + apply max_premise_of_spec_aux in Heqmp as [hle hex]. + destruct hex as [[k' [hin heq]]|hne] => //. + eapply LevelExprSet.singleton_spec in hin. now noconf hin. + destruct hne as [nein ->]. elim nein. + exists k. now eapply LevelExprSet.singleton_spec. +Qed. + +Lemma max_premise_of_spec2 l k (u : premises) : LevelExprSet.In (l, k) u -> + exists k', LevelExprSet.In (l, k') u /\ max_premise_of l u = Some k'. +Proof. + remember (max_premise_of l u) as mp. symmetry in Heqmp. + apply max_premise_of_spec_aux in Heqmp as [hle hex]. + intros hin. destruct hex. firstorder. + destruct H as [nein ->]. elim nein. now exists k. +Qed. + +Lemma max_premise_of_spec_in l (u : premises) : LevelSet.In l (levels u) -> + exists k, max_premise_of l u = Some k /\ LevelExprSet.In (l, k) u. +Proof. + intros hexi. + remember (max_premise_of l u) as mp. symmetry in Heqmp. + apply max_premise_of_spec_aux in Heqmp as [hle hex]. + destruct hex. destruct H as [l' [hin heq]]. subst mp. + - eexists; split => //. + - destruct H as [nein ->]. elim nein. + now eapply levelexprset_levels_spec in hexi. +Qed. + +(* Lemma of_level_map_premises_model_map cls cl V ne : + (forall l, LevelSet.In l (clause_levels cl) -> LevelSet.In l V) -> + cls ⊢a add_list (premises_of_level_set V) (premise cl) → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. +Proof. + intros hin [l k]. + rewrite of_level_map_spec. move/premises_model_map_spec; cbn. + rewrite max_opt_of_l. + cbn; rewrite LevelSet.union_spec. firstorder try lsets. + cbn in H1. + - rewrite Z.max_comm. + destruct (Z.max_spec 0 (max_premise_of l (premise cl))) as [[hle ->]|[hge ->]]. + * constructor. rewrite add_list_spec; right. + now eapply max_premise_of_spec_in. + * constructor. rewrite add_list_spec. left. + apply premises_of_level_set_spec. split => //. + apply hin. apply clause_levels_spec. now left. + - eapply zero_model_spec in H1 as [hin' [= ->]]. +Qed. *) + +(* Lemma max_premise_of_pos l prems : max_premise_of l prems >= 0. +Proof. + have hs := max_premise_of_spec_aux prems l. + destruct max_premise_of. lia. lia. + specialize (hs _ eq_refl) as [_ [[k' []]|[_ hne]]]; lia. +Qed. + *) + +Lemma of_level_map_premises_model_map cls cl V ne : + cls ⊢a premise cl → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. +Proof. + intros [l k]. + rewrite of_level_map_spec. move/premises_model_map_spec; cbn. + intros [[hin' [[= heq] _]]|[hnin hm]]. + 2:{ now apply zero_model_spec in hm as []. } + move: hin'; cbn; rewrite LevelSet.union_spec. intros []; [|lsets]. + eapply max_premise_of_spec_in in H as [maxp' [eq hin']]. + rewrite eq in heq; noconf heq. + now constructor. +Qed. + +Lemma entails_all_satisfies {cls prems m hne l k} : + cls ⊢a prems → of_level_map m hne -> + infers_atom m l k -> + cls ⊢ prems → (l, k). +Proof. + intros hl hi. + eapply entails_all_one; tea. now apply infers_atom_of_level_map. +Qed. + +Lemma premises_model_map_ne V cls : + ~ LevelMap.Empty V -> + ~ LevelMap.Empty (premises_model_map V cls). +Proof. + intros ne he. apply ne. + have ne' := premises_model_map_in V cls. + intros l k hin. + specialize (ne' l). destruct ne'. forward H0. right. now exists k. + destruct H0 as [k' hin']. + now move/he: hin'. +Qed. + +Lemma clauses_ne_exist cls : ~ Clauses.Empty cls -> exists cl, Clauses.In cl cls. +Proof. + intros ne. + destruct (Clauses.choose cls) eqn:hc. + - exists e. now apply Clauses.choose_spec1 in hc. + - now apply Clauses.choose_spec2 in hc. +Qed. + +Lemma premises_model_map_defined V cls : + ~ Clauses.Empty cls -> + defined_map (premises_model_map V cls). +Proof. + move/clauses_ne_exist => [cl hin]. + destruct cl as [prems concl]. + pose proof (to_nonempty_list_spec' prems). + set (l := (to_nonempty_list prems).1) in *. + have hs := max_clause_premise_of_spec l l.2 cls (prems, concl) hin. + forward hs. cbn. eapply LevelExprSet.elements_spec1; rewrite -H. + constructor. destruct l; reflexivity. depelim hs. + exists l, y. apply premises_model_map_spec. left. + split => //. + eapply clauses_premises_levels_spec. eexists; split; tea => //. + rewrite //= levelexprset_levels_spec. exists l.2. + setoid_rewrite <- LevelExprSet.elements_spec1. rewrite -H //=. + constructor. destruct l; reflexivity. +Qed. + +Variant check_result {cls} := + | IsLooping (v : premises) (islooping : loop_on_univ cls v) + | Invalid + | Valid. +Arguments check_result : clear implicits. + +Equations check_atom_value (z : option Z) (l : option Z) : bool := + | Some _, None => false + | Some z, Some v => z <=? v + | None, _ => true. + +Lemma check_atom_value_spec z l : reflectProp (z ≤ l) (check_atom_value z l). +Proof. + funelim (check_atom_value z l). + - destruct (Z.leb_spec z v); constructor. + * now constructor. + * intros h; depelim h. lia. + - constructor. intros h; depelim h. + - constructor. constructor. +Qed. + +Lemma valid_model_find {V W cl cls} : + forall v : valid_model (clause_levels cl ∪ V) W (premises_model_map (zero_model (clause_levels cl ∪ V)) (Clauses.singleton cl)) cls, + ~ LevelMap.find (concl cl).1 (model_model v) = None. +Proof. + intros v hfind. + destruct cl as [prems [concl k]]; cbn in *. + have vmupd := model_of_V v. + set (pm := premises_model_map _ _) in *. + move/LevelMapFact.F.not_find_in_iff: hfind; apply. + apply vmupd. rewrite LevelSet.union_spec; left. + rewrite clause_levels_spec. now right. +Qed. + +Equations check (cls : clauses) (cl : clause) : check_result cls := + check cls cl with loop_check cls cl := + | Loop v isl => IsLooping v isl + | Model W v _ with inspect (LevelMap.find (concl cl).1 v.(model_model)) := { + | exist (Some val) he with check_atom_value (Some (concl cl).2) val := + { | true => Valid + | false => Invalid } + | exist None he with valid_model_find v he := {} + }. + +Definition check_clauses (cls : clauses) (cls' : clauses) : bool := + let check_one cl := + match check cls cl with + | IsLooping v isl => false + | Valid => true + | Invalid => false + end + in + Clauses.for_all check_one cls'. + +(* If a clause checks, then it should be valid in any extension of the model *) +Lemma check_entails {cls cl} : + check cls cl = Valid -> valid_entailment cls cl. +Proof. + destruct cl as [prems [concl k]]. + funelim (check cls _) => // _. + set (V := clause_levels _ ∪ clauses_levels cls) in *. + clear Heqcall H. cbn [concl fst snd] in *. clear Heq0. + unfold valid_entailment, valid_clause, level_value_above. + move/check_atom_value_spec: Heq; intros h; depelim h. rename H into hgt. + intros valuation ext. + have vmupd := model_updates v. + have vmok := model_ok v. + set (pm := premises_model_map _ _) in *. + have nepm : defined_map pm. + { apply premises_model_map_defined. + set (cl := (prems, _)) in *. + move/(_ cl). rewrite Clauses.singleton_spec. congruence. } + have nev : defined_map (model_model v). + by apply (is_update_of_defined_map nepm vmupd). + move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. + set (cl := (prems, (concl0, k))) in V. + have of_lset := of_level_map_premises_model_map cls cl V nepm. + have tr := entails_all_trans of_lset ent. + eapply (entails_all_satisfies (l := concl0) (k := k)) in tr. + 2:{ red. rewrite /level_value he. now constructor. } + eapply clauses_sem_entails in tr ; tea. +Qed. + +Definition invalid_entailment cls cl := + forall V, clauses_sem V cls -> clause_sem V cl -> False. + +Definition infers_univ (m : model) (u : premises) := + exists z, min_premise m u = Some z /\ (0 <= z)%Z. + +Definition infers_expr (m : model) (le : LevelExpr.t) := + let '(l, k) := le in infers_atom m l k. + +Lemma valid_clause_elim {m prems concl k} : valid_clause m (prems, (concl, k)) -> + forall z, min_premise m prems = Some z -> + Some (z + k) ≤ level_value m concl. +Proof. + rewrite /valid_clause => hcl z eqmin. + rewrite eqmin in hcl. cbn in *. + move: hcl. rewrite /level_value_above. destruct level_value eqn:hl => //. + move/Z.leb_le. constructor. lia. +Qed. + +Lemma valid_clause_intro {m prems concl k} : + (forall z, + min_premise m prems = Some z -> + Some (z + k) ≤ level_value m concl) -> + valid_clause m (prems, (concl, k)). +Proof. + rewrite /valid_clause //=. + destruct min_premise => //. + intros hz. + specialize (hz _ eq_refl). depelim hz. + rewrite /level_value_above H0. + apply Z.leb_le. lia. +Qed. + +Lemma infers_expr_min_atom_value m le : infers_expr m le -> exists k, min_atom_value m le = Some k /\ (0 <= k)%Z. +Proof. + destruct le as [l k]; rewrite /infers_expr //=. + rewrite /infers_atom. destruct level_value => // hle; depelim hle. + eexists; split; trea. lia. +Qed. + +Lemma min_premise_add_infers m prems le lev : + level_value m le.1 = Some lev -> + forall z, min_premise m prems = Some z -> + exists z', min_premise m (add le prems) = Some z' /\ + ((z' = lev - le.2 /\ z' <= z) \/ z' = z). +Proof. + intros hlev z hmin. + have [hle [min' [hin hm]]] := min_premise_spec m (add le prems). + have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. + move/LevelExprSet.add_spec: hin => [heq|hin]. + - noconf heq. destruct le as [le k]. + rewrite /min_atom_value hlev in hm. + eexists; split => //; trea. left. + specialize (hle min''). forward hle. + { rewrite LevelExprSet.add_spec. now right. } + rewrite hm -hm' hmin in hle. now depelim hle. + - exists z. split => //. 2:right; reflexivity. rewrite hm -hmin hm'. + move: (hle' _ hin). rewrite hmin. intros h; depelim h. + rewrite H0 in hm. + specialize (hle min''). forward hle. eapply LevelExprSet.add_spec. now right. + rewrite hm in hle. rewrite -hm' hmin in hle. depelim hle. + rewrite H0 -hm' hmin. f_equal. lia. +Qed. + +Lemma fold_left_map {A B C} (f : B -> A -> A) (g : C -> B) l acc : + fold_left (fun acc l => f (g l) acc) l acc = + fold_left (fun acc l => f l acc) (List.map g l) acc. +Proof. + induction l in acc |- *; cbn; auto. +Qed. + +Lemma fold_left_max_acc {n l} : (forall x, In x l -> x = n) -> n = fold_left (option_map2 Z.min) l n. +Proof. + induction l in n |- *. + - now cbn. + - cbn. intros he. transitivity (option_map2 Z.min n a). 2:apply IHl. + specialize (he a). forward he. now left. subst. destruct n => //= //. lia_f_equal. + intros. have h := (he x). forward h by now right. + have h' := (he a). forward h' by now left. subst. + destruct n => //=; lia_f_equal. +Qed. + +Lemma option_map2_comm x y : option_map2 Z.min x y = option_map2 Z.min y x. +Proof. + destruct x, y; cbn; lia_f_equal. +Qed. + +Lemma option_map2_assoc x y z : + option_map2 Z.min x (option_map2 Z.min y z) = + option_map2 Z.min (option_map2 Z.min x y) z. +Proof. + destruct x, y, z; cbn; lia_f_equal. +Qed. + +Local Notation fn := (fold_left (option_map2 Z.min)). + +Lemma fold_left_impl n l : + (forall x, In x (n :: l) -> fn l n ≤ x) /\ + (exists x, In x (n :: l) /\ fn l n = x). +Proof. + induction l in n |- *. + - cbn. split; intros. + destruct H => //. subst. reflexivity. + exists n. split => //. now left. + - cbn. split; intros. + { destruct (IHl n) as [hle [min [hin heq]]]. + rewrite fold_left_comm. + { now intros; rewrite -option_map2_assoc (option_map2_comm x0 y) option_map2_assoc. } + repeat destruct H; subst. + * specialize (hle n). forward hle. now left. + transitivity (fn l n); auto. eapply Zmin_opt_left. + * eapply Zmin_opt_right. + * transitivity (fn l n); auto. apply Zmin_opt_left. + apply hle. now right. } + * specialize (IHl (option_map2 Z.min n a)). + destruct IHl as [hle [min [hin heq]]]. subst min. eexists. split; trea. + destruct hin. + rewrite -H. + destruct n, a; cbn; firstorder. + destruct (Z.min_spec z z0) as [[? heq]|[? heq]]. + rewrite -{1}heq. now left. right; left. f_equal. lia. + now right. +Qed. + +Lemma fold_left_impl_eq n n' l l' : + (forall x, In x (n :: l) <-> In x (n' :: l' )) -> + fn l n = fn l' n'. +Proof. + intros heq. + destruct (fold_left_impl n l) as [hle [minl [hin heq']]]. + destruct (fold_left_impl n' l') as [hle' [minl' [hin' heq'']]]. + rewrite heq' heq''. + specialize (hle minl'). forward hle. now apply heq. + specialize (hle' minl). forward hle'. now apply heq. + rewrite heq'' in hle'. rewrite heq' in hle. depelim hle'. depelim hle. f_equal; lia. + now depelim hle. +Qed. + +Lemma fold_left_comm_f {A} (f : A -> A -> A) n l : + (forall x y, f x y = f y x) -> + fold_left f l n = fold_left (flip f) l n. +Proof. + induction l in n |- *; cbn; auto. + intros hf. rewrite IHl //. + unfold flip. now rewrite hf. +Qed. + +Lemma min_premise_add {m le prems} : min_premise m (add le prems) = + option_map2 Z.min (min_atom_value m le) (min_premise m prems). +Proof. + rewrite {1}/min_premise. + have hs' := to_nonempty_list_spec (add le prems). + destruct to_nonempty_list. + have eqf : (fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (min_atom_value m p)) = + (option_map2 Z.min (min_atom_value m le) (min_premise m prems)). + 2:{ now rewrite eqf. } + rewrite -(to_nonempty_list_spec' (add le prems)) in hs'. noconf hs'. + rewrite fold_left_map. rewrite fold_left_comm_f. intros [] []; cbn; auto. lia_f_equal. unfold flip. + have l := fold_left_impl_eq (min_atom_value m (to_nonempty_list (add le prems)).1) (min_atom_value m le) + (List.map (min_atom_value m) (to_nonempty_list (add le prems)).2) (List.map (min_atom_value m) (LevelExprSet.elements prems)). + rewrite l. + intros x. + { rewrite -!map_cons to_nonempty_list_spec' !in_map_iff. + split. + - move=> [] lk [] <-. + rewrite -InA_In_eq. + move/LevelExprSet.elements_spec1. + rewrite LevelExprSet.add_spec. + intros [->|inp]. + * exists le. split => //. now left. + * exists lk. split => //. right. now apply InA_In_eq, LevelExprSet.elements_spec1. + - intros [x' [<- hin]]. + exists x'. split => //. rewrite -InA_In_eq. + eapply LevelExprSet.elements_spec1. rewrite LevelExprSet.add_spec. + apply InA_In_eq in hin. depelim hin. now left. + eapply LevelExprSet.elements_spec1 in hin. now right. } + rewrite option_map2_comm. + rewrite /min_premise. + destruct (to_nonempty_list prems) eqn:he. + rewrite fold_left_map. + rewrite (fold_left_comm_f _ _ (List.map _ l0)). intros. apply option_map2_comm. + rewrite -(fold_left_comm (option_map2 Z.min)). + { intros. now rewrite -option_map2_assoc (option_map2_comm x y) option_map2_assoc. } + rewrite -(to_nonempty_list_spec' prems) he; cbn. + now rewrite option_map2_comm. +Qed. + +Lemma min_premise_elim m (P : premises -> option Z -> Prop): + (forall le, P (singleton le) (min_atom_value m le)) -> + (forall prems acc le, P prems acc -> ~ LevelExprSet.In le prems -> P (add le prems) (option_map2 Z.min (min_atom_value m le) acc)) -> + forall prems, P prems (min_premise m prems). +Proof. + intros hs hadd. + eapply premises_elim. + - intros le. rewrite /min_premise. + rewrite singleton_to_nonempty_list. cbn. apply hs. + - intros le prems hp. now rewrite min_premise_add. +Qed. + +Lemma min_premise_add_down {m} {prems : premises} {l k} : + LevelExprSet.In (l, k + 1) prems -> + forall z, min_premise m prems = Some z -> + min_premise m (add (l, k) prems) = Some z. +Proof. + intros ine z hmin. + have [hle [min' [hin hm]]] := min_premise_spec m (add (l, k) prems). + have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. + move/LevelExprSet.add_spec: hin => [heq|hin]. + - noconf heq. + specialize (hle (l, k + 1)). + forward hle. eapply LevelExprSet.add_spec. now right. + rewrite hm in hle. + depelim hle. destruct level_value eqn:hl. noconf H0; noconf H1. lia. congruence. + destruct level_value eqn:hl' => //. + specialize (hle' _ ine). rewrite hmin in hle'; depelim hle'. + now rewrite hl' in H1. + - rewrite hm. specialize (hle' min' hin). rewrite hmin in hle'. + depelim hle'. rewrite H0. f_equal. rewrite H0 in hm. + specialize (hle min''). forward hle. eapply LevelExprSet.add_spec. now right. + rewrite hm in hle. rewrite -hm' hmin in hle. depelim hle. lia. +Qed. + + +Lemma min_premise_singleton m u : min_premise m (singleton u) = min_atom_value m u. +Proof. + now rewrite /min_premise singleton_to_nonempty_list; cbn. +Qed. + +Lemma min_atom_value_add m e x n : + min_atom_value m e = Some x -> + min_atom_value m (add_expr n e) = Some (x - n)%Z. +Proof. + rewrite /min_atom_value. destruct e. cbn. + destruct level_value => //. intros [= <-]. + f_equal. lia. +Qed. + + +Lemma min_atom_value_add_inv m e x n : + min_atom_value m (add_expr n e) = Some x -> + min_atom_value m e = Some (x + n)%Z. +Proof. + rewrite /min_atom_value. destruct e. cbn. + destruct level_value => //. intros [= <-]. + f_equal. lia. +Qed. + +Lemma min_premise_add_prems {m n prems z} : min_premise m prems = Some z -> min_premise m (add_prems n prems) = Some (z - n)%Z. +Proof. + revert z. + eapply min_premise_elim. + - intros le hm. + destruct le as [concl k]. + rewrite add_prems_singleton min_premise_singleton. + apply min_atom_value_add. + - intros prems' acc le ih nle z hm. + destruct acc; cbn in hm. 2:{ destruct (min_atom_value m le); cbn in hm; congruence. } + specialize (ih _ eq_refl). + rewrite add_prems_add min_premise_add. + destruct (min_atom_value m le) eqn:hm'; cbn in hm => //. noconf hm. + apply (min_atom_value_add _ _ _ n) in hm'. + rewrite ih hm'. cbn. f_equal. lia. +Qed. + +Lemma min_premise_add_prems_inv {m n prems z} : min_premise m (add_prems n prems) = Some z -> + min_premise m prems = Some (z + n)%Z. +Proof. + revert z. + pattern prems. + set (P := (fun n0 hm => + forall z : Z, + min_premise m (add_prems n n0) = Some z -> hm = Some (z + n)%Z)). + apply (@min_premise_elim _ P); subst P; cbn. + - intros le z hm. + destruct le as [concl k]. + rewrite add_prems_singleton min_premise_singleton in hm. + now apply min_atom_value_add_inv. + - intros prems' acc le ih nle z. + rewrite add_prems_add min_premise_add. + destruct (min_premise m (add_prems n prems')) eqn:he => //=. + * destruct (min_atom_value m (add_expr n le)) eqn:ha => //=. + intros [= <-]. + eapply min_atom_value_add_inv in ha. rewrite ha. + specialize (ih _ eq_refl). subst acc. cbn. lia_f_equal. + * destruct (min_atom_value m (add_expr n le)) eqn:ha => //=. +Qed. + +Lemma level_value_above_leq {m l k} : + Some k ≤ level_value m l -> + level_value_above m l k. +Proof. + intros h; rewrite /level_value_above. + depelim h. rewrite H0. apply Z.leb_le. lia. +Qed. + +Lemma valid_clause_shift m n cl : + valid_clause m cl -> valid_clause m (add_clause n cl). +Proof. + destruct cl as [prems [concl k]]. + move/valid_clause_elim => hv. + apply valid_clause_intro => z eqmin. + eapply min_premise_add_prems_inv in eqmin. + specialize (hv _ eqmin). + etransitivity; tea. constructor; lia. +Qed. + +Lemma entails_model_valid cls cl : entails cls cl -> + forall m, is_model cls m -> valid_clause m cl. +Proof. + induction 1. + - intros m ism. + destruct concl0 as [concl k]. + apply valid_clause_intro => z hmin. + eapply min_premise_spec_aux in hmin as [hle [x [hin heq]]]. + specialize (hle _ H). depelim hle. + destruct level_value eqn:hl => //. noconf H1. + constructor. lia. + - intros. + specialize (IHentails m H2). + depelim H. + * destruct cl as [premsc conclc]. + noconf H0. + eapply Clauses.for_all_spec in H3. + eapply H3 in H. 2:tc. + destruct concl0 as [concl k]. + eapply valid_clause_intro => z eqmin. + have mins := min_premise_subset m (add_prems n premsc) prems H2. + rewrite eqmin in mins; depelim mins. + destruct conclc as [conclc k']. + have vshift : valid_clause m (add_prems n premsc, add_expr n (conclc, k')). + { now eapply (valid_clause_shift _ n) in H. } + have hv := valid_clause_elim vshift _ H4. + depelim hv. rename y0 into vmconclc. + eapply (min_premise_add_infers _ _ (add_expr n (conclc, k'))) in eqmin as [minadd [eqminadd disj]]; tea. + move/valid_clause_elim: IHentails => //=. + move/(_ _ eqminadd). + destruct disj as [[eq le']| ->]. + + move=> h. cbn in le'. cbn in eq. subst minadd. + depelim h. rewrite H8. constructor. lia. + + intros h; depelim h. rewrite H8; constructor; lia. + * destruct concl0 as [concl0 k']. + apply valid_clause_intro => z hmin. + have mins := min_premise_subset m _ _ H1. + rewrite min_premise_singleton in mins. + specialize (H1 (x, k+1)); forward H1 by now apply LevelExprSet.singleton_spec. + have hadd := min_premise_add_down H1 _ hmin. + exact: valid_clause_elim IHentails _ hadd. +Qed. + +Lemma check_entails_looping {cls cl v isl} : + check cls cl = IsLooping v isl -> cls ⊢a v → succ_prems v. +Proof. + funelim (check cls cl) => //. +Qed. + +Lemma enabled_clause_ext {m m' cl} : + m ⩽ m' -> enabled_clause m cl -> enabled_clause m' cl. +Proof. + intros hext; rewrite /enabled_clause. + destruct cl as [prems [concl k]]; cbn; move=> [z hm]. + have pr := min_premise_pres prems hext. + rewrite hm in pr. depelim pr. now exists y. +Qed. + +Lemma check_entails_false {cls cl} : + check cls cl = Invalid -> ~ entails cls cl. +Proof. + funelim (check cls cl) => //. + set (V := clause_levels cl ∪ clauses_levels cls) in *. + destruct cl as [prems [concl k]]. + rename val into conclval_v => _. clear H Heq0 Heqcall prf. cbn in he. + move: (check_atom_value_spec (Some k) conclval_v). rewrite Heq. + intros r; depelim r. rename H into nent. intros H. + have vmupd := model_updates v. + have vmok := model_ok v. + set (pm := premises_model_map _ _) in *. + set (cl := (prems, _)) in V. + have nepm : defined_map pm. + { apply premises_model_map_defined. + move/(_ cl). rewrite Clauses.singleton_spec /cl. congruence. } + have nev : defined_map (model_model v). + by apply (is_update_of_defined_map nepm vmupd). + move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. + move/entails_model_valid/(_ _ vmok): H. + have [z minp] : enabled_clause (model_model v) cl. + { apply (@enabled_clause_ext pm). + exact: is_update_of_ext (model_updates v). + red; cbn. + have hcl : Clauses.In cl (Clauses.singleton cl). + { now eapply Clauses.singleton_spec. } + have hs:= @premises_model_map_min_premise_inv V _ _ hcl. firstorder. } + move/valid_clause_elim/(_ z minp). + cbn in minp. + rewrite /level_value he => h; depelim h. apply nent. + constructor. + have posz : 0 <= z. + { have hsu := model_updates v. + eapply is_update_of_ext in hsu. + have hs := min_premise_pres prems hsu. + rewrite minp in hs. + have hmin := @premises_model_map_min_premise_inv V (Clauses.singleton cl) cl. + forward hmin. now apply Clauses.singleton_spec. + destruct hmin as [minp' [hmineq hpos]]. + rewrite hmineq in hs. depelim hs. lia. } + lia. +Qed. + +Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) + (prf : clauses_levels cls ⊂_lset V /\ clauses_levels cls' ⊂_lset V /\ only_model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := + | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m m _. +Proof. + split. + - intros x. rewrite clauses_levels_spec. + move=> [] cl. rewrite Clauses.union_spec. + intros [[] incls]. apply H. apply clauses_levels_spec. exists cl. split => //. + apply H0. apply clauses_levels_spec. exists cl; split => //. + - exact H1. + - eapply is_update_of_empty. +Qed. + + +(* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by + setting a minimal value for the new atoms in [clauses_levels cls \ V] + such that the new clauses [cls] do not hold vacuously. +*) + +Equations add_max (l : Level.t) (k : option Z) (m : model) : model := +add_max l k m with level_value m l := + { | Some k' with check_atom_value k (Some k') := + { | true => m + | false => LevelMap.add l k m } + | None => LevelMap.add l k m }. + +Lemma nleq_optZ k k' : ~ k ≤ Some k' -> exists z, k = Some z /\ k' < z. +Proof. + destruct k. + - exists z. split => //. eapply Znot_ge_lt => hl; apply H. constructor. lia. + - elim. constructor. +Qed. + +Lemma add_max_spec l l' k k' (m : model) : + LevelMap.MapsTo l k (add_max l' k' m) <-> + (l = l' /\ k = max_opt_of Z.max k' (level_value m l)) \/ + (l <> l' /\ LevelMap.MapsTo l k m). +Proof. + funelim (add_max l' k' m). + - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. firstorder; subst. + left. split => //. rewrite Heq. now rewrite max_opt_of_l. + left. firstorder. now rewrite Heq max_opt_of_l. + - clear Heqcall. + destruct (eq_dec l0 l). + * subst l0. rewrite Heq0. + move/check_atom_value_spec: Heq. + rewrite (maps_to_update (level_value_MapsTo' Heq0)). + firstorder; subst; try left; try split; auto; depelim Heq; cbn; lia_f_equal. + * firstorder. + - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. + have := check_atom_value_spec k (Some k'). rewrite {}Heq. + intros h; depelim h. apply nleq_optZ in H as [z [-> hlt]]. + firstorder; subst. + * left; split => //. rewrite Heq0 //=. lia_f_equal. + * left; split => //. rewrite Heq0 //=. lia_f_equal. +Qed. + +Definition min_model_clause cl m := + LevelExprSet.fold (fun '(l, k) acc => add_max l (Some k) acc) (premise cl) + (add_max (concl cl) None m). + +Definition min_model_map (m : model) cls : model := + Clauses.fold min_model_clause cls m. + +Lemma In_add_max l l' k acc : + LevelMap.In l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). +Proof. + rewrite /LevelMap.In. + rw add_max_spec. firstorder subst. + eexists; left; eauto. + destruct (eq_dec l l'); subst; eexists; eauto. +Qed. + +Definition is_max k' k l acc := + match LevelMap.find l acc with + | Some k'' => k' = Nat.max k k'' + | _ => k' = k + end. + +Lemma max_opt_of_spec {x y k'} : max_opt_of Z.max x y = k' -> + (x ≤ y /\ k' = y) \/ (y ≤ x /\ k' = x). +Proof. + destruct x, y; cbn; firstorder subst. + - destruct (Z.max_spec z z0) as [[]|[]]; + [left|right]; split; try constructor; lia_f_equal. + - right. split; constructor. + - left. split; constructor. + - left; split; constructor. +Qed. + +Definition max_of_premises l kl n := + (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ kl). + +Definition is_expr l (e : LevelExpr.t) := + let '(concl, k) := e in concl = l. + +Definition max_of_clause l kl cl := + max_of_premises l kl (premise cl). + +Definition max_of_map l kl m := + (forall kl', LevelMap.MapsTo l kl' m -> kl' ≤ kl). + +Definition is_max_of_clause_and_map l cl m k := + max_of_premises l k (premise cl) /\ max_of_map l k m. + +Definition is_in_premise l k (u : LevelExprSet.t) := + (exists kl, LevelExprSet.In (l, kl) u /\ k = Some kl). + +Definition is_in_clause l k (cl : clause) := + is_in_premise l k (premise cl) \/ (l = (clause_conclusion cl) /\ k = None). + +Definition is_max_of_clause_model l cl m k := + is_max_of_clause_and_map l cl m k /\ + (is_in_clause l k cl \/ LevelMap.MapsTo l k m). + +Definition is_higher l k m := exists k', LevelMap.MapsTo l k' m /\ k ≤ k'. + +Definition is_max_of_clause_map (map : model) l cl (m : model) : Prop := + (forall k, LevelMap.MapsTo l k map -> is_max_of_clause_model l cl m k) + /\ (forall l k, LevelMap.MapsTo l k m \/ is_in_clause l k cl -> is_higher l k map). + + +Lemma max_opt_of_le_l z z' : z ≤ max_opt_of Z.max z z'. +Proof. + destruct z, z'; cbn; constructor; lia. +Qed. + +Lemma max_opt_of_le_r z z' : z' ≤ max_opt_of Z.max z z'. +Proof. + destruct z, z'; cbn; constructor; lia. +Qed. + +Lemma is_higher_le l k l' k' m : is_higher l k m -> is_higher l k (add_max l' k' m). +Proof. + rewrite /is_higher. + rw add_max_spec. + intros [k'0 [hm hle]]. + destruct (eq_dec l l'). + - subst. eexists. split; eauto. rewrite (level_value_MapsTo hm). + transitivity k'0 => //. apply max_opt_of_le_r. + - exists k'0. split; eauto. +Qed. + +Lemma is_higher_add l k m : is_higher l k (add_max l k m). +Proof. + rewrite /is_higher. + rw add_max_spec. eexists. split; eauto. + apply max_opt_of_le_l. +Qed. + +Lemma is_higher_mon l k k' m : is_higher l k' m -> k ≤ k' -> is_higher l k m. +Proof. + intros [? []] le. exists x. split => //. now transitivity k'. +Qed. + +Lemma MapsTo_fold_add_max l n a : + let map := LevelExprSet.fold (fun '(l, k0) acc => add_max l (Some k0) acc) n a in + (forall k, LevelMap.MapsTo l k map -> + ((exists kl, + [/\ LevelExprSet.In (l, kl) n, k = Some kl, + (forall kl', LevelExprSet.In (l, kl') n -> kl' <= kl) & + (forall kl', LevelMap.MapsTo l kl' a -> kl' ≤ Some kl)]) \/ + (LevelMap.MapsTo l k a /\ (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ k)))) + /\ (forall l k, LevelMap.MapsTo l k a \/ is_in_premise l k n -> is_higher l k map) /\ + a ⩽ map. + (* ~ LevelMap.In l map -> ~ (exists k, LevelExprSet.In (l, k) n) /\ ~ (LevelMap.In l a)). *) +Proof. + eapply LevelExprSetProp.fold_rec. + - intros s' he. cbn. + rewrite /is_in_premise /is_higher. + setoid_rewrite (LevelExprSetProp.empty_is_empty_1 he). + intuition auto. right. split; eauto. + intros kl. now move/LevelExprSet.empty_spec. + exists k; split => //. reflexivity. + destruct H0 as [x [hin ->]]. now apply LevelExprSet.empty_spec in hin. + reflexivity. + - cbn; intros. + destruct x as [xl k']. split. + 2:{ split. + { intros l0 hnin. destruct H2 as [hm [H2 _]]. specialize (H2 l0). + intros [ina|ins'']. + { specialize (H2 hnin (or_introl ina)). eapply is_higher_le; tea. } + { destruct ins'' as [x [ins'' ->]]. + apply H1 in ins'' as [[=]|ins']. + * subst. apply is_higher_add. + * apply is_higher_le, H2. right. eexists; eauto. } } + { destruct H2 as [_ [_ H2]]. + intros l' hin. move/H2 => [k'0 [hm hle]]. + rw add_max_spec. destruct (eq_dec l' xl). + - eexists; split. left; eauto. subst l'. + rewrite (level_value_MapsTo hm). transitivity (k'0) => //. + apply max_opt_of_le_r. + - eexists; split; eauto. } } + intros. + rewrite add_max_spec in H3; destruct H3 as [[<- hk]|[hdiff hm]]. + * destruct H2 as [hin hnin]. symmetry in hk. + have [[leacc eqms]|[len eqms]] := max_opt_of_spec hk. + { depelim leacc. specialize (hin _ (level_value_MapsTo' H3)) as [[kl [inkl [= <-] les' lea]]|]. + { left. exists y. split => //. apply H1; now right. congruence. intros. + apply H1 in H4 as [[=]|ins']. 2:now apply les'. subst kl'. lia. } + { destruct H4. right. split. now rewrite -H3 -eqms in H4. intros. + apply H1 in H6 as [[=]|ins']; subst; trea. rewrite H3; cbn; constructor; lia_f_equal. + rewrite H3; cbn; constructor. apply H5 in ins'. depelim ins'. lia. } } + { left. exists k'. split => //. + * apply H1. now left. + * move=> kl' /H1 [[=]|ins']. lia. depelim len. transitivity x; tea. specialize (hin _ (level_value_MapsTo' H3)) as + [[kl [inkl [= <-] les' lea]]|[]]. + { now eapply les'. } + { specialize (H5 _ ins'). depelim H5. lia. } + { move: H2 hk. rewrite /level_value. destruct (find_spec l a0). + * intros ->. apply hin in H2 as [[kl []]|[hm hkl']] => //. apply hkl' in ins'. depelim ins'. + * intros _; cbn; intros <-. + destruct hnin as [hnin _]. + specialize (hnin l (Some kl')); forward hnin. right. + red. exists kl'. split => //. + destruct hnin as [ka [hma hge]]. elim H2. now exists ka. } + * subst k. intros kl' mt. move: len. case: level_valueP => [k ma0 le|]. + specialize (hin _ ma0) as [[kl []]|[hm hkl']] => //. + + subst k. eapply H5 in mt. now depelim le; depelim mt; constructor; lia. + + transitivity k => //. eapply LevelMapFact.F.MapsTo_fun in mt; tea. subst. reflexivity. + + intros hnin' _. destruct hnin as [hnin _]. specialize (hnin l kl'). + forward hnin. now left. destruct hnin as [? [hm ?]]. elim hnin'. now exists x. } + * destruct H2. eapply H2 in hm as [[kl []]|[hm hkl']] => //. + { left. exists kl. split => //. apply H1. now right. intros kl' h. subst k. + apply H6. apply H1 in h. destruct h as [[=]|?] => //. subst. congruence. } + { right. split => //. intros kl' hin. apply H1 in hin as [[=]|?] => //; subst; try congruence. eauto. } +Qed. + +Lemma min_model_clause_spec l cl a : + let map := min_model_clause cl a in + is_max_of_clause_map map l cl a. +Proof. + intros m. rewrite /is_max_of_clause_map /is_max_of_clause_model. + have h := MapsTo_fold_add_max l (premise cl) (add_max (concl cl) None a). + change (LevelExprSet.fold (fun '(l, k0) (acc : model) => add_max l (Some k0) acc) (premise cl) + (add_max (concl cl) None a)) with (min_model_clause cl a) in h. + cbn in h. destruct h. split. + - intros k hm. specialize (H k hm) as [[kl []]|[hm' hle]]. + * split => //. subst k. red. split. intros kl' hin. constructor. now apply H2. + move=> kl' hm''. specialize (H3 kl'). + rewrite add_max_spec in H3. forward H3. + destruct (eq_dec l (concl cl)). + { subst l. left. split => //. rewrite max_opt_of_r. apply level_value_MapsTo in hm''. now rewrite hm''. } + { right. split => //. } + exact H3. left. + red. left. red. subst k. eauto. + * rewrite add_max_spec in hm'. + rewrite max_opt_of_r in hm'. destruct hm' as [[]|[]]; try subst l. + { repeat split => //. + { intros l hin'. subst k. rewrite (level_value_MapsTo hin'). reflexivity. } + { destruct k. right. symmetry in H1. now apply level_value_MapsTo' in H1. + left. red. right. split => //. } } + { split => //. split => //. + { intros l' hin'. eapply LevelMapFact.F.MapsTo_fun in H1; tea. subst. reflexivity. } + firstorder. } + - intros l' k. destruct H0 as [H0 hext]. specialize (H0 l' k). + intros [hm|hinc]. + { forward H0. left. rewrite add_max_spec. + destruct (eq_dec l' (concl cl)); eauto. + { left. split => //. rewrite max_opt_of_r. + now rewrite (level_value_MapsTo hm). } + destruct H0 as [? [hinm hle]]. + eapply is_higher_mon; tea. exists x. split; eauto. reflexivity. } + { red in hinc. destruct hinc. apply H0. now right. + destruct H1 as [-> ->]. + destruct (eq_dec l (concl cl)). + red. + destruct (LevelMap.find (concl cl) a) eqn:hl. + * apply LevelMap.find_2 in hl. + specialize (hext (concl cl) o). + forward hext. rewrite add_max_spec. left. split => //. + rewrite max_opt_of_r. now rewrite (level_value_MapsTo hl). + destruct hext as [k' []]. exists k'. split => //. constructor. + * specialize (hext (concl cl) None). + forward hext. rewrite add_max_spec. left. split => //. + now rewrite /level_value hl. + destruct cl; unfold clause_conclusion in *. exact hext. + * specialize (hext (concl cl) (level_value a (concl cl))). + forward hext. rewrite add_max_spec. left. split => //. + destruct hext as [l' []]; exists l'; split => //. constructor. } +Qed. + +Lemma min_model_map_acc l cls m : + let map := min_model_map m cls in + (forall k, LevelMap.MapsTo l k map -> max_of_map l k m) /\ + m ⩽ map. +Proof. + cbn. rewrite /min_model_map. + eapply ClausesProp.fold_rec. + 2:{ intros. destruct H2 as [hf hin]. + have [hm hnin] := min_model_clause_spec l x a. + split. + intros k. + move/hm. rewrite /is_max_of_clause_model. intros [[ism' ism] hasm]. + destruct hasm; eauto. intros kl'. move/hin => [k' [hmk' lek']]. + red in ism. specialize (ism _ hmk'). now transitivity k'. + transitivity a => //. + intros l' k ha. specialize (hnin l' k (or_introl ha)). + exact hnin. } + split; [|reflexivity]. + intros k hin k' hin'. + eapply LevelMapFact.F.MapsTo_fun in hin; tea. subst; reflexivity. +Qed. + +Lemma max_of_map_ext l k m m' : m ⩽ m' -> max_of_map l k m' -> max_of_map l k m. +Proof. + intros hext hm l'; move/hext => [k' [hm' le]]. + apply hm in hm'. now transitivity k'. +Qed. + +Lemma mapsto_max_of_map l k m : LevelMap.MapsTo l k m -> max_of_map l k m. +Proof. + intros hm l' k'. eapply LevelMapFact.F.MapsTo_fun in hm; tea. + subst; reflexivity. +Qed. + +Lemma min_model_map_spec l cls m : + let map := min_model_map m cls in + (forall k, LevelMap.MapsTo l k map -> + [/\ (exists cl, Clauses.In cl cls /\ is_in_clause l k cl) \/ LevelMap.MapsTo l k m, + (forall cl, Clauses.In cl cls -> max_of_premises l k (premise cl)) & max_of_map l k m]) /\ + (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l map) /\ + m ⩽ map. +Proof. + cbn. + rewrite /min_model_map. + have hgen : forall cls m, (forall k, LevelMap.MapsTo l k (Clauses.fold min_model_clause cls m) -> + [/\ (exists cl : Clauses.elt, Clauses.In cl cls /\ is_in_clause l k cl) \/ + LevelMap.MapsTo l k m, + forall cl : Clauses.elt, Clauses.In cl cls -> max_of_premises l k (premise cl) + & max_of_map l k (Clauses.fold min_model_clause cls m)]) /\ + (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l (Clauses.fold min_model_clause cls m)) /\ + m ⩽ Clauses.fold min_model_clause cls m. + 2:{ specialize (hgen cls m). destruct hgen as [hgen [hcls H]]; split; eauto. + intros k hm. specialize (hgen k hm) as [] => //. + split => //. eapply max_of_map_ext; tea. } + clear. + intros cls m. + eapply ClausesProp.fold_rec. + - intros s' he. split; [ | split; [|reflexivity]]. + * intros k hin. split => //. now right. + intros cl hin'. clsets. now apply mapsto_max_of_map. + * intros cl ins'; clsets. + - intros x a s' s'' hin hnin hadd [ih [ihcls hext]]. split; [|split]; revgoals. + { transitivity a => //. intros l' hin' hm. + have := min_model_clause_spec l' x a. cbn. + intros [_ hm']. specialize (hm' l' hin'). + now forward hm' by eauto. } + { intros cl ins'' l' inlev. + apply hadd in ins'' as [<-|]. + * have := min_model_clause_spec l' x a. cbn. + intros [_ hm']. eapply clause_levels_spec in inlev as []. + + eapply levelexprset_levels_spec in H as [k' incl]. + specialize (hm' l' (Some k')). forward hm'. right. left. rewrite /is_in_premise. exists k'; eauto. + destruct hm' as [? []]; now eexists. + + subst l'. specialize (hm' (concl x) None). forward hm'. + right. right. split => //. + destruct hm' as [? []]; now eexists. + * specialize (ihcls _ H _ inlev) as [k' ina]. + have := min_model_clause_spec l' x a. cbn. + move=> [] _ /(_ l' k' (or_introl ina)). + clear. firstorder. } + intros k. + have := min_model_clause_spec l x a. cbn. + intros [hm hm'] hmk. destruct (hm _ hmk). + split => //. + { destruct H0; eauto. + { left; exists x. split => //. apply hadd. now left. } + { specialize (ih _ H0) as []. destruct H1; eauto. left. + move: H1 => [] w []; exists w; split; eauto. apply hadd. now right. } } + { move=> cl /hadd => [] [<-|hin']. + { now move: H => []. } + { specialize (hm' l k). forward hm' by (destruct H0; eauto). + intros k' h. + specialize (ihcls _ hin' l). + forward ihcls. + { eapply clause_levels_spec. left. eapply levelexprset_levels_spec. now exists k'. } + destruct ihcls as [ka ihcls]. + specialize (ih _ ihcls) as [ihm ihcls' maxm]. + specialize (ihcls' _ hin' _ h). + transitivity ka => //. + destruct H as [mp mmap]. + now apply mmap. } } + { intros kl inma. eapply LevelMapFact.F.MapsTo_fun in hmk; tea. subst. reflexivity. } +Qed. + +Equations? infer_extension {V W init cls} (m : valid_model V W init cls) + (hincl : only_model_of V init) + (hs : clauses_levels cls ⊂_lset V) + (cls' : clauses) : + result (LevelSet.union (clauses_levels cls') V) LevelSet.empty (Clauses.union cls cls') (min_model_map m.(model_model) cls') := + infer_extension m hincl hs cls' := + infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model_map m.(model_model) cls') cls cls' _. +Proof. + repeat split. + - lsets. + - lsets. + - have ms := min_model_map_spec k cls' (model_model m). + set (map := min_model_map _ _) in *. + destruct ms as [hm [hcls hext]]. + rewrite LevelSet.union_spec => [] []. + * move/clauses_levels_spec. + intros [cl [hin ink]]. + now move: hcls => /(_ _ hin _ ink). + * move/(model_of_V m k). + move=> [] x /hext. firstorder. + - have ms := min_model_map_spec k cls' (model_model m). + set (map := min_model_map _ _) in *. + destruct ms as [hm [hcls hext]]. + rewrite LevelSet.union_spec. + move=> [] v /hm [] [[cl [incl inclv]]|hm'] ihcls mmap. + * left. + red in inclv. eapply clauses_levels_spec. + exists cl. split => //. eapply clause_levels_spec. + destruct inclv as [[? []]|]. + + left. eapply levelexprset_levels_spec. now eexists. + + right. intuition. + * have [_ ho] := valid_model_only_model _ _ _ _ m hincl k. + forward ho by now exists v. now right. +Qed. + +Lemma only_model_of_min_model_map cls V m : + clauses_levels cls ⊂_lset V -> + only_model_of V m -> only_model_of V (min_model_map m cls). +Proof. + intros incl om l. + split. + - move=> /om => [] [k inm]. + have [hmap [hcls hext]] := min_model_map_spec l cls m. + specialize (hext l k inm). firstorder. + - have [hmap [hcls hext]] := min_model_map_spec l cls m. + move=> [] x /hmap => [] [excl allcl maxm]. + red in maxm. + destruct excl as [[cl [incls incl']]|inm]. + * apply incl. apply clauses_levels_spec. exists cl. split => //. + red in incl'. + apply clause_levels_spec. + clear -incl'. firstorder. subst. left. apply levelexprset_levels_spec. + firstorder. + * rewrite (om l). now exists x. +Qed. + +Module CorrectModel. + Record t {V cls} := + { the_model : model; + only_model_of_V : only_model_of V the_model; + model_updates : LevelSet.t; + clauses_declared : clauses_levels cls ⊂_lset V; + model_valid : valid_model V model_updates the_model cls }. + Arguments t : clear implicits. + + #[local] Obligation Tactic := program_simpl. + Equations? infer_extension_correct {V W init cls} (m : valid_model V W init cls) + (hincl : only_model_of V init) + (hs : clauses_levels cls ⊂_lset V) + (cls' : clauses) + (hs' : clauses_levels cls' ⊂_lset V) : (t V (Clauses.union cls cls')) + premises := + infer_extension_correct m hincl hs cls' hs' with infer_extension m hincl hs cls' := + | Loop u _ => inr u + | Model w m' _ => + inl {| + the_model := min_model_map m.(model_model) cls'; + only_model_of_V := _; + model_updates := w; clauses_declared := _; + model_valid := {| model_model := m'.(model_model) |} |}. + Proof. + - have := valid_model_only_model _ _ _ _ m hincl. + now apply only_model_of_min_model_map. + - intros x; rewrite clauses_levels_spec; rw Clauses.union_spec. + intros [cl [[hin|hin] incl]]. apply hs. apply clauses_levels_spec. clear -hin incl; firstorder. + apply hs'. apply clauses_levels_spec. clear -hin incl; firstorder. + - have vm := model_of_V m'. eapply model_of_subset; tea. lsets. + - apply m'. + - intros ?; rewrite clauses_conclusions_spec. + intros [cl [H H']]. apply Clauses.union_spec in H as [H|H]; + [apply hs|apply hs']; subst a; apply clauses_levels_spec; exists cl; split => //; + eapply clause_levels_spec; auto. + - apply m'. + Qed. + + Equations? infer_extension_valid {V cls} (m : t V cls) cls' : option (t V (Clauses.union cls cls') + premises) := + infer_extension_valid m cls' with inspect (LevelSet.subset (clauses_levels cls') V) := + | exist false heq => None + | exist true heq := Some (infer_extension_correct (model_valid m) _ _ cls' _). + Proof. + - apply only_model_of_V. + - now apply m. + - now apply LevelSet.subset_spec in heq. + Qed. +End CorrectModel. + +Module Abstract. + Import CorrectModel. + Record t := + { levels : LevelSet.t; + clauses : Clauses.t; + model : CorrectModel.t levels clauses }. + + Program Definition init_model : t := + {| levels := LevelSet.empty; + clauses := Clauses.empty; + model := _ |}. + Next Obligation. + refine {| the_model := LevelMap.empty _; + only_model_of_V := _; + model_updates := LevelSet.empty; |}. + - intros l. split. lsets. + intros [x hm]. now eapply LevelMapFact.F.empty_mapsto_iff in hm. + - now intros l; rewrite clauses_levels_spec. + - refine {| model_model := LevelMap.empty _ |}. + * red. lsets. + * red. rewrite (proj2 (LevelSet.is_empty_spec _)). lsets. + reflexivity. + * now intros l; rewrite clauses_conclusions_spec. + * rewrite /is_model. eapply Clauses.for_all_spec. tc. + intros x hin. now apply Clauses.empty_spec in hin. + Qed. + + Equations? declare_level (m : t) (l : Level.t) : option t := + declare_level m l with inspect (LevelSet.mem l m.(levels)) := + | exist true _ => None + | exist false hneq => Some {| levels := LevelSet.add l m.(levels); clauses := m.(clauses) |}. + Proof. + refine {| the_model := LevelMap.add l None m.(model).(the_model); + only_model_of_V := _; + model_updates := m.(model).(model_updates); |}. + - intros k. rewrite LevelSet.add_spec /LevelSet.E.eq. + rw LevelMapFact.F.add_mapsto_iff. + have hyp := m.(model).(only_model_of_V) k. + firstorder; subst. all:rewrite /Level.eq. + * now exists None. + * exists x. right; split => //. intros ->. + apply LevelSetFact.not_mem_iff in hneq. contradiction. + - have hyp := m.(model).(clauses_declared). lsets. + - destruct m as [levels clauses vm]; cbn in *. + destruct vm as [init omofV W incl vm]. + destruct vm as [M mofV mupd mcls mok]. cbn in *. + refine {| model_model := LevelMap.add l None M |}. + * intros k. rewrite LevelSet.add_spec LevelMapFact.F.add_in_iff. firstorder. now left. + * move: mupd. + rewrite /is_update_of. + destruct (LevelSet.is_empty) eqn:hw. + now intros ->. + { apply (todo "strict update weakening"). } + * lsets. + * apply (todo "cannot activate more clauses"). + Qed. + + Equations enforce_clauses (m : t) (cls : Clauses.t) : option (t + premises) := + enforce_clauses m cls with infer_extension_valid m.(model) cls := + | None => None + | Some (inl m') => Some (inl {| model := m' |}) + | Some (inr u) => Some (inr u). + +End Abstract. +End Deciders. + +Module LoopChecking (LS : LevelSets). + Module Impl := Deciders(LS). + Import Impl.I. + + Definition model := Impl.Abstract.t. + + Notation univ := LS.LevelExprSet.nonEmptyLevelExprSet. + + Inductive constraint_type := UnivEq | UnivLe. + Notation constraint := (univ * constraint_type * univ). + + Definition enforce_constraint (cstr : constraint) (cls : Clauses.t) : Clauses.t := + let '(l, d, r) := cstr in + match d with + | UnivLe => + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) (LevelExprSet.t_set l) cls + | UnivEq => + let cls := + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) (LevelExprSet.t_set l) cls + in + let cls' := + LevelExprSet.fold (fun rk acc => Clauses.add (l, rk) acc) (LevelExprSet.t_set r) cls + in cls' + end. + + Definition init_model := Impl.Abstract.init_model. + + (* Returns None if already declared *) + Definition declare_level l m := Impl.Abstract.declare_level m l. + + (* Returns either a model or a looping universe, i.e. such that u >= u + 1 is implied + by the constraint *) + Definition enforce c (m : model) : option (model + univ) := + Impl.Abstract.enforce_clauses m (enforce_constraint c Clauses.empty). + + (* Returns true is the clause is valid in the model and all its possible consistent extensions. + Returns false if the constraint results in an inconsistent set of constraints or it simply + is not valid. *) + Definition check m c := + Impl.check_clauses m.(Impl.Abstract.clauses) (enforce_constraint c Clauses.empty). + + (* Returns the valuation of the model: a minimal assignement from levels to constraints + that make the enforced clauses valid. *) + Definition valuation m := Model.valuation_of_model m.(Impl.Abstract.model).(Impl.CorrectModel.the_model). + +End LoopChecking. \ No newline at end of file diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index f7c096b6e..295696415 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -5,7 +5,7 @@ From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInte From MetaRocq.Utils Require Import utils. From MetaRocq.Common Require Universes. -From MetaRocq.Common Require Import Interfaces. +From MetaRocq.Common Require Import Common Interfaces. From Equations Require Import Equations. Set Equations Transparent. @@ -84,12 +84,15 @@ Module Clauses (LS : LevelSets). Module ClausesFact := WFactsOn Clause Clauses. Module ClausesProp := WPropertiesOn Clause Clauses. Module ClausesDecide := WDecide (Clauses). + Module ClausesOrd := OrdProperties Clauses. + Ltac clsets := ClausesDecide.fsetdec. Infix "⊂_clset" := Clauses.Subset (at level 70). + Infix "=_clset" := Clauses.Equal (at level 70). Definition clauses := Clauses.t. - Lemma filter_add {p x s} : Clauses.Equal (Clauses.filter p (Clauses.add x s)) (if p x then Clauses.add x (Clauses.filter p s) else Clauses.filter p s). + Lemma filter_add {p x s} : Clauses.filter p (Clauses.add x s) =_clset if p x then Clauses.add x (Clauses.filter p s) else Clauses.filter p s. Proof. intros i. rewrite Clauses.filter_spec. @@ -127,31 +130,6 @@ Module Clauses (LS : LevelSets). rewrite Clauses.filter_spec. intuition auto. Qed. - Definition strict_subset (s s' : LevelSet.t) := - LevelSet.Subset s s' /\ ~ LevelSet.Equal s s'. - - Lemma strict_subset_incl (x y z : LevelSet.t) : LevelSet.Subset x y -> strict_subset y z -> strict_subset x z. - Proof. - intros hs []. split => //. lsets. - intros heq. apply H0. lsets. - Qed. - - Lemma strict_subset_cardinal s s' : strict_subset s s' -> LevelSet.cardinal s < LevelSet.cardinal s'. - Proof. - intros []. - assert (LevelSet.cardinal s <> LevelSet.cardinal s'). - { intros heq. apply H0. - intros x. split; intros. now apply H. - destruct (LevelSet.mem x s) eqn:hin. - eapply LevelSet.mem_spec in hin. - auto. eapply LevelSetProp.FM.not_mem_iff in hin. - exfalso. - eapply LevelSetProp.subset_cardinal_lt in hin; tea. - lia. } - enough (LevelSet.cardinal s <= LevelSet.cardinal s') by lia. - now eapply LevelSetProp.subset_cardinal. - Qed. - Definition premise (cl : clause) := fst cl. Definition concl (cl : clause) := snd cl. Extraction Inline premise concl. @@ -490,5 +468,897 @@ Module Clauses (LS : LevelSets). intuition eauto. destruct H as [cl []]; exists cl; split; try clsets; auto. Qed. + Lemma clauses_levels_conclusions cls V : clauses_levels cls ⊂_lset V -> + clauses_conclusions cls ⊂_lset V. + Proof. + intros hin x; rewrite clauses_conclusions_spec; move => [cl [hin' eq]]; apply hin. + rewrite clauses_levels_spec. exists cl. split => //. subst x. + rewrite clause_levels_spec. now right. + Qed. + + Definition clauses_premises_levels (cls : clauses) : LevelSet.t := + Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls LevelSet.empty. + + Lemma clauses_premises_levels_spec_aux l cls acc : + LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls acc) <-> + (exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl))) \/ LevelSet.In l acc. + Proof. + eapply ClausesProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k [hin hl]]. clsets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.union_spec. + split. + * intros [hin'|]. + left. exists x. split => //. + apply hadd. now left. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. + * intros [[k [ins'' ?]]|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. + Qed. + + Lemma clauses_premises_levels_spec l cls : + LevelSet.In l (clauses_premises_levels cls) <-> + exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl)). + Proof. + unfold clauses_premises_levels. + rewrite clauses_premises_levels_spec_aux. + intuition auto. lsets. + Qed. + + Lemma clauses_levels_premises cls V : clauses_levels cls ⊂_lset V -> + clauses_premises_levels cls ⊂_lset V. + Proof. + intros hin x; rewrite clauses_premises_levels_spec; move => [cl [hin' eq]]; apply hin. + rewrite clauses_levels_spec. exists cl. split => //. + rewrite clause_levels_spec. now left. + Qed. + + Lemma clauses_premises_levels_incl cls : clauses_premises_levels cls ⊂_lset clauses_levels cls. + Proof. + intros x; rewrite clauses_premises_levels_spec clauses_levels_spec; move => [cl [hin' eq]]. + exists cl; split => //. + rewrite clause_levels_spec. now left. + Qed. + + Lemma clauses_premises_levels_mon {cls cls'} : cls ⊂_clset cls' -> + clauses_premises_levels cls ⊂_lset clauses_premises_levels cls'. + Proof. + intros hin x; rewrite !clauses_premises_levels_spec; move => [cl [hin' eq]]. + exists cl; split => //. now apply hin. + Qed. + + Definition monotone_selector sel := + forall cls' cls, cls' ⊂_clset cls -> sel cls' ⊂_lset sel cls. + + Lemma clauses_levels_mon : monotone_selector clauses_levels. + Proof. + intros cls' cls hin x; rewrite !clauses_levels_spec; move => [cl [hin' eq]]. + exists cl; split => //. now apply hin. + Qed. + + Lemma clauses_with_concl_union cls W W' : + Clauses.Equal (cls ↓ (W ∪ W')) + (Clauses.union (cls ↓ W) (cls ↓ W')). + Proof. + intros x. rewrite Clauses.union_spec !in_clauses_with_concl LevelSet.union_spec. + firstorder. + Qed. + + Lemma clauses_with_concl_subset cls W : (cls ↓ W) ⊂_clset cls. + Proof. now intros ?; rewrite in_clauses_with_concl. Qed. + + Lemma union_diff_eq {cls cls'} : Clauses.Equal (Clauses.union cls (Clauses.diff cls' cls)) + (Clauses.union cls cls'). + Proof. clsets. Qed. + + Lemma union_restrict_with_concl {cls W} : + Clauses.Equal (Clauses.union (cls ⇂ W) (cls ↓ W)) (cls ↓ W). + Proof. + intros cl. rewrite Clauses.union_spec. + intuition auto. + eapply in_clauses_with_concl. + now eapply in_restrict_clauses in H0 as []. + Qed. + + Lemma union_diff {cls W} : + Clauses.Equal (Clauses.union (Clauses.diff (cls ↓ W) (cls ⇂ W)) (cls ⇂ W)) (cls ↓ W). + Proof. + now rewrite ClausesProp.union_sym union_diff_eq union_restrict_with_concl. + Qed. + + Lemma union_diff_cls {cls W} : + Clauses.Equal (Clauses.union (Clauses.diff (cls ↓ W) (cls ⇂ W)) cls) cls. + Proof. + intros ?. rewrite Clauses.union_spec Clauses.diff_spec in_restrict_clauses in_clauses_with_concl. + firstorder. + Qed. + + Lemma clauses_partition_spec {cls W allW conclW} : + clauses_conclusions cls ⊂_lset W -> + Clauses.partition (premise_restricted_to W) cls = (allW, conclW) -> + (Clauses.Equal allW (cls ⇂ W)) /\ + (Clauses.Equal conclW (Clauses.diff cls (cls ⇂ W))). + Proof. + intros clW. + destruct Clauses.partition eqn:eqp. + intros [= <- <-]. + change t with (t, t0).1. + change t0 with (t, t0).2 at 2. + rewrite -eqp. clear t t0 eqp. + split. + - intros cl. rewrite Clauses.partition_spec1. + rewrite in_restrict_clauses Clauses.filter_spec. + rewrite /premise_restricted_to LevelSet.subset_spec. firstorder eauto. + apply clW, clauses_conclusions_spec. now exists cl. + - intros cl. rewrite Clauses.partition_spec2. + rewrite Clauses.filter_spec Clauses.diff_spec. + rewrite /premise_restricted_to. intuition auto. + move/negbTE: H1. eapply eq_true_false_abs. + eapply LevelSet.subset_spec. + now eapply in_restrict_clauses in H as []. + apply eq_true_not_negb. move/LevelSet.subset_spec => he. + apply H1. apply in_restrict_clauses. split => //. + apply clW, clauses_conclusions_spec. now exists cl. + Qed. + + Lemma clauses_conclusions_eq cls W : + clauses_conclusions cls ⊂_lset W -> + Clauses.Equal cls (cls ↓ W). + Proof. + intros cl x. + rewrite in_clauses_with_concl. intuition auto. + apply cl, clauses_conclusions_spec. now exists x. + Qed. + + Definition levelexprset_of_levels (ls : LevelSet.t) n : LevelExprSet.t := + LevelSet.fold (fun x => LevelExprSet.add (x, n)) ls LevelExprSet.empty. + + Lemma levelexprset_of_levels_spec {ls : LevelSet.t} {l k n} : + LevelExprSet.In (l, k) (levelexprset_of_levels ls n) <-> LevelSet.In l ls /\ k = n. + Proof. + rewrite /levelexprset_of_levels. + eapply LevelSetProp.fold_rec. + - intros s' he. rewrite LevelExprSetFact.empty_iff. firstorder. + - intros x a s' s'' hin hnin hadd ih. + rewrite LevelExprSet.add_spec; unfold LevelExprSet.E.eq. + firstorder eauto; try noconf H1 => //. + apply hadd in H1. firstorder. subst. now left. + Qed. + + #[program] + Definition of_level_set (ls : LevelSet.t) n (hne : ~ LevelSet.Empty ls) : premises := + {| t_set := levelexprset_of_levels ls n |}. + Next Obligation. + apply not_Empty_is_empty => he. apply hne. + intros l nin. specialize (he (l,n)). apply he. + now rewrite levelexprset_of_levels_spec. + Qed. + + Lemma of_level_set_union_spec {ls ls' n hne} hne' hne'' : + of_level_set (ls ∪ ls') n hne = + univ_union (of_level_set ls n hne') (of_level_set ls' n hne''). + Proof. + apply eq_univ_equal. + intros [l k]. rewrite /of_level_set //= !levelexprset_of_levels_spec LevelExprSet.union_spec. + rewrite !levelexprset_of_levels_spec LevelSet.union_spec. clear. firstorder. + Qed. + + Lemma of_level_set_singleton l k hne : of_level_set (LevelSet.singleton l) k hne = singleton (l, k). + Proof. + apply eq_univ_equal. move=> [l' k']. + rewrite /of_level_set //= levelexprset_of_levels_spec !LevelExprSet.singleton_spec LevelSet.singleton_spec /LevelSet.E.eq /LevelExprSet.E.eq. + firstorder subst => //. now noconf H. now noconf H. + Qed. + + Definition max_premise_of l (u : premises) : option Z := + LevelExprSet.fold (fun '(l', k) acc => if eqb l l' then + max_opt_of Z.max (Some k) acc else acc) u None. + + Lemma max_premise_of_spec l k (u : premises) : LevelExprSet.In (l, k) u -> Some k ≤ max_premise_of l u. + Proof. + rewrite /max_premise_of. + eapply LevelExprSetProp.fold_rec. + - intros s' he hin. now apply he in hin. + - intros x a s' s'' hin nin hadd hle. + intros hs''. destruct x. + apply hadd in hs'' as []. + * noconf H. rewrite eqb_refl. destruct a; cbn. constructor. lia. reflexivity. + * elim: eqb_spec; try intros ->; + specialize (hle H); depelim hle; cbn; constructor; lia. + Qed. + + Definition max_clause_premise_of l (cls : clauses) := + Clauses.fold (fun cl acc => max_opt_of Z.max (max_premise_of l (premise cl)) acc) cls None. + + Lemma max_clause_premise_of_spec l k cls : + forall cl, Clauses.In cl cls -> LevelExprSet.In (l, k) (premise cl) -> Some k ≤ max_clause_premise_of l cls. + Proof. + rewrite /max_clause_premise_of => cl. + eapply ClausesProp.fold_rec. + - intros s' he hin. now apply he in hin. + - intros x a s' s'' hin nin hadd hle. + intros hs''. destruct x. + apply hadd in hs'' as []. + * noconf H. cbn. move/max_premise_of_spec. + intros h; etransitivity; tea. destruct (max_premise_of l n), a; cbn; constructor; lia. + * intros h; specialize (hle H h). depelim hle. cbn. + destruct (max_premise_of l n); cbn; constructor; lia. + Qed. + + Definition max_clause_premises cls := + let ls := clauses_levels cls in + let fn l m := LevelMap.add l (max_clause_premise_of l cls) m in + LevelSet.fold fn ls (LevelMap.empty _). + + Lemma max_clause_premises_spec l k cls : + LevelMap.MapsTo l k (max_clause_premises cls) -> + LevelSet.In l (clauses_levels cls) /\ k = max_clause_premise_of l cls. + Proof. + unfold max_clause_premises. + eapply LevelSetProp.fold_rec. + - intros s' he hm. now rewrite LevelMapFact.F.empty_mapsto_iff in hm. + - intros x a s' s'' hin hnin hadd ih. + rewrite LevelMapFact.F.add_mapsto_iff. + intros [[-> [= <-]]|[]] => //. + * split => //. apply hadd. now left. + * split => //. apply hadd; now right. now apply ih. + Qed. + + Lemma max_clause_premises_spec_inv cls : + forall l, LevelSet.In l (clauses_levels cls) -> + LevelMap.MapsTo l (max_clause_premise_of l cls) (max_clause_premises cls). + Proof. + unfold max_clause_premises. + eapply LevelSetProp.fold_rec. + - intros s' he hm. now move/he. + - intros x a s' s'' hin hnin hadd ih l ls''. + rewrite LevelMapFact.F.add_mapsto_iff. + destruct (eq_dec x l). subst. + * now left. + * right. split => //. apply ih. eapply hadd in ls''. destruct ls''; auto. contradiction. + Qed. + + Local Open Scope Z_scope. + + Definition add_expr n '((l, k) : LevelExpr.t) := (l, k + n). + + Lemma add_expr_add_expr n n' lk : add_expr n (add_expr n' lk) = add_expr (n + n') lk. + Proof. destruct lk; unfold add_expr. f_equal; lia. Qed. + Definition add_prems n s := map (add_expr n) s. + + Lemma In_add_prems k (prems : premises): + forall le, LevelExprSet.In le (add_prems k prems) <-> + exists le', LevelExprSet.In le' prems /\ le = add_expr k le'. + Proof. + intros [l k']. + now rewrite /add_prems map_spec. + Qed. + + Lemma add_expr_inj {n e e'} : add_expr n e = add_expr n e' -> e = e'. + Proof. + destruct e, e'; cbn; intros [=]. + have eq: z = z0 by lia. + now subst z0. + Qed. + + Lemma add_prems_inj n prems prems' : add_prems n prems = add_prems n prems' -> prems = prems'. + Proof. + rewrite /add_prems => /eq_univ_equal hm. + apply eq_univ_equal. + intros [l k]. specialize (hm (l, k + n)). + rewrite !map_spec in hm. destruct hm as [hl hr]. + split; intros hin. + - forward hl. exists (l, k); split => //. + destruct hl as [[] [hin' eq]]. + apply (@add_expr_inj n (l, k)) in eq. now noconf eq. + - forward hr. exists (l, k); split => //. + destruct hr as [[] [hin' eq]]. + apply (@add_expr_inj n (l, k)) in eq. now noconf eq. + Qed. + + Lemma add_prems_add_prems n n' lk : add_prems n (add_prems n' lk) = add_prems (n + n') lk. + Proof. destruct lk; unfold add_prems. + rewrite map_map. apply eq_univ_equal. + intros x. rewrite !map_spec. cbn in *. + firstorder eauto. subst. exists x0. + firstorder eauto. now rewrite add_expr_add_expr. + subst. exists x0. + firstorder eauto. now rewrite add_expr_add_expr. + Qed. + + Lemma add_prems_add {n lk prems} : add_prems n (add lk prems) = add (add_expr n lk) (add_prems n prems). + Proof. + apply eq_univ_equal. intros x. + rewrite In_add_prems LevelExprSet.add_spec In_add_prems /LevelExprSet.E.eq; rw LevelExprSet.add_spec. + firstorder. subst. red in H; subst x0. now left. + Qed. + + Lemma add_prems_0 u : add_prems 0 u = u. + Proof. + rewrite /add_prems. + apply eq_univ_equal. + intros x. rewrite map_spec. + split. + - intros[e [hin ->]]. unfold add_expr. now destruct e; rewrite Z.add_0_r. + - intros inu; exists x. split => //. destruct x. now rewrite /add_expr Z.add_0_r. + Qed. + + Lemma add_prems_of_level_set k W k' prf : + add_prems k (of_level_set W k' prf) = of_level_set W (k + k') prf. + Proof. + apply eq_univ_equal => [] [l n]. + rewrite In_add_prems /of_level_set //= levelexprset_of_levels_spec. + split. + - move=> [] [l' n']. rewrite levelexprset_of_levels_spec => [] [[inw eq] eq']. + subst n'. noconf eq'. split => //. lia. + - move=> [inW ->]. exists (l, k'). rewrite levelexprset_of_levels_spec. + split => //. cbn. f_equal; lia. + Qed. + + Definition add_clause n '((prems, concl) : clause) := (add_prems n prems, add_expr n concl). + + Lemma add_clause_add_clause n n' cl : add_clause n (add_clause n' cl) = add_clause (n + n') cl. + Proof. + destruct cl. + unfold add_clause. + now rewrite add_prems_add_prems add_expr_add_expr. + Qed. + + Notation succ_expr := (add_expr 1). + Notation succ_prems := (add_prems 1). + Notation succ_clause := (add_clause 1). + + Arguments add_prems : simpl never. + + Lemma add_clause_inj {n x y} : add_clause n x = add_clause n y -> x = y. + Proof. + destruct x as [prems concl], y as [prems' concl']. cbn. + apply: pair_inj. now move=> /add_prems_inj -> /add_expr_inj ->. + Qed. + Definition add_clauses n cls := ClausesProp.of_list (List.map (fun cl => add_clause n cl) (ClausesProp.to_list cls)). + Notation succ_clauses := (add_clauses 1). + Import SetoidList. + + Lemma add_clauses_spec {cl cls} n : Clauses.In cl cls <-> Clauses.In (add_clause n cl) (add_clauses n cls). + Proof. + unfold succ_clauses. + rewrite ClausesProp.of_list_1 InA_In_eq in_map_iff. + firstorder eauto. + - exists cl; split => //. unfold ClausesProp.to_list. now eapply Clauses_In_elements. + - eapply Clauses_In_elements in H0. apply add_clause_inj in H. now subst. + Qed. + + Lemma in_add_clauses {cl cls} n : Clauses.In cl (add_clauses n cls) -> exists cl', Clauses.In cl' cls /\ cl = add_clause n cl'. + Proof. + unfold succ_clauses. + rewrite ClausesProp.of_list_1 InA_In_eq in_map_iff. + firstorder eauto. + exists x; split => //. unfold ClausesProp.to_list. now eapply Clauses_In_elements. + Qed. + + Lemma clauses_levels_add {n cls} : clauses_levels (add_clauses n cls) =_lset clauses_levels cls. + Proof. + intros l. + rewrite clauses_levels_spec. + split. + - move=> [] cl [] /in_add_clauses [] cl' [] incl' ->. + rewrite clause_levels_spec. cbn. destruct cl; cbn. + intros h. apply clauses_levels_spec. exists cl'; split => //. + move: h; case. + move/levelexprset_levels_spec => [k]. + destruct cl'; cbn in * => /In_add_prems => [] [] x []. + destruct x => hin [=] ->. intros ->. + apply clause_levels_spec. left. apply levelexprset_levels_spec. now exists z. + intros ->. apply clause_levels_spec; right. destruct cl' => //=. destruct t0 => //. + - move/clauses_levels_spec => [] cl [] hin /clause_levels_spec []. + * move=> /levelexprset_levels_spec => [] [k hin']; exists (add_clause n cl); split => //. + now apply add_clauses_spec. + apply clause_levels_spec. left. + apply levelexprset_levels_spec. exists (k + n). + destruct cl; cbn. apply In_add_prems. exists (l, k). + split => //. + * intros ->. exists (add_clause n cl); split => //. now apply add_clauses_spec. + apply clause_levels_spec. right. + destruct cl; cbn. destruct t => //. + Qed. + + Lemma add_clause_0 cl : add_clause 0 cl = cl. + Proof. + destruct cl as [prems [concl k]]; cbn. + f_equal. 2:now rewrite Z.add_0_r. + unfold add_prems. + eapply eq_univ_equal. intros [l k']. + rewrite NonEmptySetFacts.map_spec. + unfold add_expr. split. + - intros [[] [hin heq]]. noconf heq. now rewrite Z.add_0_r. + - exists (l, k'); split => //. now rewrite Z.add_0_r. + Qed. + + Variant in_pred_closure cls : clause -> Prop := + | incls cl n : Clauses.In cl cls -> in_pred_closure cls (add_clause n cl) + | predcl x k : in_pred_closure cls (singleton (x, k + 1), (x, k)). + Derive Signature for in_pred_closure. + + Inductive entails (cls : clauses) : clause -> Prop := + | clause_in (prems : premises) (concl : LevelExpr.t) : + LevelExprSet.In concl prems -> entails cls (prems, concl) + | clause_cut prems' concl' prems concl : + in_pred_closure cls (prems', concl') -> + entails cls (add concl' prems, concl) -> + LevelExprSet.Subset prems' prems -> + entails cls (prems, concl). + + Definition entails_all cls (prems concls : premises) := + LevelExprSet.For_all (fun le => entails cls (prems, le)) concls. + + Notation " cls ⊢ prems → concl " := (entails cls (prems, concl)) (at level 20). + Notation " cls ⊢a prems → concl " := (entails_all cls prems concl) (at level 20). + + Lemma in_pred_closure_equal cls (prems prems' : premises) concl : + LevelExprSet.Equal prems prems' -> + in_pred_closure cls (prems, concl) -> in_pred_closure cls (prems', concl). + Proof. + intros eq. apply NonEmptySetFacts.eq_univ_equal in eq. now subst prems. + Qed. + + Lemma entails_equal cls (prems prems' : premises) concl : + LevelExprSet.Equal prems prems' -> + entails cls (prems, concl) -> entails cls (prems', concl). + Proof. + intros he en. + replace prems' with prems => //. + now apply eq_univ_equal. + Qed. + + Lemma entails_plus cls c : entails cls c -> entails (succ_clauses cls) (succ_clause c). + Proof. + induction 1. + - constructor. apply map_spec. exists concl0. split => //. + - eapply clause_cut with (succ_prems prems') (succ_expr concl'). + + depelim H. + * have -> : (succ_prems prems', succ_expr concl') = add_clause n (succ_clause cl). + { destruct cl as [prems'' concl'']. cbn in H0. noconf H0. + rewrite add_prems_add_prems add_expr_add_expr add_clause_add_clause. + now rewrite Z.add_1_r Z.add_1_l. } + constructor. now rewrite -add_clauses_spec. + * have eq : (succ_prems (singleton (x, (k + 1)))) = (singleton (x, k + 1 + 1)). + { apply eq_univ_equal. unfold succ_prems. + intros le. rewrite map_spec LevelExprSet.singleton_spec. + split. + { intros [? [hin ->]]. + rewrite LevelExprSet.singleton_spec in hin. red in hin; subst x0. + reflexivity. } + { unfold LevelExprSet.E.eq. intros ->. + exists (x, k + 1). split. + now rewrite LevelExprSet.singleton_spec. reflexivity. } } + rewrite eq. constructor 2. + + unfold succ_clause in IHentails. + eapply entails_equal; tea. + intros x. rewrite /succ_prems. rewrite map_spec add_spec. + setoid_rewrite add_spec. rewrite map_spec. + firstorder eauto. subst. now left. + + intros x. rewrite /succ_prems !map_spec. + intros [e [hin ->]]. exists e. firstorder. + Qed. + + + Derive Signature for entails. + + Lemma entails_pred_closure {cls prems concl k} : + cls ⊢ prems → (concl, 1 + k) -> cls ⊢ prems → (concl, k). + Proof. + intros he. + Opaque Z.add. + depind he. + - eapply clause_cut. + constructor. + 2:{ intros l hin. rewrite LevelExprSet.singleton_spec in hin. red in hin; subst l. + rewrite Z.add_comm; exact H. } + constructor. + rewrite LevelExprSet.add_spec. lesets. + - eapply clause_cut; tea. + Qed. + + Lemma entails_pred_closure_n {cls prems concl k n} : + entails cls (prems, (concl, k + Z.of_nat n)) -> entails cls (prems, (concl, k)). + Proof. + induction n in k |- *. + - rewrite Z.add_0_r. tauto. + - intros hen. rewrite Nat2Z.inj_succ in hen. rewrite Z.add_succ_r in hen. + eapply IHn. move: hen. + have -> : Z.succ (k + Z.of_nat n) = 1 + (k + Z.of_nat n) by lia. + eapply entails_pred_closure. + Qed. + + + Lemma incls0 {cls cl} : Clauses.In cl cls -> in_pred_closure cls cl. + Proof. + intros hin. + have hcl := incls _ _ 0 hin. + now rewrite add_clause_0 in hcl. + Qed. + + Lemma entails_in {cls cl} : Clauses.In cl cls -> entails cls cl. + Proof. + intros hin. + destruct cl as [prems concl]. + eapply clause_cut. + - now eapply incls0. + - constructor. eapply LevelExprSet.add_spec. now left. + - reflexivity. + Qed. + + Lemma in_pred_closure_shift {cls cl} n : in_pred_closure cls cl -> in_pred_closure cls (add_clause n cl). + Proof. + destruct 1. + - rewrite add_clause_add_clause. now constructor. + - cbn. eapply in_pred_closure_equal with (singleton (x, k + 1 + n)). + { intros le. rewrite In_add_prems; rewrite_strat (topdown LevelExprSet.singleton_spec). + intuition auto. exists (x, k + 1). split => //. + now destruct H as [le' [-> ->]]. } + have -> : k + 1 + n = (k + n) + 1 by lia. + constructor. + Qed. + + Lemma add_clause_singleton n le concl k : add_clause n (singleton le, (concl, k)) = (singleton (add_expr n le), (concl, k + n)). + Proof. + rewrite /add_clause //=. f_equal. + apply eq_univ_equal. intros le'. rewrite In_add_prems. + rewrite_strat (topdown LevelExprSet.singleton_spec). + unfold LevelExprSet.E.eq. firstorder. subst. reflexivity. + Qed. + + Lemma entails_shift {cls cl} n : entails cls cl -> entails cls (add_clause n cl). + Proof. + induction 1. + - unfold add_clause. constructor. + rewrite In_add_prems. exists concl0. split => //. + - eapply (clause_cut _ (add_prems n prems') (add_expr n concl')). + 2:{ unfold add_clause in *. eapply entails_equal; tea. + intros le. setoid_rewrite In_add_prems. setoid_rewrite LevelExprSet.add_spec. + setoid_rewrite In_add_prems. + unfold LevelExprSet.E.eq. firstorder. subst. now left. } + 2:{ intros x. rewrite !In_add_prems. firstorder. } + eapply (in_pred_closure_shift _ H). + Qed. + + Lemma entails_subset cls (prems prems' : premises) concl : LevelExprSet.Subset prems prems' -> + entails cls (prems, concl) -> + entails cls (prems', concl). + Proof. + intros hsubt. + intros H; revert prems' hsubt; depind H. + - constructor. eapply hsubt, H. + - intros prems'' hsub. + eapply clause_cut. 2:eapply IHentails. tea. + 2:lesets. intros x; rewrite !LevelExprSet.add_spec. firstorder. + Qed. + + Lemma entails_trans {cls prems concl concl'} : + entails cls (prems, concl) -> + entails cls (singleton concl, concl') -> + entails cls (prems, concl'). + Proof. + intros H; depind H. + - intros he. + depelim he. + * rewrite LevelExprSet.singleton_spec in H0. red in H0; subst concl0. + now constructor. + * eapply (clause_cut _ prems'). tea. + eapply entails_subset; tea. + intros ?; rewrite !LevelExprSet.add_spec LevelExprSet.singleton_spec; firstorder. + red in H2; subst a. now right. intros x. firstorder. apply H1 in H2. + rewrite LevelExprSet.singleton_spec in H2. now red in H2; subst x. + - intros he. + specialize (IHentails concl'0 he). + eapply clause_cut; tea. + Qed. + + Lemma entails_weak {cls prem concl concl'} : + entails cls (prem, concl) -> + entails cls (add concl' prem, concl). + Proof. + intros H. depind H. + - constructor. apply LevelExprSet.add_spec. now right. + - eapply (clause_cut _ _ concl'); tea. + rewrite add_comm. apply IHentails. + intros x; rewrite LevelExprSet.add_spec. firstorder. + Qed. + + Lemma entails_weak_union {cls prem concl concl'} : + entails cls (prem, concl) -> + entails cls (univ_union concl' prem, concl). + Proof. + intros hyp. + move: concl'. + apply: premises_elim. + - intros le. rewrite univ_union_comm univ_union_add_singleton. + now apply entails_weak. + - intros le prems ih. + rewrite univ_union_add_distr. intros _. + now eapply entails_weak. + Qed. + + Lemma entails_all_weak {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (add concl' prem) concl. + Proof. + intros hcl x hin. + specialize (hcl _ hin). cbn in hcl. + now apply entails_weak. + Qed. + + Lemma entails_all_weak_union {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (univ_union concl' prem) concl. + Proof. + intros hcl x hin. + specialize (hcl _ hin). cbn in hcl. + now apply entails_weak_union. + Qed. + + Lemma entails_all_weak' {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (add concl' prem) (add concl' concl). + Proof. + intros hcl x hin. + eapply LevelExprSet.add_spec in hin as []. red in H; subst. + - constructor. eapply LevelExprSet.add_spec. now left. + - specialize (hcl _ H). cbn in hcl. + now apply entails_weak. + Qed. + + Lemma entails_cut_all {cls prems' concl' prems concls} : + in_pred_closure cls (prems', concl') -> + cls ⊢a add concl' prems → concls -> + prems' ⊂_leset prems -> + cls ⊢a prems → concls. + Proof. + intros inp he hp x hin. + eapply clause_cut; tea. + now apply he in hin. + Qed. + + Lemma entails_all_subset {cls} {prems prems' prems'' : premises} : + prems'' ⊂_leset prems' -> + cls ⊢a prems → prems' -> + cls ⊢a prems → prems''. + Proof. + intros incl ha x hin. + eapply incl in hin. now apply ha in hin. + Qed. + + Lemma entails_all_add cls prem l prems' : + cls ⊢a prem → add l prems' <-> + cls ⊢ prem → l /\ cls ⊢a prem → prems'. + Proof. + rewrite /entails_all /LevelExprSet.For_all. + setoid_rewrite LevelExprSet.add_spec; rewrite /LevelExprSet.E.eq. + firstorder. now subst. + Qed. + + Lemma entails_add {cls prems cl concl} : + entails cls (prems, cl) -> + entails cls (add cl prems, concl) -> + entails cls (prems, concl). + Proof. + intros H; depind H. + - intros he. + depelim he. + * rewrite LevelExprSet.add_spec in H0. destruct H0 as []. + { red in H0; subst concl0. now constructor. } + { now constructor. } + * have eq : prems = add concl0 prems. + { eapply eq_univ_equal. intros x; rewrite LevelExprSet.add_spec. firstorder. now red in H2; subst. } + rewrite -eq in H1. + eapply (clause_cut _ prems' _ prems). tea. 2:tea. + now rewrite -eq in he. + - intros he. + eapply clause_cut. tea. eapply IHentails. + rewrite add_comm. now eapply entails_weak. + exact H1. + Qed. + + Lemma entails_cumul_one {cls prems prems' concl} : + entails_all cls prems prems' -> + entails cls (univ_union prems prems', concl) -> + entails cls (prems, concl). + Proof. + revert prems' prems concl. + apply: premises_elim. + - intros. specialize (H le). forward H by now apply LevelExprSet.singleton_spec. + cbn in H. + eapply entails_add; tea. + now rewrite -univ_union_add_singleton. + - intros le prems ih _ prem concl' hadd hadd'. + rewrite univ_union_comm univ_union_add_distr -univ_union_comm -univ_union_add_distr in hadd'. + eapply ih in hadd'. 2:{ apply entails_all_weak. apply entails_all_add in hadd as []. exact H0. } + apply entails_all_add in hadd as []. + eapply entails_add; tea. + Qed. + + Lemma entails_all_cumul {cls prems prems' concl} : + entails_all cls prems prems' -> + entails_all cls (univ_union prems prems') concl -> + entails_all cls prems concl. + Proof. + intros hp hc. + intros x hin. apply hc in hin. + eapply entails_cumul_one; tea. + Qed. + + Lemma entails_all_one {cls prem concl concl'} : + entails_all cls prem concl -> + entails cls (concl, concl') -> + entails cls (prem, concl'). + Proof. + intros ha he. + eapply entails_cumul_one; tea. + now eapply entails_weak_union. + Qed. + + Lemma entails_all_trans {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls concl concl' -> + entails_all cls prem concl'. + Proof. + intros ha he cl hin. + apply he in hin. + eapply entails_all_one; tea. + Qed. + + Lemma entails_incr_shift cls concl k n : + entails cls (singleton (concl, k), (concl, k + 1)) -> + entails cls (singleton (concl, k), (concl, k + 1 + Z.of_nat n)). + Proof. + induction n in k |- *; auto. + - now rewrite Z.add_0_r. + - intros en. + have hs := entails_shift 1 en. rewrite add_clause_singleton /= in hs. + apply IHn in hs. + eapply entails_trans; tea. + now have -> : k + 1 + Z.of_nat (S n) = k + 1 + 1 + Z.of_nat n by lia. + Qed. + + Lemma entails_incr_all cls concl k : + entails cls (singleton (concl, k), (concl, k + 1)) -> + forall k', entails cls (singleton (concl, k), (concl, k')). + Proof. + intros en k'. + destruct (Z.lt_trichotomy k k') as [|[]]; subst; auto. + - have ispos : 0 <= k' - k - 1 by lia. + eapply (entails_incr_shift _ _ _ (Z.to_nat (k' - k - 1))) in en. + assert (k + 1 + Z.of_nat (Z.to_nat (k' - k - 1)) = k') by lia. now rewrite H0 in en. + - constructor. now rewrite LevelExprSet.singleton_spec. + - have [k0 ->] : (exists kd : nat, k = k' + Z.of_nat kd). { exists (Z.to_nat (k - k')). lia. } + eapply (entails_pred_closure_n (n:=k0)). constructor. now apply LevelExprSet.singleton_spec. + Qed. + + Lemma entails_all_concl_union {cls prems concl concl'} : + cls ⊢a prems → concl -> + cls ⊢a prems → concl' -> + cls ⊢a prems → univ_union concl concl'. + Proof. + intros l r. + rewrite /entails_all. + intros x. rewrite univ_union_spec. intros []. now apply l. now apply r. + Qed. + + Lemma entails_all_union {cls prems concl prems' concl'} : + cls ⊢a prems → concl -> + cls ⊢a prems' → concl' -> + cls ⊢a univ_union prems prems' → univ_union concl concl'. + Proof. + intros l r. + apply entails_all_concl_union. + rewrite univ_union_comm. + now eapply entails_all_weak_union. + now eapply entails_all_weak_union. + Qed. + + + Lemma entails_all_shift {cls : clauses} {prems concl : premises} (n : Z) : + cls ⊢a prems → concl -> + cls ⊢a add_prems n prems → add_prems n concl. + Proof. + intros cla cl. + rewrite In_add_prems => [[le' [hin ->]]]. + eapply (entails_shift (cl := (prems, le'))). + now apply cla in hin. + Qed. + + Lemma in_pred_closure_subset {cls cls' prems concl} : + in_pred_closure cls (prems, concl) -> + cls ⊂_clset cls' -> + in_pred_closure cls' (prems, concl). + Proof. + induction 1. + - move/(_ _ H). now constructor. + - constructor. + Qed. + + Lemma entails_clauses_subset cls cls' prems concl : + cls ⊢ prems → concl -> + cls ⊂_clset cls' -> + cls' ⊢ prems → concl. + Proof. + induction 1 in cls' |- * => incl. + - now constructor. + - eapply clause_cut. + + eapply in_pred_closure_subset; tea. + + now apply IHentails. + + assumption. + Qed. + + Lemma entails_all_clauses_subset cls cls' prems concl : + cls ⊢a prems → concl -> + cls ⊂_clset cls' -> + cls' ⊢a prems → concl. + Proof. + intros d incl [l k]. + now move/d/entails_clauses_subset. + Qed. + + Lemma entails_succ cls (u v : premises) : + (forall l k, LevelExprSet.In (l, k) v -> exists k', LevelExprSet.In (l, k') u /\ k <= k') -> + cls ⊢a u → v. + Proof. + intros hk [l k] hin. + specialize (hk _ _ hin) as [k' [hin' le]]. + assert (exists n, k' = k + n) as [n ->] by (exists (k' - k); lia). + eapply (entails_pred_closure_n (n := Z.to_nat n)). + constructor. rewrite Z2Nat.id. lia. assumption. + Qed. + + Lemma entails_all_tauto cls u : cls ⊢a u → u. + Proof. + intros x hin. now constructor. + Qed. + + Lemma loop_any_successor cls u n : + cls ⊢a u → succ_prems u -> + cls ⊢a u → add_prems (Z.of_nat (S n)) u. + Proof. + induction n. + - auto. + - intros ass. + specialize (IHn ass). + have sh := entails_all_shift 1 IHn. + eapply entails_all_trans. tea. + rewrite add_prems_add_prems in sh. + have eq : 1 + Z.of_nat (S n) = Z.of_nat (S (S n)) by lia. + now rewrite eq in sh. + Qed. + + Lemma entails_pred_closure_neg {cls u concl k p} : + cls ⊢ u → (concl, k) -> + cls ⊢ u → (concl, k + Z.neg p). + Proof. + intros ent. + eapply (entails_pred_closure_n (n := Pos.to_nat p)). + have eq : Z.neg p + Z.of_nat (Pos.to_nat p) = 0. lia. + now rewrite -Z.add_assoc eq Z.add_0_r. + Qed. + + Lemma loop_any cls u n : + cls ⊢a u → succ_prems u -> + cls ⊢a u → add_prems n u. + Proof. + destruct n. + - rewrite add_prems_0. intros _. apply entails_all_tauto. + - assert (exists n, Z.pos p = Z.of_nat n). exists (Pos.to_nat p). now rewrite Z_of_pos_alt. + destruct H as [n ->]. destruct n. cbn. intros. rewrite add_prems_0. apply entails_all_tauto. + apply loop_any_successor. + - intros _ [l k]. rewrite In_add_prems. + intros [[] [hin heq]]. rewrite /add_expr in heq. noconf heq. + apply entails_pred_closure_neg. + now constructor. + Qed. End Clauses. diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 033a869a7..3e669c654 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -163,6 +163,33 @@ Proof. eapply LevelSetFact.is_empty_2 in he. contradiction. Qed. +Lemma in_singleton l : LevelSet.In l (LevelSet.singleton l). +Proof. lsets. Qed. + +Lemma not_in_union_inv l ls ls' : + ~ LevelSet.In l (LevelSet.union ls ls') -> + ~ LevelSet.In l ls /\ ~ LevelSet.In l ls'. +Proof. + rewrite LevelSet.union_spec. firstorder. +Qed. + +Infix "=m" := LevelMap.Equal (at level 50). + +Lemma levelmap_add_spec {A} (m m' : LevelMap.t A) {k v}: + LevelMapFact.Add k v m m' -> + m' =m LevelMap.add k v m. +Proof. + trivial. +Qed. + +Lemma not_empty_exists V : ~ LevelSet.Empty V -> exists l, LevelSet.In l V. +Proof. + intros ne. + destruct (LevelSet.choose V) eqn:ch. exists e. + now eapply LevelSet.choose_spec1 in ch. + now apply LevelSet.choose_spec2 in ch. +Qed. + Module NonEmptySetFacts. #[program] Definition singleton (e : LevelExpr.t) : nonEmptyLevelExprSet := {| t_set := LevelExprSet.singleton e |}. @@ -497,6 +524,12 @@ Proof. rewrite levelexprset_levels_spec_aux. intuition auto. lsets. Qed. +Lemma univ_non_empty (u : nonEmptyLevelExprSet) : ~ LevelSet.Empty (levels u). +Proof. intros he. have := t_ne u. move/not_Empty_is_empty. + intros he'. apply he'. intros [l k] hin. red in he. specialize (he l). apply he. + rewrite levelexprset_levels_spec. now exists k. +Qed. + Lemma levels_exprs_non_W_atoms {W prem} : LevelSet.Equal (levels (non_W_atoms W prem)) (LevelSet.diff (levels prem) W). Proof. @@ -560,4 +593,75 @@ Proof. cbn. firstorder. subst x'. now left. Qed. +Lemma map_map f g x : map f (map g x) = map (f ∘ g) x. +Proof. + apply eq_univ_equal. + intros lk. + rewrite !map_spec. setoid_rewrite map_spec. + firstorder eauto. subst. firstorder. +Qed. + +Definition strict_subset (s s' : LevelSet.t) := + LevelSet.Subset s s' /\ ~ LevelSet.Equal s s'. + +Lemma strict_subset_incl (x y z : LevelSet.t) : LevelSet.Subset x y -> strict_subset y z -> strict_subset x z. +Proof. + intros hs []. split => //. lsets. + intros heq. apply H0. lsets. +Qed. + +Lemma strict_subset_cardinal s s' : strict_subset s s' -> LevelSet.cardinal s < LevelSet.cardinal s'. +Proof. + intros []. + assert (LevelSet.cardinal s <> LevelSet.cardinal s'). + { intros heq. apply H0. + intros x. split; intros. now apply H. + destruct (LevelSet.mem x s) eqn:hin. + eapply LevelSet.mem_spec in hin. + auto. eapply LevelSetProp.FM.not_mem_iff in hin. + exfalso. + eapply LevelSetProp.subset_cardinal_lt in hin; tea. + lia. } + enough (LevelSet.cardinal s <= LevelSet.cardinal s') by lia. + now eapply LevelSetProp.subset_cardinal. +Qed. + +Lemma strict_subset_leq_right U V W : + strict_subset U V -> V ⊂_lset W -> strict_subset U W. +Proof. + intros [] le. split. lsets. intros eq. rewrite -eq in le. + apply H0. lsets. +Qed. + +Lemma strict_subset_leq_left U V W : + U ⊂_lset V -> strict_subset V W -> strict_subset U W. +Proof. + intros le []. split. lsets. intros eq. rewrite eq in le. + apply H0. lsets. +Qed. + +Lemma strict_subset_diff_incl V W W' : + strict_subset W' W -> + W ⊂_lset V -> + W' ⊂_lset V -> + strict_subset (LevelSet.diff V W) (LevelSet.diff V W'). +Proof. + intros [] lew lew'. + split. lsets. + intros eq. + apply H0. lsets. +Qed. + +Notation "#| V |" := (LevelSet.cardinal V). + +Lemma diff_cardinal_inter V W : #|LevelSet.diff V W| = #|V| - #|LevelSet.inter V W|. +Proof. + pose proof (LevelSetProp.diff_inter_cardinal V W). lia. +Qed. + +Lemma diff_cardinal V W : W ⊂_lset V -> #|LevelSet.diff V W| = #|V| - #|W|. +Proof. + intros hsub. + rewrite diff_cardinal_inter LevelSetProp.inter_sym LevelSetProp.inter_subset_equal //. +Qed. End FromLevelSets. \ No newline at end of file diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 502a1eaae..dc0bf3d7e 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -37,6 +37,29 @@ Module Model (LS : LevelSets). eapply LevelMap.find_2 in hfind. now intros [= ->]. Qed. + Inductive findSpec l m : option (option Z) -> Prop := + | inm k : LevelMap.MapsTo l k m -> findSpec l m (Some k) + | ninm : ~ LevelMap.In l m -> findSpec l m None. + + Lemma find_spec l m : findSpec l m (LevelMap.find l m). + Proof. + destruct (LevelMap.find l m) eqn:heq; constructor. + now apply LevelMap.find_2. + now apply LevelMapFact.F.not_find_in_iff in heq. + Qed. + + Variant level_value_spec (m : model) (l : Level.t) : option Z -> Prop := + | level_value_in k : LevelMap.MapsTo l k m -> level_value_spec m l k + | level_value_nin : ~ LevelMap.In l m -> level_value_spec m l None. + + Lemma level_valueP {m l} : level_value_spec m l (level_value m l). + Proof. + rewrite /level_value. + case: find_spec. + - now move=> k0 hm; apply level_value_in. + - now move=> hnin; apply level_value_nin. + Qed. + Definition levelexpr_value (m : model) (atom : LevelExpr.t) := level_value m (level atom). @@ -124,8 +147,6 @@ Module Model (LS : LevelSets). | l => Some ((LevelSet.union (LevelSetProp.of_list l) wm.1), m) end. - Infix "=m" := LevelMap.Equal (at level 50). - Definition strict_update m '(prems, (concl, k)) m' := exists v, [/\ min_premise m prems = Some v, ~~ level_value_above m concl (k + v) & @@ -139,6 +160,64 @@ Module Model (LS : LevelSets). strictly_updates cls ls' m' m'' -> strictly_updates cls (LevelSet.union ls ls') m m''. + + #[export] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. + Proof. + intros x y eqm l ? <-. unfold level_value. + unfold equal_model in eqm. + destruct LevelMap.find eqn:hl. + - eapply LevelMap.find_2 in hl. + rewrite eqm in hl. + eapply LevelMap.find_1 in hl. now rewrite hl. + - eapply LevelMapFact.F.not_find_in_iff in hl. + rewrite eqm in hl. + eapply LevelMapFact.F.not_find_in_iff in hl. + now rewrite hl. + Qed. + + #[export] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. + Proof. + intros m m' eqm ? ? ->. unfold min_atom_value. + destruct y => //. + now rewrite eqm. + Qed. + + #[export] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. + Proof. + intros m m' eq ? ? ->. + unfold min_premise. + destruct to_nonempty_list. + now setoid_rewrite eq. + Qed. + + #[export] Instance level_value_above_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> eq) level_value_above. + Proof. + intros m m' hm ? ? -> ? ? ->. + unfold level_value_above. + now rewrite hm. + Qed. + + Instance strictly_updates_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) strictly_updates. + Proof. + intros ? ? H ? ? H' ? ? H'' ? ? H'''. + eapply LevelSet.eq_leibniz in H'. subst y0. + split. + induction 1 in y, H, y1, H'', y2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. + now rewrite <- H. move: H1; unfold strict_update. destruct cl as [premse []]. + intros [v []]; exists v; split; + try setoid_rewrite <- H; + try setoid_rewrite <- H''; + try setoid_rewrite <- H'''; firstorder. + eapply IHstrictly_updates1; firstorder. firstorder. + induction 1 in x, H, x1, H'', x2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. + now rewrite H. move: H1; unfold strict_update. destruct cl as [premse []]. + intros [v []]; exists v; split; + try setoid_rewrite H; + try setoid_rewrite H''; + try setoid_rewrite H'''; firstorder. + eapply IHstrictly_updates1; firstorder. firstorder. + Qed. + Lemma strictly_updates_step cls w m m' m'' : strictly_updates cls w m m' -> forall cl, Clauses.In cl cls -> strict_update m' cl m'' -> @@ -179,9 +258,16 @@ Module Model (LS : LevelSets). - rewrite Clauses.add_spec. left; reflexivity. Qed. - #[export] Instance is_model_proper : Proper (Clauses.Equal ==> eq ==> eq) is_model. + Lemma strictly_updates_strenghten {cls W m m'} : + strictly_updates cls W m m' -> + strictly_updates (cls ↓ W) W m m'. Proof. - intros cl cl' eqcl x y ->. unfold is_model. now rewrite eqcl. + induction 1. + - constructor. rewrite in_clauses_with_concl. split => //. + eapply LevelSet.singleton_spec; reflexivity. exact H0. + - rewrite clauses_with_concl_union. econstructor 2. + eapply strictly_updates_weaken; tea. intros x; clsets. + eapply strictly_updates_weaken; tea. intros x; clsets. Qed. #[export] Instance equal_model_equiv : Equivalence equal_model. @@ -191,33 +277,9 @@ Module Model (LS : LevelSets). red; intros. now transitivity y. Qed. - #[export] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. - Proof. - intros x y eqm l ? <-. unfold level_value. - unfold equal_model in eqm. - destruct LevelMap.find eqn:hl. - - eapply LevelMap.find_2 in hl. - rewrite eqm in hl. - eapply LevelMap.find_1 in hl. now rewrite hl. - - eapply LevelMapFact.F.not_find_in_iff in hl. - rewrite eqm in hl. - eapply LevelMapFact.F.not_find_in_iff in hl. - now rewrite hl. - Qed. - - #[export] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. - Proof. - intros m m' eqm ? ? ->. unfold min_atom_value. - destruct y => //. - now rewrite eqm. - Qed. - - #[export] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. + #[export] Instance is_model_proper : Proper (Clauses.Equal ==> eq ==> eq) is_model. Proof. - intros m m' eq ? ? ->. - unfold min_premise. - destruct to_nonempty_list. - now setoid_rewrite eq. + intros cl cl' eqcl x y ->. unfold is_model. now rewrite eqcl. Qed. #[export] Instance update_model_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> LevelMap.Equal) update_model. @@ -227,13 +289,6 @@ Module Model (LS : LevelSets). now rewrite hm. Qed. - #[export] Instance level_value_above_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> eq) level_value_above. - Proof. - intros m m' hm ? ? -> ? ? ->. - unfold level_value_above. - now rewrite hm. - Qed. - Instance clauses_elements_proper : Proper (Clauses.Equal ==> eq) Clauses.elements. Proof. intros cl cl' eq. @@ -270,27 +325,6 @@ Module Model (LS : LevelSets). destruct l => //. Qed. - Instance strictly_updates_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) strictly_updates. - Proof. - intros ? ? H ? ? H' ? ? H'' ? ? H'''. - eapply LevelSet.eq_leibniz in H'. subst y0. - split. - induction 1 in y, H, y1, H'', y2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. - now rewrite <- H. move: H1; unfold strict_update. destruct cl as [premse []]. - intros [v []]; exists v; split; - try setoid_rewrite <- H; - try setoid_rewrite <- H''; - try setoid_rewrite <- H'''; firstorder. - eapply IHstrictly_updates1; firstorder. firstorder. - induction 1 in x, H, x1, H'', x2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. - now rewrite H. move: H1; unfold strict_update. destruct cl as [premse []]. - intros [v []]; exists v; split; - try setoid_rewrite H; - try setoid_rewrite H''; - try setoid_rewrite H'''; firstorder. - eapply IHstrictly_updates1; firstorder. firstorder. - Qed. - Lemma update_value_valid {m cl} : match update_value m cl with | None => valid_clause m cl @@ -503,6 +537,47 @@ Module Model (LS : LevelSets). now transitivity k'. Qed. + Lemma levelmap_find_eq {A} x (m m' : LevelMap.t A) : + (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> + LevelMap.find x m = LevelMap.find x m'. + Proof. + intros hm. + destruct (LevelMap.find x m) eqn:he; + destruct (LevelMap.find x m') eqn:he'. + all:try apply LevelMap.find_2 in he. all:try apply LevelMap.find_2 in he'. + apply hm in he. eapply LevelMapFact.F.MapsTo_fun in he; tea. congruence. + apply hm in he. apply LevelMapFact.F.not_find_in_iff in he'. firstorder. + apply LevelMapFact.F.not_find_in_iff in he. firstorder. congruence. + Qed. + + Lemma levelmap_level_value_eq x (m m' : model) : + (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> + level_value m x = level_value m' x. + Proof. + intros he. + rewrite /level_value. rewrite (levelmap_find_eq x m m') //. + Qed. + + Lemma levelmap_find_eq_inv {A} x (m m' : LevelMap.t A) : + LevelMap.find x m = LevelMap.find x m' -> + (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m'). + Proof. + intros hfind. + destruct (LevelMap.find x m) eqn:he; + destruct (LevelMap.find x m') eqn:he'. + all:try apply LevelMap.find_2 in he. all:try apply LevelMap.find_2 in he'. all:try congruence. + noconf hfind. intros k; split; intros. + eapply LevelMapFact.F.MapsTo_fun in he; tea. now subst. + eapply LevelMapFact.F.MapsTo_fun in he'; tea. now subst. + intros k; split; intros. + apply LevelMapFact.F.not_find_in_iff in he. firstorder. + apply LevelMapFact.F.not_find_in_iff in he'. firstorder. + Qed. + + Lemma maps_to_update {l k} {m : model} {k'} : LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m <-> k = k'. + Proof. + firstorder. now eapply LevelMapFact.F.MapsTo_fun in H; tea. now subst. + Qed. Lemma valid_update_value {m cl} : valid_clause m cl -> @@ -995,5 +1070,1387 @@ Module Model (LS : LevelSets). intros ih hv k. now rewrite hv. Qed. + Lemma check_model_ext {cls w init_model m w' m'} : + check_model cls (w, m) = Some (w', m') -> + strictly_updates cls w init_model m -> + strictly_updates cls w' init_model m' /\ w ⊂_lset w'. + Proof. + move/check_model_updates_spec. + intros ih cls'. eapply ih in cls' as [su incl]. split => //. + eapply strictly_updates_weaken; tea. clsets. + Qed. + + Lemma check_model_updates_spec_empty {cls m w m'} : + check_model cls (LevelSet.empty, m) = Some (w, m') -> + strictly_updates cls w m m'. + Proof. + move/check_model_spec => [w' [su ->]]. + replace (LevelSet.union LevelSet.empty w') with w' => //. + eapply LevelSet.eq_leibniz. intros x; lsets. + Qed. + + Lemma check_model_is_model {W cls m} : + check_model cls (W, m) = None <-> is_model cls m. + Proof. + now rewrite check_model_None. + Qed. + + Lemma check_model_update {W cls m wm'} : + model_of (clauses_conclusions cls) m -> + model_of W m -> + check_model cls (W, m) = Some wm' -> ~~ is_model cls m /\ m ⩽ wm'.2. + Proof. + intros mof tot. + destruct wm'. + move/check_model_spec => [w'' [su ->]]. cbn. split. + now eapply strictly_updates_invalid. + now eapply strictly_updates_ext. + Qed. + + Lemma min_premise_max_premise m prem k : + min_premise m prem = Some k -> + exists k', max_premise_value m prem = Some k'. + Proof. + unfold min_premise, max_premise_value. + destruct to_nonempty_list. + assert (forall l k, fold_left + (fun (min : option Z) (atom : LevelExpr.t) => + option_map2 Z.min (let '(l0, k0) := atom in match level_value m l0 with + | Some val => Some (val - k0)%Z + | None => None + end) min) + l None = + Some k -> False). + { clear. induction l; cbn => //. cbn in *. + destruct a, level_value; cbn; auto. } + assert + (forall x y, fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (Some x) = Some k -> + exists k', + fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.max (levelexpr_value m atom) min) l (Some y) = Some k'). + { induction l; cbn. + - intros x y [= <-]. now eexists. + - intros x y. + unfold min_atom_value, levelexpr_value, level. destruct a; cbn. + destruct level_value => //=. eapply IHl. cbn. intros H'. exfalso. + eapply H; eauto. } + - unfold min_atom_value, levelexpr_value, level. destruct p; cbn. + destruct level_value => //=. apply H0. + intros; exfalso. now eapply H. + Qed. + + Lemma model_of_value_None W m l : + model_of W m -> + LevelSet.In l W -> + LevelMap.find l m = None -> False. + Proof. + intros tm inw. specialize (tm l inw) as [v hm]. + rewrite /level_value. + now rewrite (LevelMap.find_1 hm). + Qed. + + Lemma defined_model_of_value_None W m l : + defined_model_of W m -> + LevelSet.In l W -> + level_value m l = None -> False. + Proof. + intros tm inw. specialize (tm l inw) as [v hm]. + rewrite /level_value. + now rewrite (LevelMap.find_1 hm). + Qed. + + #[export] Instance check_model_aux_proper_eq : Proper (Clauses.Equal ==> Logic.eq ==> Logic.eq) check_model_aux. + Proof. + intros cls cls' eq. + intros wm wm' eq'. subst wm'. + unfold check_model_aux. + now eapply ClausesOrd.fold_equal; tc. + Qed. + + Lemma strictly_updates_trans {cls cls' W W' m m' m''} : + strictly_updates cls W m m' -> + strictly_updates cls' W' m' m'' -> + strictly_updates (Clauses.union cls cls') (LevelSet.union W W') m m''. + Proof. + intros su su'. + eapply update_trans; eapply strictly_updates_weaken; tea; clsets. + Qed. + + Definition is_update_of cls upd minit m := + if LevelSet.is_empty upd then minit =m m + else strictly_updates cls upd minit m. + + Lemma check_model_is_update_of {cls cls' U W minit m m'} : + is_update_of cls U minit m -> + check_model cls' (U, m) = Some (W, m') -> + strictly_updates (Clauses.union cls cls') W minit m' /\ U ⊂_lset W. + Proof. + rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros ->. eapply LevelSetFact.is_empty_2 in he. + eapply LevelSetProp.empty_is_empty_1 in he. + eapply LevelSet.eq_leibniz in he. rewrite he. + move/check_model_updates_spec_empty. intros H; split => //. 2:lsets. + eapply strictly_updates_weaken; tea. clsets. + - intros hs. move/check_model_spec => [w'' [su ->]]. split; [|lsets]. + eapply strictly_updates_trans; tea. + Qed. + + Lemma is_update_of_case cls W m m' : + is_update_of cls W m m' -> + (LevelSet.Empty W /\ m =m m') \/ strictly_updates cls W m m'. + Proof. + rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros ->. left => //. now eapply LevelSetFact.is_empty_2 in he. + - intros H; now right. + Qed. + + Lemma model_of_ext {W m m'} : + model_of W m -> m ⩽ m' -> model_of W m'. + Proof. + intros mof ext. + intros k hin. destruct (mof k hin). specialize (ext _ _ H) as [k' []]. now exists k'. + Qed. + + Lemma defined_model_of_ext {W m m'} : + defined_model_of W m -> m ⩽ m' -> defined_model_of W m'. + Proof. + intros mof ext. + intros k hin. destruct (mof k hin). specialize (ext _ _ H) as [k' []]. + depelim H1. now exists y. + Qed. + + Lemma is_update_of_ext {cls W m m'} : is_update_of cls W m m' -> m ⩽ m'. + Proof. + move/is_update_of_case => []. + - intros [he%LevelSetProp.empty_is_empty_1]. red. setoid_rewrite H. + move=> l k hm; exists k; split => //. reflexivity. + - apply strictly_updates_ext. + Qed. + + Lemma model_of_union {U V cls} : model_of U cls -> model_of V cls -> model_of (LevelSet.union U V) cls. + Proof. + intros hu hv x. + rewrite LevelSet.union_spec; move => [] hin. + now apply hu. now apply hv. + Qed. + + Lemma defined_model_of_union {U V cls} : + defined_model_of U cls -> + defined_model_of V cls -> + defined_model_of (LevelSet.union U V) cls. + Proof. + intros hu hv x. + rewrite LevelSet.union_spec; move => [] hin. + now apply hu. now apply hv. + Qed. + + Lemma model_of_union_inv U V cls : model_of (LevelSet.union U V) cls -> model_of U cls /\ model_of V cls. + Proof. + rewrite /model_of. + setoid_rewrite LevelSet.union_spec. firstorder. + Qed. + + Lemma defined_model_of_union_inv U V cls : + defined_model_of (LevelSet.union U V) cls -> + defined_model_of U cls /\ defined_model_of V cls. + Proof. + rewrite /defined_model_of. + setoid_rewrite LevelSet.union_spec. firstorder. + Qed. + + Lemma strictly_updates_model_of_gen cls W m m' : + strictly_updates cls W m m' -> + forall W', model_of W' m -> model_of (LevelSet.union W' W) m'. + Proof. + clear. + induction 1. + - intros W' tot x. + destruct cl as [prems [concl cl]]. + destruct H0 as [minv [hmin ? heq]]. setoid_rewrite heq. + setoid_rewrite LevelMapFact.F.add_in_iff. cbn. + destruct (Level.eq_dec concl x). + { now left. } + { rewrite LevelSet.union_spec; intros [hin|hin]. + { eapply tot in hin as [wit mt]. right; exists wit. assumption. } + { eapply LevelSet.singleton_spec in hin. red in hin; subst. congruence. } } + - intros W' tot. + eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. + eapply model_of_subset; tea. intros x; lsets. + Qed. + + Lemma model_of_empty m : model_of LevelSet.empty m. + Proof. intros x; now move/LevelSet.empty_spec. Qed. + + Instance model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) model_of. + Proof. + intros ? ? H ? ? H'. unfold model_of. setoid_rewrite H. + now setoid_rewrite H'. + Qed. + + Lemma strictly_updates_total_model {cls W m m'} : + strictly_updates cls W m m' -> + model_of W m'. + Proof. + move/strictly_updates_model_of_gen/(_ LevelSet.empty). + intros H. forward H. apply model_of_empty. + rewrite LevelSetProp.empty_union_1 in H => //. lsets. + Qed. + + Lemma strictly_updates_only_model_gen cls W m m' : + strictly_updates cls W m m' -> + forall W', only_model_of W' m -> only_model_of (LevelSet.union W' W) m'. + Proof. + clear. + induction 1. + - intros W' tot x. + destruct cl as [prems [concl cl]]. + destruct H0 as [minv [hmin ? heq]]. setoid_rewrite heq. + setoid_rewrite LevelMapFact.F.add_mapsto_iff. cbn. + destruct (Level.eq_dec concl x). + { subst. rewrite LevelSet.union_spec LevelSet.singleton_spec. + firstorder; exists (Some (cl + minv)); left; split => //. } + { rewrite LevelSet.union_spec LevelSet.singleton_spec /LevelSet.E.eq. + firstorder. subst x. congruence. } + - intros W' tot. + eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. + eapply only_model_of_eq; tea. intros x; lsets. + Qed. + + Lemma is_update_of_total_model cls W m m' : is_update_of cls W m m' -> model_of W m'. + Proof. + move/is_update_of_case => []. + - intros [he eq]. + rewrite /model_of. lsets. + - eapply strictly_updates_total_model. + Qed. + + Lemma strict_update_modify m cl m' : strict_update m cl m' -> + exists k, LevelMap.Equal m' (LevelMap.add (clause_conclusion cl) k m). + Proof. + rewrite /strict_update. + destruct cl as [prems [concl k]]. + intros [v [hmin hab eq]]. now exists (Some (k + v)). + Qed. + + Lemma strictly_updates_model_of {cls W m m'} : + strictly_updates cls W m m' -> model_of W m'. + Proof. + move/strictly_updates_model_of_gen/(_ LevelSet.empty). + rewrite LevelSetProp.empty_union_1. lsets. + intros H; apply H. apply model_of_empty. + Qed. + + Lemma strictly_updates_modify {cls W m m'} : + strictly_updates cls W m m' -> + forall l k, LevelMap.MapsTo l k m' -> LevelSet.In l W \/ LevelMap.MapsTo l k m. + Proof. + induction 1. + + eapply strict_update_modify in H0 as [k eq]. + intros l k'. rewrite LevelSet.singleton_spec. + rewrite eq. + rewrite LevelMapFact.F.add_mapsto_iff. + intros [[]|] => //. red in H0; subst. + left. lsets. now right. + + intros. eapply IHstrictly_updates2 in H1. + destruct H1. left; lsets. + eapply IHstrictly_updates1 in H1 as []. left; lsets. + now right. + Qed. + + Lemma strictly_updates_modify_inv {cls W m m'} : + strictly_updates cls W m m' -> + forall l k, LevelMap.MapsTo l k m -> LevelSet.In l W \/ LevelMap.MapsTo l k m'. + Proof. + induction 1. + + eapply strict_update_modify in H0 as [k eq]. + intros l k'. rewrite LevelSet.singleton_spec. + rewrite eq. + rewrite LevelMapFact.F.add_mapsto_iff. + intros hm. unfold Level.eq. + destruct (Level.eq_dec l (clause_conclusion cl)). subst. now left. + right. right. auto. + + intros. eapply IHstrictly_updates1 in H1 as []. + left; lsets. + eapply IHstrictly_updates2 in H1 as []. left; lsets. + now right. + Qed. + + Lemma strictly_updates_outside cls W m m' : + strictly_updates cls W m m' -> model_map_outside W m m'. + Proof. + move=> su. + have lr := strictly_updates_modify su. + have rl := strictly_updates_modify_inv su. + intros l nin k. + split; intros. + - apply rl in H as [] => //. + - apply lr in H as [] => //. + Qed. + + Definition check_model_invariants cls w m w' m' (modified : bool) := + if modified then + [/\ w ⊂_lset w', + w' ⊂_lset (LevelSet.union w (clauses_conclusions cls)), + exists cl, + let cll := (level (concl cl)) in + [/\ Clauses.In cl cls, ~~ valid_clause m cl, + LevelSet.In cll w' & + opt_le Z.lt (level_value m cll) (level_value m' cll)], + model_extension w' m m' & + model_of w' m'] + else (w, m) = (w', m') /\ model_of w m. + + Import Corelib.Init.Logic. + + #[export] Instance check_model_invariants_proper : + Proper (Clauses.Equal ==> eq ==> eq ==> eq ==> eq ==> eq ==> iff) check_model_invariants. + Proof. + intros cls cls' eqcls. + repeat intro; subst. + unfold check_model_invariants. + destruct y3 => //. + now setoid_rewrite <-eqcls. + Qed. + + Lemma check_model_has_invariants {cls w m w' m'} : + model_of (clauses_conclusions cls) m -> + model_of w m -> + check_model cls (w, m) = Some (w', m') -> + check_model_invariants cls w m w' m' true. + Proof. + intros mof tot. + move/check_model_spec => [w'' [su ->]]. + cbn. split. + - lsets. + - apply strictly_updates_incl in su. lsets. + - clear -su. induction su. + * exists cl. split => //. now eapply strict_update_invalid. + unfold clause_conclusion. lsets. + destruct cl as [prems [concl k]]. + destruct H0 as [minp [hin hnabove habove]]. + move: hnabove habove. rewrite /level_value_above. + cbn. destruct level_value eqn:hv => //; try constructor. + intros hle. intros ->. rewrite level_value_add. constructor. + move/negbTE: hle. lia. + * destruct IHsu1 as [cl []]. + exists cl. split => //. lsets. + apply strictly_updates_ext in su2. + depelim H2; rewrite ?H3. 2:{ rewrite H2; constructor. } + eapply level_value_MapsTo', su2 in H4 as [k' [map le]]. + eapply level_value_MapsTo in map. rewrite map. depelim le. constructor; lia. + - constructor. now eapply strictly_updates_ext. + clear -mof su. + induction su. + * move: H0; unfold strict_update. destruct cl as [prems [concl k]]. + intros [v [hmi nabove eqm]]. intros l. rewrite eqm. + rewrite LevelMapFact.F.add_in_iff. specialize (mof l). + rewrite clauses_conclusions_spec in mof. firstorder. + * specialize (IHsu1 mof). transitivity m' => //. + apply IHsu2. intros l hin. specialize (mof _ hin). now apply IHsu1 in mof. + * eapply model_map_outside_weaken. now eapply strictly_updates_outside. lsets. + - eapply strictly_updates_model_of_gen in su; tea. + Qed. + + Definition infers_atom (m : model) (l : Level.t) (k : Z) := Some k ≤ level_value m l. + + Lemma infer_atom_downward {m l k k'} : + infers_atom m l k -> + (k' <= k) -> + infers_atom m l k'. + Proof. + rewrite /infers_atom. + intros infa le. + transitivity (Some k) => //. now constructor. + Qed. + + Lemma infers_atom_le {m m' l k} : + infers_atom m l k -> + m ⩽ m' -> + infers_atom m' l k. + Proof. + rewrite /infers_atom. + intros infa le. + depelim infa. eapply level_value_MapsTo' in H0. eapply le in H0 as [k' [hm hle]]. + rewrite (level_value_MapsTo hm). depelim hle; constructor; lia. + Qed. + + Lemma infers_atom_mapsto m l k : infers_atom m l k <-> + exists k', LevelMap.MapsTo l k' m /\ (Some k ≤ k'). + Proof. + rewrite /infers_atom; split. + - intros hle; depelim hle. + eapply level_value_MapsTo' in H0. exists (Some y). split => //. + now constructor. + - intros [k' [hm hle]]. + eapply level_value_MapsTo in hm. now rewrite hm. + Qed. + +Lemma is_update_of_empty cls m : + is_update_of cls LevelSet.empty m m. + Proof. + unfold is_update_of. + rewrite LevelSetFact.is_empty_1 //. lsets. + Qed. + + Lemma strictly_updates_W_eq cls W init m W' : + LevelSet.Equal W W' -> + strictly_updates cls W init m -> + strictly_updates cls W' init m. + Proof. now intros ->. Qed. + + Lemma strictly_updates_clauses_W cls cls' W init m W' : + Clauses.Subset cls cls' -> + LevelSet.Equal W W' -> + strictly_updates cls W init m -> + strictly_updates cls' W' init m. + Proof. intros hsub ->. now apply strictly_updates_weaken. Qed. + + Lemma strictly_updates_is_update_of cls W init m cls' W' m' : + strictly_updates cls W init m -> + is_update_of cls' W' m m' -> + strictly_updates (Clauses.union cls cls') (LevelSet.union W W') init m'. + Proof. + move=> su /is_update_of_case; intros [[empw eq]|su']. + rewrite <- eq. eapply (strictly_updates_weaken cls). clsets. + eapply strictly_updates_W_eq; tea. lsets. + eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. + Qed. + + Definition restrict_model W (m : model) := + LevelMapFact.filter (fun l k => LevelSet.mem l W) m. + + Lemma restrict_model_spec W m : + forall l k, LevelMap.MapsTo l k (restrict_model W m) <-> LevelMap.MapsTo l k m /\ LevelSet.In l W. + Proof. + intros l k; rewrite /restrict_model. + now rewrite LevelMapFact.filter_iff LevelSet.mem_spec. + Qed. + + (* Updates the entries in m with the values in m' if any *) + Definition model_update (m m' : model) : model := + LevelMap.mapi (fun l k => + match LevelMap.find l m' with + | Some k' => k' + | None => k + end) m. + + Instance model_update_proper : Proper (LevelMap.Equal ==> LevelMap.Equal ==> LevelMap.Equal) model_update. + Proof. + intros ? ? eq ? ? eq'. + rewrite /model_update. + apply LevelMapFact.F.Equal_mapsto_iff. + intros k e. + rewrite LevelMapFact.F.mapi_mapsto_iff. now intros ? ? ? ->. + rewrite LevelMapFact.F.mapi_mapsto_iff. now intros ? ? ? ->. + firstorder. exists x1. rewrite H. now rewrite -eq eq'. + rewrite H. exists x1. now rewrite eq -eq'. + Qed. + + Lemma model_update_spec m m' : + forall l k, LevelMap.MapsTo l k (model_update m m') <-> + (~ LevelMap.In l m' /\ LevelMap.MapsTo l k m) \/ + (LevelMap.MapsTo l k m' /\ LevelMap.In l m). + Proof. + intros l k; split. + - unfold model_update => hl. + eapply LevelMapFact.F.mapi_inv in hl as [a [k' [-> [eqk mt]]]]. + move: eqk; elim: (find_spec l m'). + + intros ? hm <-. right; split => //. now exists a. + + intros nin ->. left. split => //. + - intros [[nin hm]|[inm' inm]]. + * eapply LevelMapFact.F.mapi_mapsto_iff. now intros x y e ->. + elim: (find_spec l m'). + + intros k0 hm'. elim nin. now exists k0. + + intros _. exists k. split => //. + * eapply LevelMapFact.F.mapi_mapsto_iff. now intros x y e ->. + elim: (find_spec l m'). + + intros k0 hm'. destruct inm as [a inm]. exists a. split => //. + now eapply LevelMapFact.F.MapsTo_fun in inm'; tea. + + intros nin; elim nin. now exists k. + Qed. + + Lemma model_update_restrict m W : model_update m (restrict_model W m) =m m. + Proof. + apply LevelMapFact.F.Equal_mapsto_iff. intros l k. + rewrite model_update_spec. + split => //. + - intros [[nin hk]|[hr inm]] => //. + now eapply restrict_model_spec in hr. + - intros hm. + destruct (find_spec l (restrict_model W m)). + + right. apply restrict_model_spec in H as [hm' hw]. + split. eapply LevelMapFact.F.MapsTo_fun in hm; tea. subst. apply restrict_model_spec; split => //. + now exists k. + + left. split => //. + Qed. + + + Lemma min_premise_preserved {m m'} {prems : premises} : + (forall x, LevelSet.In x (levels prems) -> level_value m x = level_value m' x) -> + min_premise m prems = min_premise m' prems. + Proof. + intros hcl. + unfold min_premise. + funelim (to_nonempty_list prems). bang. clear H. + rw_in levelexprset_levels_spec hcl. + have -> : min_atom_value m e = min_atom_value m' e. + { destruct e as [k l']. + rewrite /min_atom_value. rewrite -hcl //. + exists l'. + apply LevelExprSet.elements_spec1. rewrite e0. now left. } + have cl' : forall x, (exists k, InA eq (x, k) l) -> level_value m x = level_value m' x. + { intros x [k ina]. apply hcl. exists k. apply LevelExprSet.elements_spec1. rewrite e0. now right. } + clear hcl Heqcall e0. + generalize (min_atom_value m' e). + induction l; cbn; auto. + have -> : min_atom_value m a = min_atom_value m' a. + { destruct a as [k l']. + rewrite /min_atom_value. rewrite cl' //. + exists l'. now left. } + intros o. + apply IHl. + intros x [k l']. apply cl'. exists k. now right. + Qed. + + Lemma min_premise_restrict m W (prems : premises) v : + (forall l k, LevelExprSet.In (l, k) prems -> LevelSet.In l W) -> + min_premise (restrict_model W m) prems = Some v -> + min_premise m prems = Some v. + Proof. + intros hin. + rewrite (@min_premise_preserved _ m) //. + move=> x. rewrite levelexprset_levels_spec => [] [k] /hin inW. + apply levelmap_level_value_eq => k'. + rewrite restrict_model_spec. firstorder. + Qed. + + Lemma model_of_model_update W m m' : + model_of W m -> + model_of W (model_update m m'). + Proof. + intros hm l hin. + move/hm: hin => [k hin]. + red. rw model_update_spec. + destruct (LevelMapFact.F.In_dec m' l). + - destruct i as [k' hin']. exists k'. right; split => //. now exists k. + - exists k; left; split => //. + Qed. + + Lemma strictly_updates_restrict_only_model {cls W m m'} : strictly_updates cls W m m' -> + only_model_of W (restrict_model W m'). + Proof. + intros su. red. rw restrict_model_spec. + split => //. 2:clear; firstorder. + eapply strictly_updates_total_model in su. move/[dup]/su. clear; firstorder. + Qed. + + Lemma only_model_of_restrict W m : + model_of W m -> only_model_of W (restrict_model W m). + Proof. + intros mof x. rw restrict_model_spec. firstorder. + Qed. + + Lemma strictly_updates_from_restrict {cls W W' m m'} : + clauses_conclusions cls ⊂_lset W -> + model_of W m -> + strictly_updates cls W' (restrict_model W m) m' -> + only_model_of W m'. + Proof. + intros hcls mof su. + have om := strictly_updates_only_model_gen _ _ _ _ su W. + apply strictly_updates_incl in su. + have hu : ((W ∪ W') =_lset W). intros x; lsets. + rewrite hu in om. apply om. + now apply only_model_of_restrict. + Qed. + + Lemma restrict_model_update W m m' : + model_of W m' -> + only_model_of W m -> + restrict_model W (model_update m' m) =m m. + Proof. + intros mof om. + intro l. apply levelmap_find_eq => k. + rewrite restrict_model_spec model_update_spec. split. + - move=> [] [[hnin hm] hin|hm hin]. + specialize (proj1 (om l) hin) as [x hm']. elim hnin. now exists x. + apply hm. + - move=> hm. split => //. 2:now apply om; exists k. + right; firstorder. + Qed. + + Lemma model_update_trans m upd upd' : + (forall l, LevelMap.In l upd -> LevelMap.In l upd') -> + model_update (model_update m upd) upd' =m model_update m upd'. + Proof. + intros hl l. apply levelmap_find_eq => k. + rewrite !model_update_spec /LevelMap.In. + rw model_update_spec. firstorder. + right. split => //. + destruct (LevelMapFact.F.In_dec upd l). + - destruct i as [updv hk]. + exists updv. firstorder. + - exists x; left; firstorder. + Qed. + + (* If we can update starting from a restricted model with no values outside [W], + this can be lifted to the unrestricted model, applying the same updates *) + Lemma strictly_updates_restrict_model_gen cls W W' m' : + forall cls' mr, + strictly_updates cls' W' mr m' -> + forall m, model_of W m -> + cls' = (cls ⇂ W) -> + mr =m (restrict_model W m) -> + strictly_updates (cls ⇂ W) W' m (model_update m m'). + Proof. + intros cls' mr. induction 1. + - intros mi mofW -> hm. + constructor. auto. + destruct cl as [prems [concl k]]. + destruct H0 as [v [hmin above heq]]. + rewrite hm in hmin, above. + exists v. split => //. + eapply min_premise_restrict with W => //. + { intros l k' hp. move/in_restrict_clauses: H => [] //= _ hsub _. apply hsub. + rewrite levelexprset_levels_spec. now exists k'. } + move: above. + rewrite /level_value_above /level_value. + elim: find_spec => //. + + intros kr hkr. + apply restrict_model_spec in hkr as [hkr hcl]. + now rewrite (LevelMap.find_1 hkr). + + move=> ncl _. + elim: find_spec => // => k' inm. + apply in_restrict_clauses in H as [inconcl inprems incls]. cbn in *. + elim ncl. exists k'. eapply restrict_model_spec. split => //. + + apply in_restrict_clauses in H as [inconcl inprems incls]. cbn in *. + rewrite heq. intro. apply levelmap_find_eq => k'. + rewrite hm. + rewrite model_update_spec !LevelMapFact.F.add_mapsto_iff restrict_model_spec. + rewrite LevelMapFact.F.add_in_iff /Level.eq. firstorder; subst. + right. split => //. left => //. now apply mofW. + destruct (inLevelSet W y). + * right. split. right => //. now exists k'. + * left. split => //. intros []. congruence. + destruct H2 as [yrest hin]. eapply restrict_model_spec in hin as []. contradiction. + - intros mtot mof -> hm. specialize (IHstrictly_updates1 mtot mof eq_refl hm). + specialize (IHstrictly_updates2 (model_update mtot m')). + have model_of : model_of W (model_update mtot m'). + by apply model_of_model_update. + specialize (IHstrictly_updates2 model_of eq_refl). + forward IHstrictly_updates2. + { rewrite hm in H. eapply strictly_updates_from_restrict in H; tea. + 2:eapply clauses_conclusions_restrict_clauses. + now rewrite restrict_model_update. } + eapply update_trans; tea. + have eqm : (model_update (model_update mtot m') m'') =m model_update mtot m''. + { eapply model_update_trans. eapply strictly_updates_ext in H0. + intros l [k hin]. apply H0 in hin as [k' []]. now exists k'. } + now rewrite eqm in IHstrictly_updates2. + Qed. + + Lemma strictly_updates_restrict_model cls W W' m' : + forall m, model_of W m -> + strictly_updates (cls ⇂ W) W' (restrict_model W m) m' -> + strictly_updates (cls ⇂ W) W' m (model_update m m'). + Proof. + intros m mof su. + eapply strictly_updates_restrict_model_gen; tea; reflexivity. + Qed. + + Lemma strictly_updates_is_update_of_restrict cls W init m W' m' : + strictly_updates cls W init m -> + is_update_of (cls ⇂ W) W' (restrict_model W m) m' -> + strictly_updates cls (LevelSet.union W W') init (model_update m m'). + Proof. + move=> su /is_update_of_case; intros [[empw eq]|su']. + - rewrite <- eq. eapply (strictly_updates_weaken cls). clsets. + rewrite model_update_restrict. + eapply strictly_updates_W_eq; tea. lsets. + - eapply strictly_updates_restrict_model in su'. + eapply strictly_updates_weaken in su'. 2:eapply restrict_clauses_subset. + eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. + now apply strictly_updates_total_model in su. + Qed. + + Lemma union_with_concl cls W : Clauses.Equal (Clauses.union cls (cls ↓ W)) cls. + Proof. + intros x. rewrite Clauses.union_spec in_clauses_with_concl. firstorder. + Qed. + + Instance is_update_of_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) is_update_of. + Proof. + intros ?? H ?? H' ?? H'' ?? H'''. + unfold is_update_of. setoid_rewrite H'. destruct LevelSet.is_empty. + rewrite H'' H'''. reflexivity. + firstorder. now rewrite -H -H' -H'' -H'''. + subst. now rewrite H H' H'' H'''. + Qed. + + Lemma empty_union l : LevelSet.Equal (LevelSet.union LevelSet.empty l) l. + Proof. intros ?. lsets. Qed. + + Lemma is_update_of_strictly_updates cls W m m' : + strictly_updates cls W m m' -> + is_update_of cls W m m'. + Proof. + intros su. have ne := strictly_updates_non_empty su. + rewrite /is_update_of. now rewrite (proj2 (levelset_not_Empty_is_empty _) ne). + Qed. + + Lemma is_update_of_weaken {cls cls' W m m'} : + Clauses.Subset cls cls' -> + is_update_of cls W m m' -> is_update_of cls' W m m'. + Proof. + intros hsub. + move/is_update_of_case => []. + - intros []. subst. rewrite /is_update_of. + now rewrite (LevelSetFact.is_empty_1 H). + - intros su. have ne := strictly_updates_non_empty su. + unfold is_update_of. rewrite (proj2 (levelset_not_Empty_is_empty _) ne). + eapply strictly_updates_weaken; tea. + Qed. + + Lemma is_update_of_trans {cls cls' W W' m m' m''} : + is_update_of cls W m m' -> is_update_of cls' W' m' m'' -> + is_update_of (Clauses.union cls cls') (LevelSet.union W W') m m''. + Proof. + move/is_update_of_case => []. + - move=> [he eq]. intro. rewrite eq. rewrite (LevelSetProp.empty_is_empty_1 he) empty_union. + move: H. eapply is_update_of_weaken. clsets. + - intros su isu. + eapply strictly_updates_is_update_of in isu; tea. + have ne := strictly_updates_non_empty isu. + rewrite /is_update_of. now rewrite (proj2 (levelset_not_Empty_is_empty _) ne). + Qed. + + Lemma is_update_of_trans_eq {cls cls' W W' cltr Wtr m m' m''} : + is_update_of cls W m m' -> is_update_of cls' W' m' m'' -> + Clauses.Subset (Clauses.union cls cls') cltr -> + LevelSet.Equal Wtr (LevelSet.union W W') -> + is_update_of cltr Wtr m m''. + Proof. + intros hi hi' hcl hw. rewrite hw. + eapply is_update_of_weaken; tea. + eapply is_update_of_trans; tea. + Qed. + + Lemma union_idem cls : Clauses.Equal (Clauses.union cls cls) cls. + Proof. intros ?; rewrite Clauses.union_spec. firstorder. Qed. + + Lemma update_total_model W m m' : + model_of W m -> + model_of W (model_update m m'). + Proof. + intros mof k inW. + apply mof in inW as [v inW]. + destruct (LevelMapFact.F.In_dec m' k). + - destruct i as [v' inm']. exists v'. + rewrite model_update_spec. right; firstorder. + - exists v. rewrite model_update_spec. left. split => //. + Qed. + + Lemma model_map_outside_update W m m' : + only_model_of W m' -> + model_map_outside W m (model_update m m'). + Proof. + intros om l nin k. + rewrite model_update_spec. + firstorder. + Qed. + + Lemma valid_clause_preserved {m m' cl} : + (forall x, LevelSet.In x (clause_levels cl) -> level_value m x = level_value m' x) -> + valid_clause m cl -> + valid_clause m' cl. + Proof. + intros hcl. destruct cl as [prems [concl k]]. + rewrite /valid_clause //=. + rewrite (@min_premise_preserved m m' prems). + { intros x inp. apply hcl. rewrite clause_levels_spec. now left. } + destruct (min_premise m' prems) => //. + rewrite /level_value_above. rewrite hcl //. + rewrite clause_levels_spec. now right. + Qed. + + Lemma is_model_update W m m' cls : + model_of W m -> + only_model_of W m' -> + is_model (cls ⇂ W) m' -> + is_model (cls ⇂ W) (model_update m m'). + Proof. + intros mW om. + rewrite /is_model. + move/Clauses.for_all_spec. intros h. + apply Clauses.for_all_spec. tc. + intros cl hin. + specialize (h cl hin). cbn in h. + eapply valid_clause_preserved; tea. + move=>x; move: hin. rewrite in_restrict_clauses. + intros [incl inprems incls]. + rewrite clause_levels_spec. move=> [] hin. + - apply inprems in hin. + apply levelmap_level_value_eq => k. + rewrite model_update_spec. clear -mW om hin. firstorder. + - subst x. apply levelmap_level_value_eq => k. + rewrite model_update_spec. cbn in *. firstorder. + Qed. + + Lemma strictly_updates_defined_model cls W m m' : + strictly_updates cls W m m' -> + defined_model_of W m'. + Proof. + induction 1. + - cbn. destruct cl as [prems [concl k]]; cbn in H0. + destruct H0 as [hz [hmin habov heq]]. + move=> l /LevelSet.singleton_spec => -> //=. + setoid_rewrite heq. exists (k + hz)%Z. + apply LevelMapFact.F.add_mapsto_iff. + left; split => //. + - apply defined_model_of_union; auto. + eapply defined_model_of_ext. exact IHstrictly_updates1. + now apply strictly_updates_ext in H0. + Qed. + + Lemma defined_model_of_restrict W m : + defined_model_of W m -> defined_model_of W (restrict_model W m). + Proof. + intros def l hin. specialize (def _ hin) as [k hm]. + exists k. apply restrict_model_spec. split => //. + Qed. + + Lemma defined_model_of_update W m m' : + model_of W m' -> + defined_model_of W m -> defined_model_of W (model_update m' m). + Proof. + intros mof def l hin. specialize (def _ hin) as [k hm]. + exists k. apply model_update_spec. right. split => //. + now apply mof. + Qed. + + Lemma defined_model_of_is_update_of {W W' W'' m m'} : + defined_model_of W m -> + is_update_of W' W'' m m' -> + defined_model_of W m'. + Proof. + intros def isupd l hin. move: isupd; rewrite /is_update_of. + destruct LevelSet.is_empty. + - intros h; setoid_rewrite <- h. specialize (def _ hin) as [k hm]. + now exists k. + - now move/strictly_updates_ext/defined_model_of_ext; move/(_ W). + Qed. + + Lemma check_model_spec_V {V cls w m w' m'} : + model_of V m -> clauses_conclusions cls ⊂_lset V -> + model_of w m -> + check_model cls (w, m) = Some (w', m') -> + check_model_invariants cls w m w' m' true. + Proof. + cbn; intros mof incl tot cm. + apply check_model_has_invariants in cm => //. + eapply model_of_subset. exact mof. tea. + Qed. + + Lemma is_modelP m cls : reflect (Clauses.For_all (valid_clause m) cls) (is_model cls m). + Proof. + case E: is_model; constructor. + - now move: E; rewrite /is_model -ClausesFact.for_all_iff. + - intros hf. apply ClausesFact.for_all_iff in hf; tc. unfold is_model in E; congruence. + Qed. + + Lemma is_model_invalid_clause cl cls m : is_model cls m -> ~~ valid_clause m cl -> ~ Clauses.In cl cls. + Proof. + move/is_modelP => ism /negP valid hin. + now specialize (ism _ hin). + Qed. + + + Definition model_min m := + LevelMap.fold (fun l k acc => Z.min acc (option_get 0 k)) m 0. + + Lemma model_min_spec m : forall l k, LevelMap.MapsTo l (Some k) m -> (model_min m <= k)%Z. + Proof. + intros l k hm. + rewrite /model_min. + move: hm; eapply LevelMapFact.fold_rec. + - move=> m0 he hm. now apply he in hm. + - intros k' e a m' m'' hm nin hadd hle hm''. + specialize (hadd l). + eapply levelmap_find_eq_inv in hadd. eapply hadd in hm''. + rewrite LevelMapFact.F.add_mapsto_iff in hm''. + move: hm''=> [] [h h']. + * subst e. cbn. lia. + * move/hle: h'. lia. + Qed. + + Lemma model_min_spec2 m : (model_min m <= 0)%Z. + Proof. + rewrite /model_min. + eapply LevelMapFact.fold_rec. + - intros; reflexivity. + - intros k' e a m' m'' hm nin hadd hle. lia. + Qed. + + Definition model_max m := + LevelMap.fold (fun l k acc => Z.max acc (option_get 0 k)) m 0. + + Lemma model_max_spec m : forall l k, LevelMap.MapsTo l k m -> (k ≤ Some (model_max m)). + Proof. + intros l k hm. + rewrite /model_max. + move: hm; eapply LevelMapFact.fold_rec. + - move=> m0 he hm. now apply he in hm. + - intros k' e a m' m'' hm nin hadd hle hm''. + specialize (hadd l). + eapply levelmap_find_eq_inv in hadd. eapply hadd in hm''. + rewrite LevelMapFact.F.add_mapsto_iff in hm''. + move: hm''=> [] [h h']. + * subst k. destruct e; constructor. cbn. lia. + * move/hle: h'. intros h'; depelim h'; constructor; lia. + Qed. + + Lemma model_max_spec2 m : (0 <= model_max m)%Z. + Proof. + rewrite /model_max. + eapply LevelMapFact.fold_rec. + - intros; reflexivity. + - intros k' e a m' m'' hm nin hadd hle. lia. + Qed. + + Definition valuation_of_model (m : model) : LevelMap.t nat := + let max := model_max m in + let min := model_min m in + LevelMap.fold (fun l k acc => LevelMap.add l (Z.to_nat (max - option_get 0 k - min)) acc) m (LevelMap.empty _). + + Lemma valuation_of_model_spec m : + forall l k, LevelMap.MapsTo l (Some k) m -> + let v := (model_max m - k - model_min m)%Z in + LevelMap.MapsTo l (Z.to_nat v) (valuation_of_model m). + Proof. + intros l k hm v. + unfold valuation_of_model. subst v. + move: hm. generalize (model_max m) (model_min m) => n n'. + eapply LevelMapFact.fold_rec. + - intros v he hm. + now eapply he in hm. + - intros. + specialize (H1 l). eapply levelmap_find_eq_inv in H1. eapply H1 in hm. + rewrite LevelMapFact.F.add_mapsto_iff in hm. destruct hm as [[-> ->]|[neq hm]]. + * eapply LevelMapFact.F.add_mapsto_iff. left. split => //. + * eapply LevelMapFact.F.add_mapsto_iff. right. split => //. now apply H2. + Qed. + + Lemma strictly_updates_valid_model {W W' m m' cls} : + is_model (cls ↓ W) m -> + strictly_updates cls W' m m' -> + exists l, LevelSet.In l W' /\ ~ LevelSet.In l W. + Proof. + intros vm. induction 1. + - exists (clause_conclusion cl). split => //. lsets. intros hin. + eapply strict_update_invalid in H0. + eapply is_model_invalid_clause in vm; tea. apply vm. + eapply in_clauses_with_concl. split => //. + - destruct (IHstrictly_updates1 vm). exists x. + rewrite LevelSet.union_spec. firstorder. + Qed. + + Lemma model_of_strictly_updates cls W V m m' : + strictly_updates cls W m m' -> model_of V m -> model_of V m'. + Proof. + intros su. + induction su. + - intros mv l hin. apply mv in hin. + destruct cl as [prems [concl k]]. + destruct H0 as [minv [eqmin nabove eqm]]. rewrite eqm. + rewrite LevelMapFact.F.add_in_iff. now right. + - eauto. + Qed. + + Lemma check_model_ne {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> ~ LevelSet.Empty W. + Proof. + move/check_model_spec => [w'' [su ->]]. + apply strictly_updates_non_empty in su. + intros he. apply su. lsets. + Qed. + + Lemma check_model_update_of {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> + exists W', is_update_of cls W' m m' /\ W = LevelSet.union U W'. + Proof. + move/check_model_spec => [w'' [su ->]]. exists w''. split => //. + now eapply is_update_of_strictly_updates. + Qed. + + Lemma strictly_updates_all cls V minit m : + strictly_updates cls V minit m -> + (forall l k, LevelSet.In l V -> LevelMap.MapsTo l k minit -> + exists k', LevelMap.MapsTo l (Some k') m /\ opt_le Z.lt k (Some k')). + Proof. + induction 1. + - intros l k hin hm. + move: H0; rewrite /strict_update. + destruct cl as [prems [concl gain]]. + move=> [] v [] minp hlt. cbn in hin. eapply LevelSet.singleton_spec in hin. red in hin; subst l. + move/negbTE: hlt; rewrite /level_value_above. + intros hle eq. setoid_rewrite eq. + eexists. setoid_rewrite LevelMapFact.F.add_mapsto_iff. split; [left;split;eauto|] => //. + destruct level_value eqn:hl => //. + * rewrite (level_value_MapsTo hm) in hl. noconf hl. constructor. lia. + * rewrite (level_value_MapsTo hm) in hl. noconf hl. constructor. + - intros l k; rewrite LevelSet.union_spec; move=> [] hin hm. + apply IHstrictly_updates1 in hm as [k' [hle hm']]; tea. + eapply strictly_updates_ext in H0. apply H0 in hle as [k'' [hm'' lek'']]. + depelim lek''. + exists y. split => //. depelim hm'; constructor; lia. + eapply strictly_updates_ext in H. eapply H in hm as [k' [hm' lek']]. + eapply IHstrictly_updates2 in hm' as [k'' [hm'' lek'']]; tea. + exists k''. split => //. depelim lek'; depelim lek''; constructor; lia. + Qed. + + Definition model_rel_partial R V (m m' : model) := + forall l, + (LevelSet.In l V -> forall k, LevelMap.MapsTo l k m -> + exists k', LevelMap.MapsTo l k' m' /\ opt_le R k k') /\ + (~ LevelSet.In l V -> forall k, LevelMap.MapsTo l k m <-> LevelMap.MapsTo l k m'). + + Lemma model_of_sext {R W W' m m'} : + model_of W m -> + model_of W' m -> + model_rel_partial R W m m' -> + model_of W' m'. + Proof. + intros mof mof' ext. + intros l hin. + destruct (mof' l hin). specialize (ext l) as [lin lout]. + destruct (inLevelSet W l) as [hin'|hout]. + - specialize (lin hin' _ H). firstorder. + - specialize (lout hout x). + exists x. now apply lout. + Qed. + + Lemma defined_model_of_sext {R W W' m m'} : + defined_model_of W m -> + defined_model_of W' m -> + model_rel_partial R W m m' -> + defined_model_of W' m'. + Proof. + intros mof mof' ext. + intros l hin. + destruct (mof' l hin). specialize (ext l) as [lin lout]. + destruct (inLevelSet W l) as [hin'|hout]. + - specialize (lin hin' _ H). firstorder. depelim H1. now exists y. + - specialize (lout hout (Some x)). + exists x. now apply lout. + Qed. + + Lemma model_rel_partial_trans {R W W' m m' m''} (HR : Transitive R) : + model_rel_partial R W m m' -> + model_rel_partial R W' m' m'' -> + model_rel_partial R (LevelSet.union W W') m m''. + Proof. + intros mr mr' l. + specialize (mr l) as [inWmr outWmr]. + specialize (mr' l) as [inWmr' outWmr']. + split. + { rewrite LevelSet.union_spec. move=> [] hin k hm. + - specialize (inWmr hin k hm) as [k' [hk' rk']]. + destruct (inLevelSet W' l). + + specialize (inWmr' H k' hk') as [k'' [hk'' rk'']]. + exists k''. split => //. now transitivity k'. + + specialize (outWmr' H k'). exists k'. split => //. now apply outWmr'. + - destruct (inLevelSet W l). + + specialize (inWmr H k hm) as [k'' [hk'' rk'']]. + specialize (inWmr' hin k'' hk'') as [km' [hkm' rkm']]. + exists km'. split => //. now transitivity k''. + + specialize (outWmr H k) as eq. + apply eq in hm. + specialize (inWmr' hin k hm) as [m''k [hm'' rm'']]. + exists m''k. split => //. } + { move/not_in_union_inv => [] ninW ninW' k. + rewrite (outWmr ninW k). + rewrite (outWmr' ninW' k). reflexivity. } + Qed. + + Lemma strictly_updates_model_lt {cls V} {m m'} : + strictly_updates cls V m m' -> + model_of V m -> + model_rel_partial Z.lt V m m'. + Proof. + intros su; induction su. + - intros htot l. split; revgoals. + { intros nin k. destruct cl as [prems [concl conclk]]; cbn in *. + destruct H0 as [minp [hmin nabove hm']]. + rewrite hm'. rewrite LevelMapFact.F.add_mapsto_iff. + assert (concl <> l). intros ->. + apply nin, in_singleton. + firstorder. } + intros inv k hin. + red in htot. + specialize (htot (clause_conclusion cl) (in_singleton _)) as [mconcl mt]. + destruct cl as [prems [concl conclk]]; cbn in *. + destruct H0 as [minp [hmin nabove hm']]. + eapply LevelSet.singleton_spec in inv; red in inv; subst l. + eapply LevelMapFact.F.MapsTo_fun in hin; tea. noconf hin. + exists (Some (conclk + minp))%Z. split => //. + rewrite hm'. + rewrite LevelMapFact.F.add_mapsto_iff. left. split => //. + move/negbTE: nabove; move/level_value_not_above_spec. + now rewrite (level_value_MapsTo mt). + - move/model_of_union_inv => [] totls totls'. + forward IHsu1 by auto. + forward IHsu2. + { eapply model_of_sext. exact totls. assumption. eassumption. } + now eapply model_rel_partial_trans. + Qed. + + Definition defined_map (m : LevelMap.t (option Z)) := + exists l k, LevelMap.MapsTo l (Some k) m. + + #[program] + Definition of_level_map (m : LevelMap.t (option Z)) (hne : defined_map m) : premises := + {| t_set := LevelMap.fold (fun l k acc => + if k is (Some k') return _ then LevelExprSet.add (l, k') acc else acc) m LevelExprSet.empty |}. + Next Obligation. apply not_Empty_is_empty. + move: hne. eapply LevelMapFact.fold_rec. firstorder. + intros. rewrite /LevelExprSet.Empty. + intros ha. destruct e eqn:he. + - specialize (ha (k, z)). apply ha; apply LevelExprSet.add_spec. now left. + - destruct hne as [witl [witk hin]]. + apply levelmap_add_spec in H1. rewrite H1 in hin. + rewrite LevelMapFact.F.add_mapsto_iff in hin; + destruct hin as [[? eq]|[new hm]]; try congruence. + eapply H2. now exists witl, witk. exact ha. + Qed. + + Lemma mapsto_some_add_none l k l' (m : model) : + LevelMap.MapsTo l (Some k) (LevelMap.add l' None m) <-> + LevelMap.MapsTo l (Some k) m /\ l <> l'. + Proof. + rewrite LevelMapFact.F.add_mapsto_iff; firstorder; congruence. + Qed. + + Lemma of_level_map_spec m hne : + forall l k, LevelExprSet.In (l, k) (of_level_map m hne) <-> LevelMap.MapsTo l (Some k) m. + Proof. + intros l k; rewrite /of_level_map //=. + clear hne. + have : forall acc, + LevelExprSet.In (l, k) + (LevelMap.fold (fun (l0 : LevelMap.key) k0 (acc : LevelExprSet.t) => + if k0 is (Some k') then LevelExprSet.add (l0, k') acc else acc) m acc) <-> + LevelMap.MapsTo l (Some k) m \/ LevelExprSet.In (l, k) acc. + move=> acc; eapply LevelMapFact.fold_rec. + - firstorder. + - intros. + destruct e eqn:he. + { rewrite LevelExprSet.add_spec H2. + split. + * intros [eq|hm]. + + noconf eq. specialize (H1 l). eapply levelmap_find_eq_inv in H1. + erewrite H1. left. apply LevelMapFact.F.add_mapsto_iff. left => //. + + specialize (H1 l). eapply levelmap_find_eq_inv in H1; erewrite H1. + rewrite LevelMapFact.F.add_mapsto_iff. + destruct (Level.eq_dec l k0); subst; firstorder. exact None. + * intros hm'. destruct hm'. + + specialize (H1 l). eapply levelmap_find_eq_inv in H1. eapply H1 in H3. + apply LevelMapFact.F.add_mapsto_iff in H3. destruct H3. firstorder; subst. left. red. red in H3. subst. + noconf H6; reflexivity. + unfold LevelExprSet.E.eq. destruct H3. now right; left. + + unfold LevelExprSet.E.eq. now right. } + { rewrite H2. clear H2; apply levelmap_add_spec in H1; rewrite H1. + rewrite mapsto_some_add_none. firstorder. cbn in H0. + destruct (Level.eq_dec l k0). + * subst. cbn in H0. firstorder. + * left. auto. } + - intros. rewrite H. firstorder. lesets. + Qed. + + Lemma strictly_updates_defined_map {cls W m m'} : + strictly_updates cls W m m' -> defined_map m'. + Proof. + induction 1. + - exists (clause_conclusion cl). + destruct cl as [prems [concl k]]. + destruct H0 as [? [? ? heq]]. cbn. + setoid_rewrite heq. exists (k + x)%Z; cbn. + rewrite LevelMapFact.F.add_mapsto_iff. firstorder. + - assumption. + Qed. + + Lemma strictly_updates_non_empty_init_map {cls W m m'} : + strictly_updates cls W m m' -> ~ LevelMap.Empty m. + Proof. + induction 1. + - destruct cl as [prems [concl k]]. + destruct H0 as [? [? ? heq]]. + eapply min_premise_spec_aux in H0 as [_ [[] [inprems heq']]]. + unfold min_atom_value in heq'. + destruct level_value eqn:hl => //. apply level_value_MapsTo' in hl. + now intros e; apply e in hl. + - auto. + Qed. + + Lemma strictly_updates_defined_init_map {cls W m m'} : + strictly_updates cls W m m' -> defined_map m. + Proof. + induction 1. + - destruct cl as [prems [concl k]]. + destruct H0 as [? [? ? heq]]. + eapply min_premise_spec_aux in H0 as [_ [[] [inprems heq']]]. + unfold min_atom_value in heq'. + destruct level_value eqn:hl => //. apply level_value_MapsTo' in hl. + now exists t0, z0. + - auto. + Qed. + + Definition premise_values (prems : premises) m := + NonEmptySetFacts.map (fun '(l, k) => (l, option_get 0 (level_value m l))) prems. + + Lemma premise_values_spec prems m : + forall l k, LevelExprSet.In (l, k) (premise_values prems m) <-> + (exists k', LevelExprSet.In (l, k') prems /\ k = option_get 0 (level_value m l)). + Proof. + rewrite /premise_values. + intros l k. rewrite NonEmptySetFacts.map_spec. + firstorder. destruct x. noconf H0. + exists z. split => //. exists(l, x); split => //. now rewrite -H0. + Qed. + + Definition hyps_map (hyps : premises) m := + (forall (l : Level.t) k, LevelExprSet.In (l, k) hyps <-> LevelMap.MapsTo l (Some k) m). + + Lemma model_hyps_entails cls m hyps (prems : premises) concl : + Clauses.In (prems, concl) cls -> + (forall l k, LevelExprSet.In (l,k) prems -> exists z, Some z ≤ level_value m l) -> + hyps_map hyps m -> + cls ⊢a hyps → premise_values prems m. + Proof. + intros incls hmx hm. + intros [l k] hin. + rewrite premise_values_spec in hin. destruct hin as [k' [inp ->]]. + red in hm. + constructor. rewrite hm. + specialize (hmx l _ inp). + depelim hmx. depelim H. rewrite H0 //=. + now eapply level_value_MapsTo'. + Qed. + + Section ModelMaps. + Definition premises_model_map (m : model) cls : model := + let levels := clauses_premises_levels cls in + LevelSet.fold (fun l acc => + LevelMap.add l (max_clause_premise_of l cls) acc) levels m. + + Definition zero_model levels : model := + LevelSet.fold (fun l acc => LevelMap.add l None acc) levels (LevelMap.empty _). + + Definition premises_model V cl : LevelSet.t * model := + let levels := LevelSet.union (clause_levels cl) V in + (levels, premises_model_map (zero_model levels) (Clauses.singleton cl)). + + Lemma premises_model_map_spec m cls : + forall l k, + LevelMap.MapsTo l k (premises_model_map m cls) <-> + ((LevelSet.In l (clauses_premises_levels cls) /\ k = max_clause_premise_of l cls /\ isSome k) \/ + (~ LevelSet.In l (clauses_premises_levels cls) /\ LevelMap.MapsTo l k m)). + Proof. + intros l k; rewrite /premises_model_map. + eapply LevelSetProp.fold_rec. + - intros s' he. split. intros hm. right. split => //. + firstorder. + - intros x a s' s'' hin hnin hadd ih. + split. + * rewrite LevelMapFact.F.add_mapsto_iff. + firstorder. subst k. red in H; subst. firstorder. + left; firstorder. + apply clauses_premises_levels_spec in hin as [cl [incl inlev]]. + apply levelexprset_levels_spec in inlev as [k inprem]. + have hs := max_clause_premise_of_spec l k cls cl incl inprem. + depelim hs. now rewrite H3. + * intros [[hin' [-> iss]]|]. + rewrite LevelMapFact.F.add_mapsto_iff. + destruct (Level.eq_dec x l); subst; firstorder. + destruct (Level.eq_dec x l); subst; firstorder. + rewrite LevelMapFact.F.add_mapsto_iff. right; split => //. + Qed. + + Lemma premises_model_map_in m cls l : + LevelMap.In l (premises_model_map m cls) <-> (LevelSet.In l (clauses_premises_levels cls) \/ LevelMap.In l m). + Proof. + rewrite /premises_model_map. + eapply LevelSetProp.fold_rec. + - intros s' he. firstorder. + - intros x a s' s'' hin hnin hadd ih. + rewrite LevelMapFact.F.add_in_iff. + firstorder. + Qed. + + Lemma zero_model_spec {l ls n} : LevelMap.MapsTo l n (zero_model ls) <-> LevelSet.In l ls /\ n = None. + Proof. + unfold zero_model. + eapply LevelSetProp.fold_rec. + - intros s' he. rewrite LevelMapFact.F.empty_mapsto_iff. firstorder. + - intros x a s s' hin hnin hadd eq. + rewrite LevelMapFact.F.add_mapsto_iff. firstorder. + destruct (Level.eq_dec x l). + * subst. now left. + * right. split => //. apply hadd in H1. destruct H1; try congruence. now apply H0. + Qed. + + Lemma in_premises_model V cl : + forall l, + LevelMap.In l (premises_model V cl).2 <-> + LevelSet.In l V \/ LevelSet.In l (clause_levels cl). + Proof. + intros l. rewrite premises_model_map_in. + rewrite clauses_premises_levels_spec. + firstorder. + - right. apply Clauses.singleton_spec in H. + apply clause_levels_spec. left. now subst. + - apply zero_model_spec in H as [hin ->]. + apply LevelSet.union_spec in hin. firstorder. + - right. exists None. apply zero_model_spec. split => //; lsets. + - eapply clause_levels_spec in H as [H|H]. + * left. exists cl. split => //. now apply Clauses.singleton_spec. + * subst. right. exists None. apply zero_model_spec. split => //. + apply LevelSet.union_spec. left. apply clause_levels_spec. now right. + Qed. + + End ModelMaps. + + + Section Semantics. + + Section Interpretation. + Context (V : LevelMap.t nat). + + Definition interp_level l := + match LevelMap.find l V with + | Some x => x + | None => 0%nat + end. + + Definition interp_expr '(l, k) := (Z.of_nat (interp_level l) + k)%Z. + Definition interp_prems prems := + let '(hd, tl) := to_nonempty_list prems in + fold_right (fun lk acc => Z.max (interp_expr lk) acc) (interp_expr hd) tl. + + Definition clause_sem (cl : clause) : Prop := + let '(prems, concl) := cl in + (interp_prems prems >= interp_expr concl)%Z. + + Definition clauses_sem (cls : clauses) : Prop := + Clauses.For_all clause_sem cls. + End Interpretation. + + (* There exists a valuation making all clauses true in the natural numbers *) + Definition satisfiable (cls : clauses) := + exists V, clauses_sem V cls. + + (* Any valuation making all clauses valid in the natural numbers also satisfies the clause cl *) + Definition entails_sem (cls : clauses) (cl : clause) := + forall V, clauses_sem V cls -> clause_sem V cl. + End Semantics. + End Model. \ No newline at end of file diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index 9ed58d34e..7836ded67 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -11,37 +11,8 @@ From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses M Set Equations Transparent. -Module Type LoopCheckingItf (LS : LevelSets). - - (* Type of consistent models of a set of universe constraints *) - Parameter model : Type. - Notation univ := LS.LevelExprSet.nonEmptyLevelExprSet. - - Inductive constraint_type := UnivEq | UnivLe. - Notation constraint := (univ * constraint_type * univ). - - Parameter init_model : model. - - (* Returns None if already declared *) - Parameter declare_level : LS.Level.t -> model -> option model. - - (* If the constraints mention undeclared universes, returns None, - otherwise, returns either a model or a looping universe, i.e. such that u >= u + 1 is implied - by the constraint *) - Parameter enforce : constraint -> model -> option (model + univ). - - (* Returns true is the clause is valid in the model and all its possible consistent extensions. - Returns false if the constraint results in an inconsistent set of constraints or it simply - is not valid. *) - Parameter check : model -> constraint -> bool. - - (* Returns the valuation of the model: a minimal assignement from levels to constraints - that make the enforced clauses valid. *) - Parameter valuation : model -> LS.LevelMap.t nat. -End LoopCheckingItf. - Module LoopCheckingImpl (LS : LevelSets). - Module Import Model := Model(LS). + Module Export Model := Model(LS). Local Open Scope Z_scope. Definition v_minus_w_bound (W : LevelSet.t) (m : model) := @@ -108,29 +79,6 @@ Proof. destruct LevelMap.find => hf; depelim hf; constructor; lia. Qed. -Definition check_model_invariants cls w m w' m' (modified : bool) := - if modified then - [/\ w ⊂_lset w', - w' ⊂_lset (LevelSet.union w (clauses_conclusions cls)), - exists cl, - let cll := (level (concl cl)) in - [/\ Clauses.In cl cls, ~~ valid_clause m cl, - LevelSet.In cll w' & - opt_le Z.lt (level_value m cll) (level_value m' cll)], - model_extension w' m m' & - model_of w' m'] - else (w, m) = (w', m') /\ model_of w m. - -#[export] Instance check_model_invariants_proper : - Proper (Clauses.Equal ==> eq ==> eq ==> eq ==> eq ==> eq ==> iff) check_model_invariants. -Proof. - intros cls cls' eqcls. - repeat intro; subst. - unfold check_model_invariants. - destruct y3 => //. - now setoid_rewrite <-eqcls. -Qed. - Definition levelset_m_eq : list Level.t × model -> list Level.t × model -> Prop := fun x y => x.1 = y.1 /\ LevelMap.Equal x.2 y.2. @@ -142,43 +90,6 @@ Proof. all:etransitivity; tea. Qed. -Lemma check_model_ext {cls w init_model m w' m'} : - check_model cls (w, m) = Some (w', m') -> - strictly_updates cls w init_model m -> - strictly_updates cls w' init_model m' /\ w ⊂_lset w'. -Proof. - move/check_model_updates_spec. - intros ih cls'. eapply ih in cls' as [su incl]. split => //. - eapply strictly_updates_weaken; tea. clsets. -Qed. - -Lemma check_model_updates_spec_empty {cls m w m'} : - check_model cls (LevelSet.empty, m) = Some (w, m') -> - strictly_updates cls w m m'. -Proof. - move/check_model_spec => [w' [su ->]]. - replace (LevelSet.union LevelSet.empty w') with w' => //. - eapply LevelSet.eq_leibniz. intros x; lsets. -Qed. - -Lemma check_model_is_model {W cls m} : - check_model cls (W, m) = None <-> is_model cls m. -Proof. - now rewrite check_model_None. -Qed. - -Lemma check_model_update {W cls m wm'} : - model_of (clauses_conclusions cls) m -> - model_of W m -> - check_model cls (W, m) = Some wm' -> ~~ is_model cls m /\ m ⩽ wm'.2. -Proof. - intros mof tot. - destruct wm'. - move/check_model_spec => [w'' [su ->]]. cbn. split. - now eapply strictly_updates_invalid. - now eapply strictly_updates_ext. -Qed. - Definition level_value_default m l := match level_value m l with Some x => x | None => 0 end%Z. @@ -187,57 +98,6 @@ Definition measure_w W cls m w := let maxgain := max_gain (cls_diff cls W) in (bound + Z.of_nat maxgain - (level_value_default m w))%Z. -Lemma min_premise_max_premise m prem k : - min_premise m prem = Some k -> - exists k', max_premise_value m prem = Some k'. -Proof. - unfold min_premise, max_premise_value. - destruct to_nonempty_list. - assert (forall l k, fold_left - (fun (min : option Z) (atom : LevelExpr.t) => - option_map2 Z.min (let '(l0, k0) := atom in match level_value m l0 with - | Some val => Some (val - k0)%Z - | None => None - end) min) - l None = - Some k -> False). - { clear. induction l; cbn => //. cbn in *. - destruct a, level_value; cbn; auto. } - assert - (forall x y, fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (Some x) = Some k -> -exists k', - fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.max (levelexpr_value m atom) min) l (Some y) = Some k'). - { induction l; cbn. - - intros x y [= <-]. now eexists. - - intros x y. - unfold min_atom_value, levelexpr_value, level. destruct a; cbn. - destruct level_value => //=. eapply IHl. cbn. intros H'. exfalso. - eapply H; eauto. } - - unfold min_atom_value, levelexpr_value, level. destruct p; cbn. - destruct level_value => //=. apply H0. - intros; exfalso. now eapply H. -Qed. - -Lemma model_of_value_None W m l : - model_of W m -> - LevelSet.In l W -> - LevelMap.find l m = None -> False. -Proof. - intros tm inw. specialize (tm l inw) as [v hm]. - rewrite /level_value. - now rewrite (LevelMap.find_1 hm). -Qed. - -Lemma defined_model_of_value_None W m l : - defined_model_of W m -> - LevelSet.In l W -> - level_value m l = None -> False. -Proof. - intros tm inw. specialize (tm l inw) as [v hm]. - rewrite /level_value. - now rewrite (LevelMap.find_1 hm). -Qed. - Lemma invalid_clause_measure W cls cl m : defined_model_of W m -> ~~ valid_clause m cl -> @@ -245,7 +105,6 @@ Lemma invalid_clause_measure W cls cl m : (0 < measure_w W cls m (concl cl))%Z. Proof. intros hwv. unfold valid_clause. - (* case: Z.ltb_spec => // hprem. *) destruct cl as [prem [l k]]; cbn. destruct min_premise eqn:hmin => //. move/negbTE/level_value_not_above_spec => hlt hin. @@ -280,10 +139,8 @@ Proof. pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. assert (premise_min prem <= premise_min preml). { eapply premise_min_subset. eapply non_W_atoms_subset. } - (* transitivity (v_minus_w_bound W m + (k - premise_min preml)). 2:lia. *) assert (y <= maxpreml - (premise_min preml))%Z. { rewrite eqpminpre. rewrite H2 in eqminpre; symmetry in eqminpre. - (* eqmaxpre eqminpre. *) pose proof (min_atom_value_levelexpr_value m exmin). specialize (amax _ inminpre) as amax'. rewrite eqmaxpre in amax'. destruct amax' as [vexmin [eqexmin ltexmin]]. @@ -292,11 +149,6 @@ Proof. rewrite -eqmaxpre in H6. noconf H6. lia. } transitivity (k + (maxpreml - (premise_min preml)))%Z. lia. - (* assert (Z.of_nat (premise_min preml) <= maxpreml)%Z. - { rewrite eqmaxpre. - move/min_premise_pos_spec: hprem => hprem. - transitivity exmax. apply apmin => //. eapply hprem. - now apply (non_W_atoms_subset W prem). } *) assert (k + (maxpreml - (premise_min preml)) = (maxpreml + k - (premise_min preml)))%Z as ->. lia. enough (maxpreml <= (v_minus_w_bound W m))%Z. lia. @@ -310,42 +162,6 @@ Proof. destruct hlevels as [_ nw]. specialize (vm nw). depelim vm. lia. } Qed. -Module ClausesOrd := OrdProperties Clauses. - - -#[local] Instance check_model_aux_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model_aux. -Proof. - intros cls cls' eq. - intros wm wm' eq'. subst wm'. - unfold check_model_aux. - now eapply ClausesOrd.fold_equal; tc. -Qed. - -(* #[local] Instance check_model_aux_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> modified_levelset_m_eq) check_model_aux. -Proof. - intros cls cls' eq. - intros wm wm' eq'. - transitivity (check_model_aux cls' wm). - 2:{ unfold check_model_aux. - eapply (ClausesProp.fold_init (eqA := modified_levelset_m_eq)); tc. - red. cbn => //. } - unfold check_model_aux. - now eapply ClausesOrd.fold_equal; tc. -Qed. *) - -(* -#[local] Instance check_model_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model. -Proof. - intros cls cls' eq. - intros wm wm' eq'. - unfold check_model. - now subst wm'; rewrite eq. -Qed. *) - -Definition is_update_of cls upd minit m := - if LevelSet.is_empty upd then minit =m m - else strictly_updates cls upd minit m. - Record valid_model_def (V W : LevelSet.t) (m : model) (cls : clauses) := { model_model : model; model_of_V :> model_of V model_model; @@ -362,612 +178,8 @@ Extraction Inline model_model. Definition valid_model := valid_model_def. -Definition add_expr n '((l, k) : LevelExpr.t) := (l, k + n). - -Lemma add_expr_add_expr n n' lk : add_expr n (add_expr n' lk) = add_expr (n + n') lk. -Proof. destruct lk; unfold add_expr. f_equal; lia. Qed. -Definition add_prems n s := map (add_expr n) s. - -Lemma In_add_prems k (prems : premises): - forall le, LevelExprSet.In le (add_prems k prems) <-> - exists le', LevelExprSet.In le' prems /\ le = add_expr k le'. -Proof. - intros [l k']. - now rewrite /add_prems map_spec. -Qed. - - -Lemma map_map f g x : map f (map g x) = map (f ∘ g) x. -Proof. - apply eq_univ_equal. - intros lk. - rewrite !map_spec. setoid_rewrite map_spec. - firstorder eauto. subst. firstorder. -Qed. - -Lemma add_expr_inj {n e e'} : add_expr n e = add_expr n e' -> e = e'. -Proof. - destruct e, e'; cbn; intros [=]. - have eq: z = z0 by lia. - now subst z0. -Qed. - -Lemma add_prems_inj n prems prems' : add_prems n prems = add_prems n prems' -> prems = prems'. -Proof. - rewrite /add_prems => /eq_univ_equal hm. - apply eq_univ_equal. - intros [l k]. specialize (hm (l, k + n)). - rewrite !map_spec in hm. destruct hm as [hl hr]. - split; intros hin. - - forward hl. exists (l, k); split => //. - destruct hl as [[] [hin' eq]]. - apply (@add_expr_inj n (l, k)) in eq. now noconf eq. - - forward hr. exists (l, k); split => //. - destruct hr as [[] [hin' eq]]. - apply (@add_expr_inj n (l, k)) in eq. now noconf eq. -Qed. - -Lemma add_prems_add_prems n n' lk : add_prems n (add_prems n' lk) = add_prems (n + n') lk. -Proof. destruct lk; unfold add_prems. - rewrite map_map. apply eq_univ_equal. - intros x. rewrite !map_spec. cbn in *. - firstorder eauto. subst. exists x0. - firstorder eauto. now rewrite add_expr_add_expr. - subst. exists x0. - firstorder eauto. now rewrite add_expr_add_expr. -Qed. - -Definition add_clause n '((prems, concl) : clause) := (add_prems n prems, add_expr n concl). - -Lemma add_clause_add_clause n n' cl : add_clause n (add_clause n' cl) = add_clause (n + n') cl. -Proof. - destruct cl. - unfold add_clause. - now rewrite add_prems_add_prems add_expr_add_expr. -Qed. - -Notation succ_expr := (add_expr 1). -Notation succ_prems := (add_prems 1). -Notation succ_clause := (add_clause 1). - -Arguments add_prems : simpl never. - -Lemma pair_inj {A B} (x x' : A) (y y' : B) P : - (x = x' -> y = y' -> P) -> - ((x, y) = (x', y') -> P). -Proof. - now intros h [=]. -Qed. - -Lemma add_clause_inj {n x y} : add_clause n x = add_clause n y -> x = y. -Proof. - destruct x as [prems concl], y as [prems' concl']. cbn. - apply: pair_inj. now move=> /add_prems_inj -> /add_expr_inj ->. -Qed. -Definition add_clauses n cls := ClausesProp.of_list (List.map (fun cl => add_clause n cl) (ClausesProp.to_list cls)). -Notation succ_clauses := (add_clauses 1). -Import SetoidList. - -Lemma add_clauses_spec {cl cls} n : Clauses.In cl cls <-> Clauses.In (add_clause n cl) (add_clauses n cls). -Proof. - unfold succ_clauses. - rewrite ClausesProp.of_list_1 InA_In_eq in_map_iff. - firstorder eauto. - - exists cl; split => //. unfold ClausesProp.to_list. now eapply Clauses_In_elements. - - eapply Clauses_In_elements in H0. apply add_clause_inj in H. now subst. -Qed. - -Lemma in_add_clauses {cl cls} n : Clauses.In cl (add_clauses n cls) -> exists cl', Clauses.In cl' cls /\ cl = add_clause n cl'. -Proof. - unfold succ_clauses. - rewrite ClausesProp.of_list_1 InA_In_eq in_map_iff. - firstorder eauto. - exists x; split => //. unfold ClausesProp.to_list. now eapply Clauses_In_elements. -Qed. - -Variant in_pred_closure cls : clause -> Prop := -| incls cl n : Clauses.In cl cls -> in_pred_closure cls (add_clause n cl) -| predcl x k : in_pred_closure cls (singleton (x, k + 1), (x, k)). -Derive Signature for in_pred_closure. - -Inductive entails (cls : clauses) : clause -> Prop := -| clause_in (prems : premises) (concl : LevelExpr.t) : - LevelExprSet.In concl prems -> entails cls (prems, concl) -| clause_cut prems' concl' prems concl : - in_pred_closure cls (prems', concl') -> - entails cls (add concl' prems, concl) -> - LevelExprSet.Subset prems' prems -> - entails cls (prems, concl). - -Definition entails_all cls (prems concls : premises) := - LevelExprSet.For_all (fun le => entails cls (prems, le)) concls. - -Notation " cls ⊢ prems → concl " := (entails cls (prems, concl)) (at level 20). -Notation " cls ⊢a prems → concl " := (entails_all cls prems concl) (at level 20). - -Lemma in_pred_closure_equal cls (prems prems' : premises) concl : - LevelExprSet.Equal prems prems' -> - in_pred_closure cls (prems, concl) -> in_pred_closure cls (prems', concl). -Proof. - intros eq. apply NonEmptySetFacts.eq_univ_equal in eq. now subst prems. -Qed. - -Lemma entails_equal cls (prems prems' : premises) concl : - LevelExprSet.Equal prems prems' -> - entails cls (prems, concl) -> entails cls (prems', concl). -Proof. - intros he en. - replace prems' with prems => //. - now apply eq_univ_equal. -Qed. - -Lemma entails_plus cls c : entails cls c -> entails (succ_clauses cls) (succ_clause c). -Proof. - induction 1. - - constructor. apply map_spec. exists concl0. split => //. - - eapply clause_cut with (succ_prems prems') (succ_expr concl'). - + depelim H. - * have -> : (succ_prems prems', succ_expr concl') = add_clause n (succ_clause cl). - { destruct cl as [prems'' concl'']. cbn in H0. noconf H0. - rewrite add_prems_add_prems add_expr_add_expr add_clause_add_clause. - now rewrite Z.add_1_r Z.add_1_l. } - constructor. now rewrite -add_clauses_spec. - * have eq : (succ_prems (singleton (x, (k + 1)))) = (singleton (x, k + 1 + 1)). - { apply eq_univ_equal. unfold succ_prems. - intros le. rewrite map_spec LevelExprSet.singleton_spec. - split. - { intros [? [hin ->]]. - rewrite LevelExprSet.singleton_spec in hin. red in hin; subst x0. - reflexivity. } - { unfold LevelExprSet.E.eq. intros ->. - exists (x, k + 1). split. - now rewrite LevelExprSet.singleton_spec. reflexivity. } } - rewrite eq. constructor 2. - + unfold succ_clause in IHentails. - eapply entails_equal; tea. - intros x. rewrite /succ_prems. rewrite map_spec add_spec. - setoid_rewrite add_spec. rewrite map_spec. - firstorder eauto. subst. now left. - + intros x. rewrite /succ_prems !map_spec. - intros [e [hin ->]]. exists e. firstorder. -Qed. - - -Derive Signature for entails. - -Lemma entails_pred_closure {cls prems concl k} : - cls ⊢ prems → (concl, 1 + k) -> cls ⊢ prems → (concl, k). -Proof. - intros he. - Opaque Z.add. - depind he. - - eapply clause_cut. - constructor. - 2:{ intros l hin. rewrite LevelExprSet.singleton_spec in hin. red in hin; subst l. - rewrite Z.add_comm; exact H. } - constructor. - rewrite LevelExprSet.add_spec. lesets. - - eapply clause_cut; tea. -Qed. - -Lemma entails_pred_closure_n {cls prems concl k n} : - entails cls (prems, (concl, k + Z.of_nat n)) -> entails cls (prems, (concl, k)). -Proof. - induction n in k |- *. - - rewrite Z.add_0_r. tauto. - - intros hen. rewrite Nat2Z.inj_succ in hen. rewrite Z.add_succ_r in hen. - eapply IHn. move: hen. - have -> : Z.succ (k + Z.of_nat n) = 1 + (k + Z.of_nat n) by lia. - eapply entails_pred_closure. -Qed. - -Lemma add_clause_0 cl : add_clause 0 cl = cl. -Proof. - destruct cl as [prems [concl k]]; cbn. - f_equal. 2:now rewrite Z.add_0_r. - unfold add_prems. - eapply eq_univ_equal. intros [l k']. - rewrite NonEmptySetFacts.map_spec. - unfold add_expr. split. - - intros [[] [hin heq]]. noconf heq. now rewrite Z.add_0_r. - - exists (l, k'); split => //. now rewrite Z.add_0_r. -Qed. - -Lemma incls0 {cls cl} : Clauses.In cl cls -> in_pred_closure cls cl. -Proof. - intros hin. - have hcl := incls _ _ 0 hin. - now rewrite add_clause_0 in hcl. -Qed. - -Lemma entails_in {cls cl} : Clauses.In cl cls -> entails cls cl. -Proof. - intros hin. - destruct cl as [prems concl]. - eapply clause_cut. - - now eapply incls0. - - constructor. eapply LevelExprSet.add_spec. now left. - - reflexivity. -Qed. - - - -Lemma in_pred_closure_shift {cls cl} n : in_pred_closure cls cl -> in_pred_closure cls (add_clause n cl). -Proof. - destruct 1. - - rewrite add_clause_add_clause. now constructor. - - cbn. eapply in_pred_closure_equal with (singleton (x, k + 1 + n)). - { intros le. rewrite In_add_prems; rewrite_strat (topdown LevelExprSet.singleton_spec). - intuition auto. exists (x, k + 1). split => //. - now destruct H as [le' [-> ->]]. } - have -> : k + 1 + n = (k + n) + 1 by lia. - constructor. -Qed. - -Lemma add_clause_singleton n le concl k : add_clause n (singleton le, (concl, k)) = (singleton (add_expr n le), (concl, k + n)). -Proof. - rewrite /add_clause //=. f_equal. - apply eq_univ_equal. intros le'. rewrite In_add_prems. - rewrite_strat (topdown LevelExprSet.singleton_spec). - unfold LevelExprSet.E.eq. firstorder. subst. reflexivity. -Qed. - -Lemma entails_shift {cls cl} n : entails cls cl -> entails cls (add_clause n cl). -Proof. - induction 1. - - unfold add_clause. constructor. - rewrite In_add_prems. exists concl0. split => //. - - eapply (clause_cut _ (add_prems n prems') (add_expr n concl')). - 2:{ unfold add_clause in *. eapply entails_equal; tea. - intros le. setoid_rewrite In_add_prems. setoid_rewrite LevelExprSet.add_spec. - setoid_rewrite In_add_prems. - unfold LevelExprSet.E.eq. firstorder. subst. now left. } - 2:{ intros x. rewrite !In_add_prems. firstorder. } - eapply (in_pred_closure_shift _ H). -Qed. - -Lemma entails_subset cls (prems prems' : premises) concl : LevelExprSet.Subset prems prems' -> - entails cls (prems, concl) -> - entails cls (prems', concl). -Proof. - intros hsubt. - intros H; revert prems' hsubt; depind H. - - constructor. eapply hsubt, H. - - intros prems'' hsub. - eapply clause_cut. 2:eapply IHentails. tea. - 2:lesets. intros x; rewrite !LevelExprSet.add_spec. firstorder. -Qed. - -Lemma entails_trans {cls prems concl concl'} : - entails cls (prems, concl) -> - entails cls (singleton concl, concl') -> - entails cls (prems, concl'). -Proof. - intros H; depind H. - - intros he. - depelim he. - * rewrite LevelExprSet.singleton_spec in H0. red in H0; subst concl0. - now constructor. - * eapply (clause_cut _ prems'). tea. - eapply entails_subset; tea. - intros ?; rewrite !LevelExprSet.add_spec LevelExprSet.singleton_spec; firstorder. - red in H2; subst a. now right. intros x. firstorder. apply H1 in H2. - rewrite LevelExprSet.singleton_spec in H2. now red in H2; subst x. - - intros he. - specialize (IHentails concl'0 he). - eapply clause_cut; tea. -Qed. - -Lemma entails_weak {cls prem concl concl'} : - entails cls (prem, concl) -> - entails cls (add concl' prem, concl). -Proof. - intros H. depind H. - - constructor. apply LevelExprSet.add_spec. now right. - - eapply (clause_cut _ _ concl'); tea. - rewrite add_comm. apply IHentails. - intros x; rewrite LevelExprSet.add_spec. firstorder. -Qed. - -Lemma entails_weak_union {cls prem concl concl'} : - entails cls (prem, concl) -> - entails cls (univ_union concl' prem, concl). -Proof. - intros hyp. - move: concl'. - apply: premises_elim. - - intros le. rewrite univ_union_comm univ_union_add_singleton. - now apply entails_weak. - - intros le prems ih. - rewrite univ_union_add_distr. intros _. - now eapply entails_weak. -Qed. - -Lemma entails_all_weak {cls prem concl concl'} : - entails_all cls prem concl -> - entails_all cls (add concl' prem) concl. -Proof. - intros hcl x hin. - specialize (hcl _ hin). cbn in hcl. - now apply entails_weak. -Qed. - -Lemma entails_all_weak_union {cls prem concl concl'} : - entails_all cls prem concl -> - entails_all cls (univ_union concl' prem) concl. -Proof. - intros hcl x hin. - specialize (hcl _ hin). cbn in hcl. - now apply entails_weak_union. -Qed. - -Lemma entails_all_weak' {cls prem concl concl'} : - entails_all cls prem concl -> - entails_all cls (add concl' prem) (add concl' concl). -Proof. - intros hcl x hin. - eapply LevelExprSet.add_spec in hin as []. red in H; subst. - - constructor. eapply LevelExprSet.add_spec. now left. - - specialize (hcl _ H). cbn in hcl. - now apply entails_weak. -Qed. - -Lemma entails_cut_all {cls prems' concl' prems concls} : - in_pred_closure cls (prems', concl') -> - cls ⊢a add concl' prems → concls -> - prems' ⊂_leset prems -> - cls ⊢a prems → concls. -Proof. - intros inp he hp x hin. - eapply clause_cut; tea. - now apply he in hin. -Qed. - -Lemma entails_all_subset {cls} {prems prems' prems'' : premises} : - prems'' ⊂_leset prems' -> - cls ⊢a prems → prems' -> - cls ⊢a prems → prems''. -Proof. - intros incl ha x hin. - eapply incl in hin. now apply ha in hin. -Qed. - -(* Lemma entails_all_one {cls prems concl concl'} : - entails_all cls prems concl -> - entails cls (univ_union concl prems, concl') -> - entails cls (prems, concl'). -Proof. - intros hall he; depind he. - - eapply LevelExprSet.union_spec in H as []. - 2:now constructor. - now eapply hall in H. - - eapply clause_cut in he; tea. 3:reflexivity. specialize (IHhe _ _ concl0 hall). *) - -Lemma entails_all_add cls prem l prems' : - cls ⊢a prem → add l prems' <-> - cls ⊢ prem → l /\ cls ⊢a prem → prems'. -Proof. - rewrite /entails_all /LevelExprSet.For_all. - setoid_rewrite LevelExprSet.add_spec; rewrite /LevelExprSet.E.eq. - firstorder. now subst. -Qed. - -Lemma entails_add {cls prems cl concl} : - entails cls (prems, cl) -> - entails cls (add cl prems, concl) -> - entails cls (prems, concl). -Proof. - intros H; depind H. - - intros he. - depelim he. - * rewrite LevelExprSet.add_spec in H0. destruct H0 as []. - { red in H0; subst concl0. now constructor. } - { now constructor. } - * have eq : prems = add concl0 prems. - { eapply eq_univ_equal. intros x; rewrite LevelExprSet.add_spec. firstorder. now red in H2; subst. } - rewrite -eq in H1. - eapply (clause_cut _ prems' _ prems). tea. 2:tea. - now rewrite -eq in he. - - intros he. - eapply clause_cut. tea. eapply IHentails. - rewrite add_comm. now eapply entails_weak. - exact H1. -Qed. - -Lemma entails_cumul_one {cls prems prems' concl} : - entails_all cls prems prems' -> - entails cls (univ_union prems prems', concl) -> - entails cls (prems, concl). -Proof. - revert prems' prems concl. - apply: premises_elim. - - intros. specialize (H le). forward H by now apply LevelExprSet.singleton_spec. - cbn in H. - eapply entails_add; tea. - now rewrite -univ_union_add_singleton. - - intros le prems ih _ prem concl' hadd hadd'. - rewrite univ_union_comm univ_union_add_distr -univ_union_comm -univ_union_add_distr in hadd'. - eapply ih in hadd'. 2:{ apply entails_all_weak. apply entails_all_add in hadd as []. exact H0. } - apply entails_all_add in hadd as []. - eapply entails_add; tea. -Qed. - -Lemma entails_all_cumul {cls prems prems' concl} : - entails_all cls prems prems' -> - entails_all cls (univ_union prems prems') concl -> - entails_all cls prems concl. -Proof. - intros hp hc. - intros x hin. apply hc in hin. - eapply entails_cumul_one; tea. -Qed. - -Lemma entails_all_one {cls prem concl concl'} : - entails_all cls prem concl -> - entails cls (concl, concl') -> - entails cls (prem, concl'). -Proof. - intros ha he. - eapply entails_cumul_one; tea. - now eapply entails_weak_union. -Qed. - -Lemma entails_all_trans {cls prem concl concl'} : - entails_all cls prem concl -> - entails_all cls concl concl' -> - entails_all cls prem concl'. -Proof. - intros ha he cl hin. - apply he in hin. - eapply entails_all_one; tea. -Qed. - -Lemma entails_incr_shift cls concl k n : - entails cls (singleton (concl, k), (concl, k + 1)) -> - entails cls (singleton (concl, k), (concl, k + 1 + Z.of_nat n)). -Proof. - induction n in k |- *; auto. - - now rewrite Z.add_0_r. - - intros en. - have hs := entails_shift 1 en. rewrite add_clause_singleton /= in hs. - apply IHn in hs. - eapply entails_trans; tea. - now have -> : k + 1 + Z.of_nat (S n) = k + 1 + 1 + Z.of_nat n by lia. -Qed. - -Lemma entails_incr_all cls concl k : - entails cls (singleton (concl, k), (concl, k + 1)) -> - forall k', entails cls (singleton (concl, k), (concl, k')). -Proof. - intros en k'. - destruct (Z.lt_trichotomy k k') as [|[]]; subst; auto. - - have ispos : 0 <= k' - k - 1 by lia. - eapply (entails_incr_shift _ _ _ (Z.to_nat (k' - k - 1))) in en. - assert (k + 1 + Z.of_nat (Z.to_nat (k' - k - 1)) = k') by lia. now rewrite H0 in en. - - constructor. now rewrite LevelExprSet.singleton_spec. - - have [k0 ->] : (exists kd : nat, k = k' + Z.of_nat kd). { exists (Z.to_nat (k - k')). lia. } - eapply (entails_pred_closure_n (n:=k0)). constructor. now apply LevelExprSet.singleton_spec. -Qed. - -Lemma entails_all_concl_union {cls prems concl concl'} : - cls ⊢a prems → concl -> - cls ⊢a prems → concl' -> - cls ⊢a prems → univ_union concl concl'. -Proof. - intros l r. - rewrite /entails_all. - intros x. rewrite univ_union_spec. intros []. now apply l. now apply r. -Qed. - -Lemma entails_all_union {cls prems concl prems' concl'} : - cls ⊢a prems → concl -> - cls ⊢a prems' → concl' -> - cls ⊢a univ_union prems prems' → univ_union concl concl'. -Proof. - intros l r. - apply entails_all_concl_union. - rewrite univ_union_comm. - now eapply entails_all_weak_union. - now eapply entails_all_weak_union. -Qed. - - -Lemma entails_all_shift {cls : clauses} {prems concl : premises} (n : Z) : - cls ⊢a prems → concl -> - cls ⊢a add_prems n prems → add_prems n concl. -Proof. - intros cla cl. - rewrite In_add_prems => [[le' [hin ->]]]. - eapply (entails_shift (cl := (prems, le'))). - now apply cla in hin. -Qed. - -Lemma in_pred_closure_subset {cls cls' prems concl} : - in_pred_closure cls (prems, concl) -> - cls ⊂_clset cls' -> - in_pred_closure cls' (prems, concl). -Proof. - induction 1. - - move/(_ _ H). now constructor. - - constructor. -Qed. - -Lemma entails_clauses_subset cls cls' prems concl : - cls ⊢ prems → concl -> - cls ⊂_clset cls' -> - cls' ⊢ prems → concl. -Proof. - induction 1 in cls' |- * => incl. - - now constructor. - - eapply clause_cut. - + eapply in_pred_closure_subset; tea. - + now apply IHentails. - + assumption. -Qed. - -Lemma entails_all_clauses_subset cls cls' prems concl : - cls ⊢a prems → concl -> - cls ⊂_clset cls' -> - cls' ⊢a prems → concl. -Proof. - intros d incl [l k]. - now move/d/entails_clauses_subset. -Qed. - - -Definition to_clauses (prems : premises) (concl : premises) : clauses := - LevelExprSet.fold (fun lk cls => Clauses.add (prems, lk) cls) concl Clauses.empty. - -Definition is_loop (cls : clauses) (t : premises) := - let cls' := to_clauses t (succ_prems t) in - Clauses.For_all (fun cl' => entails cls cl') cls'. - -(* Definition is_looping (w : LevelSet.t) n (cls : clauses) := - let preml := LevelSet.elements w in - let prem := List.map (fun e => (e, n)) preml in - is_loop cls prem. *) - -Definition levelexprset_of_levels (ls : LevelSet.t) n : LevelExprSet.t := - LevelSet.fold (fun x => LevelExprSet.add (x, n)) ls LevelExprSet.empty. - -Lemma levelexprset_of_levels_spec {ls : LevelSet.t} {l k n} : - LevelExprSet.In (l, k) (levelexprset_of_levels ls n) <-> LevelSet.In l ls /\ k = n. -Proof. - rewrite /levelexprset_of_levels. - eapply LevelSetProp.fold_rec. - - intros s' he. rewrite LevelExprSetFact.empty_iff. firstorder. - - intros x a s' s'' hin hnin hadd ih. - rewrite LevelExprSet.add_spec; unfold LevelExprSet.E.eq. - firstorder eauto; try noconf H1 => //. - apply hadd in H1. firstorder. subst. now left. -Qed. - -#[program] -Definition of_level_set (ls : LevelSet.t) n (hne : ~ LevelSet.Empty ls) : premises := - {| t_set := levelexprset_of_levels ls n |}. -Next Obligation. - apply not_Empty_is_empty => he. apply hne. - intros l nin. specialize (he (l,n)). apply he. - now rewrite levelexprset_of_levels_spec. -Qed. - Definition loop_on_univ cls u := cls ⊢a u → succ_prems u. -(* Definition loop_on W (hne : ~ LevelSet.Empty W) n cls := - cls ⊢a of_level_set W n hne → of_level_set W (n + 1) hne. - -Lemma loop_on_proper W W' n hne' cls : W =_lset W' -> exists hne, loop_on W hne n cls -> loop_on W' hne' n cls. -Proof. - intros eq; rewrite /loop_on /loop_on_univ. - assert (hne : ~ LevelSet.Empty W). now rewrite eq. - exists hne. - assert (of_level_set W n hne = of_level_set W' n hne') as ->. - apply eq_univ_equal. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. - assert (of_level_set W (n + 1) hne = of_level_set W' (n + 1) hne') as ->. - apply eq_univ_equal. unfold of_level_set; cbn. intros []. rewrite !levelexprset_of_levels_spec. now rewrite eq. - by []. -Qed. *) - Lemma loop_on_subset {cls cls' u} : Clauses.Subset cls cls' -> loop_on_univ cls u -> loop_on_univ cls' u. Proof. intros sub; rewrite /loop_on_univ => hyp. @@ -987,8 +199,6 @@ Definition option_of_result {V U m cls} (r : result V U m cls) : option model := | Loop v _ => None end. -Notation "#| V |" := (LevelSet.cardinal V). - Notation loop_measure V W := (#|V|, #|V| - #|W|)%nat. Definition lexprod_rel := lexprod lt lt. @@ -998,40 +208,6 @@ Proof. eapply (Acc_intro_generator 1000). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. Defined. -Lemma strictly_updates_trans {cls cls' W W' m m' m''} : - strictly_updates cls W m m' -> - strictly_updates cls' W' m' m'' -> - strictly_updates (Clauses.union cls cls') (LevelSet.union W W') m m''. - Proof. - intros su su'. - eapply update_trans; eapply strictly_updates_weaken; tea; clsets. - Qed. - -Lemma check_model_is_update_of {cls cls' U W minit m m'} : is_update_of cls U minit m -> check_model cls' (U, m) = Some (W, m') -> - strictly_updates (Clauses.union cls cls') W minit m' /\ U ⊂_lset W. -Proof. - rewrite /is_update_of. - destruct LevelSet.is_empty eqn:he. - - intros ->. eapply LevelSetFact.is_empty_2 in he. - eapply LevelSetProp.empty_is_empty_1 in he. - eapply LevelSet.eq_leibniz in he. rewrite he. - move/check_model_updates_spec_empty. intros H; split => //. 2:lsets. - eapply strictly_updates_weaken; tea. clsets. - - intros hs. move/check_model_spec => [w'' [su ->]]. split; [|lsets]. - eapply strictly_updates_trans; tea. -Qed. - -Lemma is_update_of_case cls W m m' : - is_update_of cls W m m' -> - (LevelSet.Empty W /\ m =m m') \/ strictly_updates cls W m m'. -Proof. - rewrite /is_update_of. - destruct LevelSet.is_empty eqn:he. - - intros ->. left => //. now eapply LevelSetFact.is_empty_2 in he. - - intros H; now right. -Qed. - - Lemma model_incl {V W m cls} : valid_model V W m cls -> W ⊂_lset V. Proof. intros vm; have upd := model_updates vm. @@ -1040,31 +216,6 @@ Proof. - move/strictly_updates_incl. have hv := model_clauses_conclusions vm. lsets. Qed. -(* - model_of_W : model_of W model_model; - model_incl : ; -model_extends : model_extension V m model_model; - -Arguments model_of_W {V W m cls}. -Arguments model_incl {V W m cls}. -Arguments model_extends {V W m cls}. - *) - -Lemma model_of_ext {W m m'} : - model_of W m -> m ⩽ m' -> model_of W m'. -Proof. - intros mof ext. - intros k hin. destruct (mof k hin). specialize (ext _ _ H) as [k' []]. now exists k'. -Qed. - -Lemma defined_model_of_ext {W m m'} : - defined_model_of W m -> m ⩽ m' -> defined_model_of W m'. -Proof. - intros mof ext. - intros k hin. destruct (mof k hin). specialize (ext _ _ H) as [k' []]. - depelim H1. now exists y. -Qed. - Lemma valid_model_total W W' m cls : forall vm : valid_model W W' m cls, model_of W m -> model_of W (model_model vm). Proof. @@ -1075,417 +226,12 @@ Proof. eapply model_of_ext; tea. Qed. -Lemma is_update_of_ext {cls W m m'} : is_update_of cls W m m' -> m ⩽ m'. -Proof. - move/is_update_of_case => []. - - intros [he%LevelSetProp.empty_is_empty_1]. red. setoid_rewrite H. - move=> l k hm; exists k; split => //. reflexivity. - - apply strictly_updates_ext. -Qed. - -Lemma model_of_union {U V cls} : model_of U cls -> model_of V cls -> model_of (LevelSet.union U V) cls. -Proof. - intros hu hv x. - rewrite LevelSet.union_spec; move => [] hin. - now apply hu. now apply hv. -Qed. - -Lemma defined_model_of_union {U V cls} : - defined_model_of U cls -> - defined_model_of V cls -> - defined_model_of (LevelSet.union U V) cls. -Proof. - intros hu hv x. - rewrite LevelSet.union_spec; move => [] hin. - now apply hu. now apply hv. -Qed. - -Lemma model_of_union_inv U V cls : model_of (LevelSet.union U V) cls -> model_of U cls /\ model_of V cls. -Proof. - rewrite /model_of. - setoid_rewrite LevelSet.union_spec. firstorder. -Qed. - -Lemma defined_model_of_union_inv U V cls : - defined_model_of (LevelSet.union U V) cls -> - defined_model_of U cls /\ defined_model_of V cls. -Proof. - rewrite /defined_model_of. - setoid_rewrite LevelSet.union_spec. firstorder. -Qed. - -Lemma strictly_updates_model_of_gen cls W m m' : - strictly_updates cls W m m' -> - forall W', model_of W' m -> model_of (LevelSet.union W' W) m'. -Proof. - clear. - induction 1. - - intros W' tot x. - destruct cl as [prems [concl cl]]. - destruct H0 as [minv [hmin ? heq]]. setoid_rewrite heq. - setoid_rewrite LevelMapFact.F.add_in_iff. cbn. - destruct (Level.eq_dec concl x). - { now left. } - { rewrite LevelSet.union_spec; intros [hin|hin]. - { eapply tot in hin as [wit mt]. right; exists wit. assumption. } - { eapply LevelSet.singleton_spec in hin. red in hin; subst. congruence. } } - - intros W' tot. - eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. - eapply model_of_subset; tea. intros x; lsets. -Qed. - - -Lemma model_of_empty m : model_of LevelSet.empty m. -Proof. intros x; now move/LevelSet.empty_spec. Qed. - -Instance model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) model_of. -Proof. - intros ? ? H ? ? H'. unfold model_of. setoid_rewrite H. - now setoid_rewrite H'. -Qed. +Section InnerLoop. + Definition sum_W W (f : LevelSet.elt -> nat) : nat := + LevelSet.fold (fun w acc => acc + f w)%nat W 0%nat. -Lemma strictly_updates_total_model {cls W m m'} : - strictly_updates cls W m m' -> - model_of W m'. -Proof. - move/strictly_updates_model_of_gen/(_ LevelSet.empty). - intros H. forward H. apply model_of_empty. - rewrite LevelSetProp.empty_union_1 in H => //. lsets. -Qed. - -Lemma strictly_updates_only_model_gen cls W m m' : - strictly_updates cls W m m' -> - forall W', only_model_of W' m -> only_model_of (LevelSet.union W' W) m'. -Proof. - clear. - induction 1. - - intros W' tot x. - destruct cl as [prems [concl cl]]. - destruct H0 as [minv [hmin ? heq]]. setoid_rewrite heq. - setoid_rewrite LevelMapFact.F.add_mapsto_iff. cbn. - destruct (Level.eq_dec concl x). - { subst. rewrite LevelSet.union_spec LevelSet.singleton_spec. - firstorder; exists (Some (cl + minv)); left; split => //. } - { rewrite LevelSet.union_spec LevelSet.singleton_spec /LevelSet.E.eq. - firstorder. subst x. congruence. } - - intros W' tot. - eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. - eapply only_model_of_eq; tea. intros x; lsets. -Qed. - -Lemma is_update_of_total_model cls W m m' : is_update_of cls W m m' -> model_of W m'. -Proof. - move/is_update_of_case => []. - - intros [he eq]. - rewrite /model_of. lsets. - - eapply strictly_updates_total_model. -Qed. - -Lemma strict_update_modify m cl m' : strict_update m cl m' -> - exists k, LevelMap.Equal m' (LevelMap.add (clause_conclusion cl) k m). -Proof. - rewrite /strict_update. - destruct cl as [prems [concl k]]. - intros [v [hmin hab eq]]. now exists (Some (k + v)). -Qed. - -Lemma strictly_updates_model_of {cls W m m'} : - strictly_updates cls W m m' -> model_of W m'. -Proof. - move/strictly_updates_model_of_gen/(_ LevelSet.empty). - rewrite LevelSetProp.empty_union_1. lsets. - intros H; apply H. apply model_of_empty. -Qed. - -Lemma strictly_updates_modify {cls W m m'} : - strictly_updates cls W m m' -> - forall l k, LevelMap.MapsTo l k m' -> LevelSet.In l W \/ LevelMap.MapsTo l k m. -Proof. - induction 1. - + eapply strict_update_modify in H0 as [k eq]. - intros l k'. rewrite LevelSet.singleton_spec. - rewrite eq. - rewrite LevelMapFact.F.add_mapsto_iff. - intros [[]|] => //. red in H0; subst. - left. lsets. now right. - + intros. eapply IHstrictly_updates2 in H1. - destruct H1. left; lsets. - eapply IHstrictly_updates1 in H1 as []. left; lsets. - now right. -Qed. - -Lemma strictly_updates_modify_inv {cls W m m'} : - strictly_updates cls W m m' -> - forall l k, LevelMap.MapsTo l k m -> LevelSet.In l W \/ LevelMap.MapsTo l k m'. -Proof. - induction 1. - + eapply strict_update_modify in H0 as [k eq]. - intros l k'. rewrite LevelSet.singleton_spec. - rewrite eq. - rewrite LevelMapFact.F.add_mapsto_iff. - intros hm. unfold Level.eq. - destruct (eq_dec l (clause_conclusion cl)). subst. now left. - right. right. auto. - + intros. eapply IHstrictly_updates1 in H1 as []. - left; lsets. - eapply IHstrictly_updates2 in H1 as []. left; lsets. - now right. -Qed. - -Lemma strictly_updates_outside cls W m m' : - strictly_updates cls W m m' -> model_map_outside W m m'. -Proof. - move=> su. - have lr := strictly_updates_modify su. - have rl := strictly_updates_modify_inv su. - intros l nin k. - split; intros. - - apply rl in H as [] => //. - - apply lr in H as [] => //. -Qed. - -Lemma valid_model_model_map_outside {W W' m cls} (vm : valid_model W W' m cls) : model_map_outside W m (model_model vm). -Proof. - destruct vm as [m' mV mupd mcls mok]; cbn. - - move/is_update_of_case: mupd => []. - * intros [ne <-]. red. intros. reflexivity. - * intros su. eapply (model_map_outside_weaken (W:=W')). - 2:{ eapply strictly_updates_incl in su. lsets. } - clear -su. revert su. - eapply strictly_updates_outside. -Qed. - - -Lemma check_model_has_invariants {cls w m w' m'} : - model_of (clauses_conclusions cls) m -> - model_of w m -> - check_model cls (w, m) = Some (w', m') -> - check_model_invariants cls w m w' m' true. -Proof. - intros mof tot. - move/check_model_spec => [w'' [su ->]]. - cbn. split. - - lsets. - - apply strictly_updates_incl in su. lsets. - - clear -su. induction su. - * exists cl. split => //. now eapply strict_update_invalid. - unfold clause_conclusion. lsets. - destruct cl as [prems [concl k]]. - destruct H0 as [minp [hin hnabove habove]]. - move: hnabove habove. rewrite /level_value_above. - cbn. destruct level_value eqn:hv => //; try constructor. - intros hle. intros ->. rewrite level_value_add. constructor. - move/negbTE: hle. lia. - * destruct IHsu1 as [cl []]. - exists cl. split => //. lsets. - apply strictly_updates_ext in su2. - depelim H2; rewrite ?H3. 2:{ rewrite H2; constructor. } - eapply level_value_MapsTo', su2 in H4 as [k' [map le]]. - eapply level_value_MapsTo in map. rewrite map. depelim le. constructor; lia. - - constructor. now eapply strictly_updates_ext. - clear -mof su. - induction su. - * move: H0; unfold strict_update. destruct cl as [prems [concl k]]. - intros [v [hmi nabove eqm]]. intros l. rewrite eqm. - rewrite LevelMapFact.F.add_in_iff. specialize (mof l). - rewrite clauses_conclusions_spec in mof. firstorder. - * specialize (IHsu1 mof). transitivity m' => //. - apply IHsu2. intros l hin. specialize (mof _ hin). now apply IHsu1 in mof. - * eapply model_map_outside_weaken. now eapply strictly_updates_outside. lsets. - - eapply strictly_updates_model_of_gen in su; tea. -Qed. - -Lemma clauses_levels_conclusions cls V : clauses_levels cls ⊂_lset V -> - clauses_conclusions cls ⊂_lset V. -Proof. - intros hin x; rewrite clauses_conclusions_spec; move => [cl [hin' eq]]; apply hin. - rewrite clauses_levels_spec. exists cl. split => //. subst x. - rewrite clause_levels_spec. now right. -Qed. -Definition clauses_premises_levels (cls : clauses) : LevelSet.t := - Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls LevelSet.empty. - -Lemma clauses_premises_levels_spec_aux l cls acc : - LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls acc) <-> - (exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl))) \/ LevelSet.In l acc. -Proof. - eapply ClausesProp.fold_rec. - - intros. - intuition auto. destruct H1 as [k [hin hl]]. clsets. - - intros x a s' s'' hin nin hadd ih. - rewrite LevelSet.union_spec. - split. - * intros [hin'|]. - left. exists x. split => //. - apply hadd. now left. - apply ih in H. - intuition auto. - left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. - * intros [[k [ins'' ?]]|inacc]. - eapply hadd in ins''. destruct ins''; subst. - + now left. - + right. apply ih. now left; exists k. - + right. intuition auto. -Qed. - -Lemma clauses_premises_levels_spec l cls : - LevelSet.In l (clauses_premises_levels cls) <-> - exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl)). -Proof. - unfold clauses_premises_levels. - rewrite clauses_premises_levels_spec_aux. - intuition auto. lsets. -Qed. - -Lemma clauses_levels_premises cls V : clauses_levels cls ⊂_lset V -> - clauses_premises_levels cls ⊂_lset V. -Proof. - intros hin x; rewrite clauses_premises_levels_spec; move => [cl [hin' eq]]; apply hin. - rewrite clauses_levels_spec. exists cl. split => //. - rewrite clause_levels_spec. now left. -Qed. - -Lemma clauses_premises_levels_incl cls : clauses_premises_levels cls ⊂_lset clauses_levels cls. -Proof. - intros x; rewrite clauses_premises_levels_spec clauses_levels_spec; move => [cl [hin' eq]]. - exists cl; split => //. - rewrite clause_levels_spec. now left. -Qed. - -Lemma clauses_premises_levels_mon {cls cls'} : cls ⊂_clset cls' -> - clauses_premises_levels cls ⊂_lset clauses_premises_levels cls'. -Proof. - intros hin x; rewrite !clauses_premises_levels_spec; move => [cl [hin' eq]]. - exists cl; split => //. now apply hin. -Qed. - -Definition monotone_selector sel := - forall cls' cls, cls' ⊂_clset cls -> sel cls' ⊂_lset sel cls. - -Lemma clauses_levels_mon : monotone_selector clauses_levels. -Proof. - intros cls' cls hin x; rewrite !clauses_levels_spec; move => [cl [hin' eq]]. - exists cl; split => //. now apply hin. -Qed. - -Definition infers_atom (m : model) (l : Level.t) (k : Z) := Some k ≤ level_value m l. - -Definition max_premise_model cls sel m := - (forall l, LevelSet.In l (sel cls) -> - LevelMap.MapsTo l (max_clause_premise cls) m) /\ - (forall l k, LevelMap.MapsTo l k m -> LevelSet.In l (sel cls) /\ k = max_clause_premise cls). - -(* Definition max_premise_map cls : model := - let max := max_clause_premise cls in - let ls := clauses_levels cls in - LevelSet.fold (fun l acc => LevelMap.add l max acc) ls (LevelMap.empty _). - -Definition above_max_premise_model cls m := - (exists V, strictly_updates cls V (max_premise_map cls) m) \/ m = max_premise_map cls. - -Lemma max_premise_model_exists cls : max_premise_model cls clauses_levels (max_premise_map cls). -Proof. - rewrite /max_premise_map; split. - - intros l. - eapply LevelSetProp.fold_rec. - { intros s he hin. now apply he in hin. } - intros. - destruct (Level.eq_dec l x). subst. - * eapply LevelMapFact.F.add_mapsto_iff. left; split => //. - * eapply LevelMapFact.F.add_mapsto_iff. right. split => //. now unfold Level.eq. apply H2. - specialize (H1 l). apply H1 in H3. destruct H3 => //. congruence. - - intros l k. - eapply LevelSetProp.fold_rec. - { intros s' he hm. now eapply LevelMapFact.F.empty_mapsto_iff in hm. } - intros. - eapply LevelMapFact.F.add_mapsto_iff in H3 as []. - * destruct H3. noconf H4. split => //. apply H1. now left. - * destruct H3. firstorder. -Qed. *) - -Lemma infer_atom_downward {m l k k'} : - infers_atom m l k -> - (k' <= k) -> - infers_atom m l k'. -Proof. - rewrite /infers_atom. - intros infa le. - transitivity (Some k) => //. now constructor. -Qed. - -Lemma infers_atom_le {m m' l k} : - infers_atom m l k -> - m ⩽ m' -> - infers_atom m' l k. -Proof. - rewrite /infers_atom. - intros infa le. - depelim infa. eapply level_value_MapsTo' in H0. eapply le in H0 as [k' [hm hle]]. - rewrite (level_value_MapsTo hm). depelim hle; constructor; lia. -Qed. - -Lemma infers_atom_mapsto m l k : infers_atom m l k <-> - exists k', LevelMap.MapsTo l k' m /\ (Some k ≤ k'). -Proof. - rewrite /infers_atom; split. - - intros hle; depelim hle. - eapply level_value_MapsTo' in H0. exists (Some y). split => //. - now constructor. - - intros [k' [hm hle]]. - eapply level_value_MapsTo in hm. now rewrite hm. -Qed. - -(* Lemma above_max_premise_model_infers {cls m} : - above_max_premise_model cls m -> - (forall l, LevelSet.In l (clauses_levels cls) -> infers_atom m l (max_clause_premise cls)). -Proof. - intros ha l hl. - have hm := max_premise_model_exists cls. - destruct ha as [[V su]|eq]. - * eapply strictly_updates_ext in su. - eapply infers_atom_le; tea. - eapply infers_atom_mapsto. - destruct hm. exists (max_clause_premise cls). split => //. - now eapply H. reflexivity. - * subst m. eapply infers_atom_mapsto. destruct hm. - specialize (H l hl). eexists; split. exact H. lia. -Qed. *) - -Lemma clauses_with_concl_union cls W W' : - Clauses.Equal (clauses_with_concl cls (LevelSet.union W W')) - (Clauses.union (clauses_with_concl cls W) (clauses_with_concl cls W')). -Proof. - intros x. rewrite Clauses.union_spec !in_clauses_with_concl LevelSet.union_spec. - firstorder. -Qed. - -Lemma strictly_updates_strenghten {cls W m m'} : - strictly_updates cls W m m' -> - strictly_updates (cls ↓ W) W m m'. -Proof. - induction 1. - - constructor. rewrite in_clauses_with_concl. split => //. - eapply LevelSet.singleton_spec; reflexivity. exact H0. - - rewrite clauses_with_concl_union. econstructor 2. - eapply strictly_updates_weaken; tea. intros x; clsets. - eapply strictly_updates_weaken; tea. intros x; clsets. -Qed. - -Lemma clauses_with_concl_subset cls W : (cls ↓ W) ⊂_clset cls. -Proof. now intros ?; rewrite in_clauses_with_concl. Qed. - -Section InnerLoop. - Definition sum_W W (f : LevelSet.elt -> nat) : nat := - LevelSet.fold (fun w acc => acc + f w)%nat W 0%nat. - - Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := - sum_W W (fun w => Z.to_nat (measure_w W cls m w)). - - Lemma maps_to_value_default {x k m} : LevelMap.MapsTo x k m -> level_value m x = k. - Proof. - intros h; apply LevelMap.find_1 in h. - now rewrite /level_value h. - Qed. + Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := + sum_W W (fun w => Z.to_nat (measure_w W cls m w)). Lemma measure_model W cls m : defined_model_of W m -> @@ -1503,9 +249,9 @@ Section InnerLoop. intros x a s' s'' inw nins' hadd ih heq. forward ih by lia. intros l hin. - specialize (hv _ inw) as [k lv]. rewrite /level_value_default (maps_to_value_default lv) in heq. + specialize (hv _ inw) as [k lv]. rewrite /level_value_default (level_value_MapsTo lv) in heq. apply hadd in hin as []. - * subst x. rewrite (maps_to_value_default lv). + * subst x. rewrite (level_value_MapsTo lv). constructor. lia. * now apply ih. } clear hm. @@ -1518,8 +264,8 @@ Section InnerLoop. destruct (proj1 (Clauses.diff_spec _ _ _) hl) as [hlcls hl']. eapply in_clauses_with_concl in hlcls as [lW incls]. specialize (H _ lW). cbn -[clsdiff] in H. cbn in lW. - specialize (hv _ lW) as [vl hvl]. rewrite /level_value_above (maps_to_value_default hvl). - rewrite (maps_to_value_default hvl) in H; depelim H. + specialize (hv _ lW) as [vl hvl]. rewrite /level_value_above (level_value_MapsTo hvl). + rewrite (level_value_MapsTo hvl) in H; depelim H. (* etransitivity; tea. *) set (prem' := non_W_atoms W prem). assert (ne : LevelExprSet.is_empty prem' = false). @@ -1574,15 +320,6 @@ Section InnerLoop. Lemma level_value_default_def {m x v} : level_value m x = Some v -> level_value_default m x = v. Proof. unfold level_value_default. now intros ->. Qed. - Lemma w_values_ext m m' W : - m ⩽ m' -> model_of W m -> model_of W m'. - Proof. - intros ext hf x hin. - specialize (hf x hin) as [k hl]. - specialize (ext _ _ hl) as [? []]. - now exists x0. - Qed. - Lemma level_values_in_W m m' W x : defined_model_of W m -> m ⩽ m' -> @@ -1590,13 +327,13 @@ Section InnerLoop. exists k k', level_value m x = Some k /\ level_value m' x = Some k' /\ (k <= k'). Proof. intros hwv ext hin hleq. - specialize (hwv _ hin) as x'. destruct x' as [k hl]. rewrite (maps_to_value_default hl) in hleq. + specialize (hwv _ hin) as x'. destruct x' as [k hl]. rewrite (level_value_MapsTo hl) in hleq. eapply defined_model_of_ext in ext; tea. specialize (ext _ hin) as [k' hl']. - rewrite (maps_to_value_default hl') in hleq. depelim hleq. + rewrite (level_value_MapsTo hl') in hleq. depelim hleq. do 2 eexists. intuition eauto. - now rewrite (maps_to_value_default hl). - now rewrite (maps_to_value_default hl'). + now rewrite (level_value_MapsTo hl). + now rewrite (level_value_MapsTo hl'). Qed. Lemma measure_le {W cls m m'} : @@ -1649,85 +386,6 @@ Section InnerLoop. lia. now eapply defined_model_of_value_None in H; tea. Qed. - Lemma is_model_equal {cls cls' m} : Clauses.Equal cls cls' -> is_model cls m -> is_model cls' m. - Proof. now intros ->. Qed. - - Lemma union_diff_eq {cls cls'} : Clauses.Equal (Clauses.union cls (Clauses.diff cls' cls)) - (Clauses.union cls cls'). - Proof. clsets. Qed. - - Lemma union_restrict_with_concl {cls W} : - Clauses.Equal (Clauses.union (cls ⇂ W) (cls ↓ W)) (cls ↓ W). - Proof. - intros cl. rewrite Clauses.union_spec. - intuition auto. - eapply in_clauses_with_concl. - now eapply in_restrict_clauses in H0 as []. - Qed. - - Lemma union_diff {cls W} : - Clauses.Equal (Clauses.union (Clauses.diff (cls ↓ W) (cls ⇂ W)) (cls ⇂ W)) (cls ↓ W). - Proof. - now rewrite ClausesProp.union_sym union_diff_eq union_restrict_with_concl. - Qed. - - Lemma union_diff_cls {cls W} : - Clauses.Equal (Clauses.union (Clauses.diff (cls ↓ W) (cls ⇂ W)) cls) cls. - Proof. - intros ?. rewrite Clauses.union_spec Clauses.diff_spec in_restrict_clauses in_clauses_with_concl. - firstorder. - Qed. - - Lemma maps_to_level_value x (m m' : model) : - (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> - level_value m x = level_value m' x. - Proof. - intros heq. - unfold level_value. - destruct LevelMap.find eqn:hl. - apply LevelMap.find_2 in hl. rewrite heq in hl. - rewrite (LevelMap.find_1 hl) //. - destruct (LevelMap.find x m') eqn:hl' => //. - apply LevelMap.find_2 in hl'. rewrite -heq in hl'. - now rewrite (LevelMap.find_1 hl') in hl. - Qed. - - Lemma measure_Z_lt x y : - (x < y)%Z -> - (0 < y)%Z -> - (Z.to_nat x < Z.to_nat y)%nat. - Proof. intros. lia. Qed. - - Lemma sum_pos W f : - (0 < sum_W W f)%nat -> - exists w, LevelSet.In w W /\ (0 < f w)%nat. - Proof. - unfold sum_W. - eapply LevelSetProp.fold_rec => //. - intros. lia. - intros. - destruct (Nat.ltb_spec 0 a). - - destruct (H2 H4) as [w [hin hlt]]. exists w. split => //. apply H1. now right. - - exists x. split => //. apply H1. now left. lia. - Qed. - - Lemma measure_pos {W cls m} : - (0 < measure W cls m)%nat -> - exists l, LevelSet.In l W /\ (0 < measure_w W cls m l)%Z. - Proof. - unfold measure. - move/sum_pos => [w [hin hlt]]. - exists w. split => //. lia. - Qed. - - Lemma model_of_diff cls W m : - model_of W m -> model_of (clauses_conclusions (cls_diff cls W)) m. - Proof. - intros; eapply model_of_subset; tea. - eapply clauses_conclusions_diff_left. - Qed. - Hint Resolve model_of_diff : core. - Lemma check_model_spec_diff {cls w m w' m' w''} : model_of w m -> model_of w'' m -> @@ -1747,525 +405,6 @@ Section InnerLoop. eapply model_of_subset. exact mof. tea. exact tot. Qed. - Lemma model_of_extension {W W' m m'} : - model_of W m -> model_extension W' m m' -> model_of W m'. - Proof. - intros mof [_ dom _]. - intros k hin. apply dom. now apply mof. - Qed. - - Lemma clauses_partition_spec {cls W allW conclW} : - clauses_conclusions cls ⊂_lset W -> - Clauses.partition (premise_restricted_to W) cls = (allW, conclW) -> - (Clauses.Equal allW (cls ⇂ W)) /\ - (Clauses.Equal conclW (Clauses.diff cls (cls ⇂ W))). - Proof. - intros clW. - destruct Clauses.partition eqn:eqp. - intros [= <- <-]. - change t with (t, t0).1. - change t0 with (t, t0).2 at 2. - rewrite -eqp. clear t t0 eqp. - split. - - intros cl. rewrite Clauses.partition_spec1. - rewrite in_restrict_clauses Clauses.filter_spec. - rewrite /premise_restricted_to LevelSet.subset_spec. firstorder eauto. - apply clW, clauses_conclusions_spec. now exists cl. - - intros cl. rewrite Clauses.partition_spec2. - rewrite Clauses.filter_spec Clauses.diff_spec. - rewrite /premise_restricted_to. intuition auto. - move/negbTE: H1. eapply eq_true_false_abs. - eapply LevelSet.subset_spec. - now eapply in_restrict_clauses in H as []. - apply eq_true_not_negb. move/LevelSet.subset_spec => he. - apply H1. apply in_restrict_clauses. split => //. - apply clW, clauses_conclusions_spec. now exists cl. - Qed. - - Lemma clauses_conclusions_eq cls W : - clauses_conclusions cls ⊂_lset W -> - Clauses.Equal cls (cls ↓ W). - Proof. - intros cl x. - rewrite in_clauses_with_concl. intuition auto. - apply cl, clauses_conclusions_spec. now exists x. - Qed. - - (* Inductive inner_result (V U : LevelSet.t) (cls : clauses) (m : model) := - | InLoop (w : LevelSet.t) (hne : ~ LevelSet.Empty w) (islooping : loop_on w hne cls) - | InModel (w : LevelSet.t) (m : valid_model V w m cls). - (* (prf : U ⊂_lset w /\ w ⊂_lset V). *) - Arguments InLoop {V U cls m}. - Arguments InModel {V U cls m}. *) - - Lemma is_update_of_empty cls m : - is_update_of cls LevelSet.empty m m. - Proof. - unfold is_update_of. - rewrite LevelSetFact.is_empty_1 //. lsets. - Qed. - - Lemma strictly_updates_W_eq cls W init m W' : - LevelSet.Equal W W' -> - strictly_updates cls W init m -> - strictly_updates cls W' init m. - Proof. now intros ->. Qed. - - Lemma strictly_updates_clauses_W cls cls' W init m W' : - Clauses.Subset cls cls' -> - LevelSet.Equal W W' -> - strictly_updates cls W init m -> - strictly_updates cls' W' init m. - Proof. intros hsub ->. now apply strictly_updates_weaken. Qed. - - Lemma strictly_updates_is_update_of cls W init m cls' W' m' : - strictly_updates cls W init m -> - is_update_of cls' W' m m' -> - strictly_updates (Clauses.union cls cls') (LevelSet.union W W') init m'. - Proof. - move=> su /is_update_of_case; intros [[empw eq]|su']. - rewrite <- eq. eapply (strictly_updates_weaken cls). clsets. - eapply strictly_updates_W_eq; tea. lsets. - eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. - Qed. - - Definition restrict_model W (m : model) := - LevelMapFact.filter (fun l k => LevelSet.mem l W) m. - - Lemma restrict_model_spec W m : - forall l k, LevelMap.MapsTo l k (restrict_model W m) <-> LevelMap.MapsTo l k m /\ LevelSet.In l W. - Proof. - intros l k; rewrite /restrict_model. - now rewrite LevelMapFact.filter_iff LevelSet.mem_spec. - Qed. - - (* Updates the entries in m with the values in m' if any *) - Definition model_update (m m' : model) : model := - LevelMap.mapi (fun l k => - match LevelMap.find l m' with - | Some k' => k' - | None => k - end) m. - - Instance model_update_proper : Proper (LevelMap.Equal ==> LevelMap.Equal ==> LevelMap.Equal) model_update. - Proof. - intros ? ? eq ? ? eq'. - rewrite /model_update. - apply LevelMapFact.F.Equal_mapsto_iff. - intros k e. - rewrite LevelMapFact.F.mapi_mapsto_iff. now intros ? ? ? ->. - rewrite LevelMapFact.F.mapi_mapsto_iff. now intros ? ? ? ->. - firstorder. exists x1. rewrite H. now rewrite -eq eq'. - rewrite H. exists x1. now rewrite eq -eq'. - Qed. - - Inductive findSpec l m : option (option Z) -> Prop := - | inm k : LevelMap.MapsTo l k m -> findSpec l m (Some k) - | ninm : ~ LevelMap.In l m -> findSpec l m None. - - Lemma find_spec l m : findSpec l m (LevelMap.find l m). - Proof. - destruct (LevelMap.find l m) eqn:heq; constructor. - now apply LevelMap.find_2. - now apply LevelMapFact.F.not_find_in_iff in heq. - Qed. - - Lemma model_update_spec m m' : - forall l k, LevelMap.MapsTo l k (model_update m m') <-> - (~ LevelMap.In l m' /\ LevelMap.MapsTo l k m) \/ - (LevelMap.MapsTo l k m' /\ LevelMap.In l m). - Proof. - intros l k; split. - - unfold model_update => hl. - eapply LevelMapFact.F.mapi_inv in hl as [a [k' [-> [eqk mt]]]]. - move: eqk; elim: (find_spec l m'). - + intros ? hm <-. right; split => //. now exists a. - + intros nin ->. left. split => //. - - intros [[nin hm]|[inm' inm]]. - * eapply LevelMapFact.F.mapi_mapsto_iff. now intros x y e ->. - elim: (find_spec l m'). - + intros k0 hm'. elim nin. now exists k0. - + intros _. exists k. split => //. - * eapply LevelMapFact.F.mapi_mapsto_iff. now intros x y e ->. - elim: (find_spec l m'). - + intros k0 hm'. destruct inm as [a inm]. exists a. split => //. - now eapply LevelMapFact.F.MapsTo_fun in inm'; tea. - + intros nin; elim nin. now exists k. - Qed. - - Lemma model_update_restrict m W : model_update m (restrict_model W m) =m m. - Proof. - apply LevelMapFact.F.Equal_mapsto_iff. intros l k. - rewrite model_update_spec. - split => //. - - intros [[nin hk]|[hr inm]] => //. - now eapply restrict_model_spec in hr. - - intros hm. - destruct (find_spec l (restrict_model W m)). - + right. apply restrict_model_spec in H as [hm' hw]. - split. eapply LevelMapFact.F.MapsTo_fun in hm; tea. subst. apply restrict_model_spec; split => //. - now exists k. - + left. split => //. - Qed. - - - Lemma min_premise_preserved {m m'} {prems : premises} : - (forall x, LevelSet.In x (levels prems) -> level_value m x = level_value m' x) -> - min_premise m prems = min_premise m' prems. - Proof. - intros hcl. - unfold min_premise. - funelim (to_nonempty_list prems). bang. clear H. - rw_in levelexprset_levels_spec hcl. - have -> : min_atom_value m e = min_atom_value m' e. - { destruct e as [k l']. - rewrite /min_atom_value. rewrite -hcl //. - exists l'. - apply LevelExprSet.elements_spec1. rewrite e0. now left. } - have cl' : forall x, (exists k, InA eq (x, k) l) -> level_value m x = level_value m' x. - { intros x [k ina]. apply hcl. exists k. apply LevelExprSet.elements_spec1. rewrite e0. now right. } - clear hcl Heqcall e0. - generalize (min_atom_value m' e). - induction l; cbn; auto. - have -> : min_atom_value m a = min_atom_value m' a. - { destruct a as [k l']. - rewrite /min_atom_value. rewrite cl' //. - exists l'. now left. } - intros o. - apply IHl. - intros x [k l']. apply cl'. exists k. now right. - Qed. - - - Lemma levelmap_find_eq {A} x (m m' : LevelMap.t A) : - (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> - LevelMap.find x m = LevelMap.find x m'. - Proof. - intros hm. - destruct (LevelMap.find x m) eqn:he; - destruct (LevelMap.find x m') eqn:he'. - all:try apply LevelMap.find_2 in he. all:try apply LevelMap.find_2 in he'. - apply hm in he. eapply LevelMapFact.F.MapsTo_fun in he; tea. congruence. - apply hm in he. apply LevelMapFact.F.not_find_in_iff in he'. firstorder. - apply LevelMapFact.F.not_find_in_iff in he. firstorder. congruence. - Qed. - - Lemma levelmap_level_value_eq x (m m' : model) : - (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> - level_value m x = level_value m' x. - Proof. - intros he. - rewrite /level_value. rewrite (levelmap_find_eq x m m') //. - Qed. - - Lemma levelmap_find_eq_inv {A} x (m m' : LevelMap.t A) : - LevelMap.find x m = LevelMap.find x m' -> - (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m'). - Proof. - intros hfind. - destruct (LevelMap.find x m) eqn:he; - destruct (LevelMap.find x m') eqn:he'. - all:try apply LevelMap.find_2 in he. all:try apply LevelMap.find_2 in he'. all:try congruence. - noconf hfind. intros k; split; intros. - eapply LevelMapFact.F.MapsTo_fun in he; tea. now subst. - eapply LevelMapFact.F.MapsTo_fun in he'; tea. now subst. - intros k; split; intros. - apply LevelMapFact.F.not_find_in_iff in he. firstorder. - apply LevelMapFact.F.not_find_in_iff in he'. firstorder. - Qed. - - Lemma min_premise_restrict m W (prems : premises) v : - (forall l k, LevelExprSet.In (l, k) prems -> LevelSet.In l W) -> - min_premise (restrict_model W m) prems = Some v -> - min_premise m prems = Some v. - Proof. - intros hin. - rewrite (@min_premise_preserved _ m) //. - move=> x. rewrite levelexprset_levels_spec => [] [k] /hin inW. - apply levelmap_level_value_eq => k'. - rewrite restrict_model_spec. firstorder. - Qed. - - Lemma model_of_model_update W m m' : - model_of W m -> - model_of W (model_update m m'). - Proof. - intros hm l hin. - move/hm: hin => [k hin]. - red. rw model_update_spec. - destruct (LevelMapFact.F.In_dec m' l). - - destruct i as [k' hin']. exists k'. right; split => //. now exists k. - - exists k; left; split => //. - Qed. - - Lemma strictly_updates_restrict_only_model {cls W m m'} : strictly_updates cls W m m' -> - only_model_of W (restrict_model W m'). - Proof. - intros su. red. rw restrict_model_spec. - split => //. 2:clear; firstorder. - eapply strictly_updates_total_model in su. move/[dup]/su. clear; firstorder. - Qed. - - Lemma only_model_of_restrict W m : - model_of W m -> only_model_of W (restrict_model W m). - Proof. - intros mof x. rw restrict_model_spec. firstorder. - Qed. - - Lemma strictly_updates_from_restrict {cls W W' m m'} : - clauses_conclusions cls ⊂_lset W -> - model_of W m -> - strictly_updates cls W' (restrict_model W m) m' -> - only_model_of W m'. - Proof. - intros hcls mof su. - have om := strictly_updates_only_model_gen _ _ _ _ su W. - apply strictly_updates_incl in su. - have hu : ((W ∪ W') =_lset W). intros x; lsets. - rewrite hu in om. apply om. - now apply only_model_of_restrict. - Qed. - - Lemma restrict_model_update W m m' : - model_of W m' -> - only_model_of W m -> - restrict_model W (model_update m' m) =m m. - Proof. - intros mof om. - intro l. apply levelmap_find_eq => k. - rewrite restrict_model_spec model_update_spec. split. - - move=> [] [[hnin hm] hin|hm hin]. - specialize (proj1 (om l) hin) as [x hm']. elim hnin. now exists x. - apply hm. - - move=> hm. split => //. 2:now apply om; exists k. - right; firstorder. - Qed. - - Lemma model_update_trans m upd upd' : - (forall l, LevelMap.In l upd -> LevelMap.In l upd') -> - model_update (model_update m upd) upd' =m model_update m upd'. - Proof. - intros hl l. apply levelmap_find_eq => k. - rewrite !model_update_spec /LevelMap.In. - rw model_update_spec. firstorder. - right. split => //. - destruct (LevelMapFact.F.In_dec upd l). - - destruct i as [updv hk]. - exists updv. firstorder. - - exists x; left; firstorder. - Qed. - - (* If we can update starting from a restricted model with no values outside [W], - this can be lifted to the unrestricted model, applying the same updates *) - Lemma strictly_updates_restrict_model_gen cls W W' m' : - forall cls' mr, - strictly_updates cls' W' mr m' -> - forall m, model_of W m -> - cls' = (cls ⇂ W) -> - mr =m (restrict_model W m) -> - strictly_updates (cls ⇂ W) W' m (model_update m m'). - Proof. - intros cls' mr. induction 1. - - intros mi mofW -> hm. - constructor. auto. - destruct cl as [prems [concl k]]. - destruct H0 as [v [hmin above heq]]. - rewrite hm in hmin, above. - exists v. split => //. - eapply min_premise_restrict with W => //. - { intros l k' hp. move/in_restrict_clauses: H => [] //= _ hsub _. apply hsub. - rewrite levelexprset_levels_spec. now exists k'. } - move: above. - rewrite /level_value_above /level_value. - elim: find_spec => //. - + intros kr hkr. - apply restrict_model_spec in hkr as [hkr hcl]. - now rewrite (LevelMap.find_1 hkr). - + move=> ncl _. - elim: find_spec => // => k' inm. - apply in_restrict_clauses in H as [inconcl inprems incls]. cbn in *. - elim ncl. exists k'. eapply restrict_model_spec. split => //. - + apply in_restrict_clauses in H as [inconcl inprems incls]. cbn in *. - rewrite heq. intro. apply levelmap_find_eq => k'. - rewrite hm. - rewrite model_update_spec !LevelMapFact.F.add_mapsto_iff restrict_model_spec. - rewrite LevelMapFact.F.add_in_iff /Level.eq. firstorder; subst. - right. split => //. left => //. now apply mofW. - destruct (inLevelSet W y). - * right. split. right => //. now exists k'. - * left. split => //. intros []. congruence. - destruct H2 as [yrest hin]. eapply restrict_model_spec in hin as []. contradiction. - - intros mtot mof -> hm. specialize (IHstrictly_updates1 mtot mof eq_refl hm). - specialize (IHstrictly_updates2 (model_update mtot m')). - have model_of : model_of W (model_update mtot m'). - by apply model_of_model_update. - specialize (IHstrictly_updates2 model_of eq_refl). - forward IHstrictly_updates2. - { rewrite hm in H. eapply strictly_updates_from_restrict in H; tea. - 2:eapply clauses_conclusions_restrict_clauses. - now rewrite restrict_model_update. } - eapply update_trans; tea. - have eqm : (model_update (model_update mtot m') m'') =m model_update mtot m''. - { eapply model_update_trans. eapply strictly_updates_ext in H0. - intros l [k hin]. apply H0 in hin as [k' []]. now exists k'. } - now rewrite eqm in IHstrictly_updates2. - Qed. - - Lemma strictly_updates_restrict_model cls W W' m' : - forall m, model_of W m -> - strictly_updates (cls ⇂ W) W' (restrict_model W m) m' -> - strictly_updates (cls ⇂ W) W' m (model_update m m'). - Proof. - intros m mof su. - eapply strictly_updates_restrict_model_gen; tea; reflexivity. - Qed. - - Lemma strictly_updates_is_update_of_restrict cls W init m W' m' : - strictly_updates cls W init m -> - is_update_of (cls ⇂ W) W' (restrict_model W m) m' -> - strictly_updates cls (LevelSet.union W W') init (model_update m m'). - Proof. - move=> su /is_update_of_case; intros [[empw eq]|su']. - - rewrite <- eq. eapply (strictly_updates_weaken cls). clsets. - rewrite model_update_restrict. - eapply strictly_updates_W_eq; tea. lsets. - - eapply strictly_updates_restrict_model in su'. - eapply strictly_updates_weaken in su'. 2:eapply restrict_clauses_subset. - eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. - now apply strictly_updates_total_model in su. - Qed. - - Lemma union_with_concl cls W : Clauses.Equal (Clauses.union cls (cls ↓ W)) cls. - Proof. - intros x. rewrite Clauses.union_spec in_clauses_with_concl. firstorder. - Qed. - - Instance is_update_of_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) is_update_of. - Proof. - intros ?? H ?? H' ?? H'' ?? H'''. - unfold is_update_of. setoid_rewrite H'. destruct LevelSet.is_empty. - rewrite H'' H'''. reflexivity. - firstorder. now rewrite -H -H' -H'' -H'''. - subst. now rewrite H H' H'' H'''. - Qed. - - Lemma empty_union l : LevelSet.Equal (LevelSet.union LevelSet.empty l) l. - Proof. intros ?. lsets. Qed. - - Lemma is_update_of_strictly_updates cls W m m' : - strictly_updates cls W m m' -> - is_update_of cls W m m'. - Proof. - intros su. have ne := strictly_updates_non_empty su. - rewrite /is_update_of. now rewrite (proj2 (levelset_not_Empty_is_empty _) ne). - Qed. - - Lemma is_update_of_weaken {cls cls' W m m'} : - Clauses.Subset cls cls' -> - is_update_of cls W m m' -> is_update_of cls' W m m'. - Proof. - intros hsub. - move/is_update_of_case => []. - - intros []. subst. rewrite /is_update_of. - now rewrite (LevelSetFact.is_empty_1 H). - - intros su. have ne := strictly_updates_non_empty su. - unfold is_update_of. rewrite (proj2 (levelset_not_Empty_is_empty _) ne). - eapply strictly_updates_weaken; tea. - Qed. - - Lemma is_update_of_trans {cls cls' W W' m m' m''} : - is_update_of cls W m m' -> is_update_of cls' W' m' m'' -> - is_update_of (Clauses.union cls cls') (LevelSet.union W W') m m''. - Proof. - move/is_update_of_case => []. - - move=> [he eq]. intro. rewrite eq. rewrite (LevelSetProp.empty_is_empty_1 he) empty_union. - move: H. eapply is_update_of_weaken. clsets. - - intros su isu. - eapply strictly_updates_is_update_of in isu; tea. - have ne := strictly_updates_non_empty isu. - rewrite /is_update_of. now rewrite (proj2 (levelset_not_Empty_is_empty _) ne). - Qed. - - Lemma is_update_of_trans_eq {cls cls' W W' cltr Wtr m m' m''} : - is_update_of cls W m m' -> is_update_of cls' W' m' m'' -> - Clauses.Subset (Clauses.union cls cls') cltr -> - LevelSet.Equal Wtr (LevelSet.union W W') -> - is_update_of cltr Wtr m m''. - Proof. - intros hi hi' hcl hw. rewrite hw. - eapply is_update_of_weaken; tea. - eapply is_update_of_trans; tea. - Qed. - - Lemma union_idem cls : Clauses.Equal (Clauses.union cls cls) cls. - Proof. intros ?; rewrite Clauses.union_spec. firstorder. Qed. - - (* (* Lemma above_max_premise_model_trans {cls V' m m'} : - above_max_premise_model cls m -> - strictly_updates cls V' m m' -> - above_max_premise_model cls m'. - Proof. - move=> [[V'' ab]|eq] su. - * have tr := strictly_updates_trans ab su. - rewrite union_idem in tr. - now left; eexists. - * left; exists V'. now subst. - Qed. *) - - Lemma max_clause_premise_spec2 cls : - (exists cl, Clauses.In cl cls /\ max_clause_premise cls = Z.max (premise_max (premise cl)) 0) \/ - (Clauses.Empty cls /\ max_clause_premise cls = 0). - Proof. - unfold max_clause_premise. - eapply ClausesProp.fold_rec. - - firstorder. - - intros x a s' s'' incls ins' hadd [ih|ih]. - left. - * destruct ih as [cl [incl ->]]. - destruct (Z.max_spec (premise_max (premise x)) (Z.max (premise_max (premise cl)) 0)) as [[hlt ->]|[hge ->]]. - { exists cl. split => //. apply hadd. now right. } - { exists x. firstorder. lia. } - * destruct ih. left. exists x. split; firstorder. subst. - lia. - Qed. *) -(* - Lemma max_clause_premise_mon {cls cls'} : - cls ⊂_clset cls' -> - (max_clause_premise cls <= max_clause_premise cls'). - Proof using Type. - intros hincl. - have [[cl [hin hs]]|[he hs]] := max_clause_premise_spec2 cls; - have [[cl' [hin' hs']]|[he' hs']] := max_clause_premise_spec2 cls'. - - apply hincl in hin. - have hm := max_clause_premise_spec _ _ hin. - have hm' := max_clause_premise_spec _ _ hin'. lia. - - rewrite hs'. apply hincl in hin. now eapply he' in hin. - - rewrite hs. lia. - - lia. - Qed. *) - - - Lemma update_total_model W m m' : - model_of W m -> - model_of W (model_update m m'). - Proof. - intros mof k inW. - apply mof in inW as [v inW]. - destruct (LevelMapFact.F.In_dec m' k). - - destruct i as [v' inm']. exists v'. - rewrite model_update_spec. right; firstorder. - - exists v. rewrite model_update_spec. left. split => //. - Qed. - - Lemma model_map_outside_update W m m' : - only_model_of W m' -> - model_map_outside W m (model_update m m'). - Proof. - intros om l nin k. - rewrite model_update_spec. - firstorder. - Qed. - Lemma valid_model_only_model W W' m cls : forall vm : valid_model W W' m cls, only_model_of W m -> only_model_of W (model_model vm). @@ -2294,8 +433,6 @@ Section InnerLoop. - intros su. eapply strictly_updates_restrict_model in su; tea. Qed. - Infix "=_clset" := Clauses.Equal (at level 90). - Lemma valid_model_is_update_of_eq W W' m cls cls' : model_of W m -> forall vm : valid_model W W' (restrict_model W m) cls, @@ -2312,87 +449,6 @@ Section InnerLoop. now rewrite eq. Qed. - Lemma valid_clause_preserved {m m' cl} : - (forall x, LevelSet.In x (clause_levels cl) -> level_value m x = level_value m' x) -> - valid_clause m cl -> - valid_clause m' cl. - Proof. - intros hcl. destruct cl as [prems [concl k]]. - rewrite /valid_clause //=. - rewrite (@min_premise_preserved m m' prems). - { intros x inp. apply hcl. rewrite clause_levels_spec. now left. } - destruct (min_premise m' prems) => //. - rewrite /level_value_above. rewrite hcl //. - rewrite clause_levels_spec. now right. - Qed. - - Lemma is_model_update W m m' cls : - model_of W m -> - only_model_of W m' -> - is_model (cls ⇂ W) m' -> - is_model (cls ⇂ W) (model_update m m'). - Proof. - intros mW om. - rewrite /is_model. - move/Clauses.for_all_spec. intros h. - apply Clauses.for_all_spec. tc. - intros cl hin. - specialize (h cl hin). cbn in h. - eapply valid_clause_preserved; tea. - move=>x; move: hin. rewrite in_restrict_clauses. - intros [incl inprems incls]. - rewrite clause_levels_spec. move=> [] hin. - - apply inprems in hin. - apply levelmap_level_value_eq => k. - rewrite model_update_spec. clear -mW om hin. firstorder. - - subst x. apply levelmap_level_value_eq => k. - rewrite model_update_spec. cbn in *. firstorder. - Qed. - - Lemma strictly_updates_defined_model cls W m m' : - strictly_updates cls W m m' -> - defined_model_of W m'. - Proof. - induction 1. - - cbn. destruct cl as [prems [concl k]]; cbn in H0. - destruct H0 as [hz [hmin habov heq]]. - move=> l /LevelSet.singleton_spec => -> //=. - setoid_rewrite heq. exists (k + hz). - apply LevelMapFact.F.add_mapsto_iff. - left; split => //. - - apply defined_model_of_union; auto. - eapply defined_model_of_ext. exact IHstrictly_updates1. - now apply strictly_updates_ext in H0. - Qed. - - Lemma defined_model_of_restrict W m : - defined_model_of W m -> defined_model_of W (restrict_model W m). - Proof. - intros def l hin. specialize (def _ hin) as [k hm]. - exists k. apply restrict_model_spec. split => //. - Qed. - - Lemma defined_model_of_update W m m' : - model_of W m' -> - defined_model_of W m -> defined_model_of W (model_update m' m). - Proof. - intros mof def l hin. specialize (def _ hin) as [k hm]. - exists k. apply model_update_spec. right. split => //. - now apply mof. - Qed. - - Lemma defined_model_of_is_update_of {W W' W'' m m'} : - defined_model_of W m -> - is_update_of W' W'' m m' -> - defined_model_of W m'. - Proof. - intros def isupd l hin. move: isupd; rewrite /is_update_of. - destruct LevelSet.is_empty. - - intros h; setoid_rewrite <- h. specialize (def _ hin) as [k hm]. - now exists k. - - now move/strictly_updates_ext/defined_model_of_ext; move/(_ W). - Qed. - Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) (loop : forall (V' U' : LevelSet.t) (cls' : clauses) (minit m : model) (prf : [/\ clauses_levels cls' ⊂_lset V', only_model_of V' minit & @@ -2437,13 +493,9 @@ Section InnerLoop. - split => //. * rewrite eqprem. apply clauses_levels_restrict_clauses. * now eapply strictly_updates_restrict_only_model. - (* * eapply (strictly_updates_total_model upd). *) - (* * rewrite eqprem. transitivity cls => //. apply restrict_clauses_subset. *) - (* * eapply strictly_updates_weaken in upd; tea. eapply above_max_premise_model_trans in maxp; tea. *) * eapply is_update_of_empty. - left. now eapply strict_subset_cardinal. - rewrite eqprem. eapply restrict_clauses_subset. - (* - destruct prf. transitivity (cls ⇂ W) => //. now rewrite H3. eapply restrict_clauses_subset. *) - have mu := model_updates mr. setoid_rewrite eqprem at 1 in mu. eapply strictly_updates_is_update_of_restrict in upd; tea. @@ -2534,540 +586,10 @@ Section InnerLoop. End InnerLoop. -Local Open Scope nat_scope. -Lemma diff_cardinal_inter V W : #|LevelSet.diff V W| = #|V| - #|LevelSet.inter V W|. -Proof. - pose proof (LevelSetProp.diff_inter_cardinal V W). lia. -Qed. +(* To help equations *) +Opaque lexprod_rel_wf. -Lemma diff_cardinal V W : W ⊂_lset V -> #|LevelSet.diff V W| = #|V| - #|W|. -Proof. - intros hsub. - rewrite diff_cardinal_inter LevelSetProp.inter_sym LevelSetProp.inter_subset_equal //. -Qed. - -Lemma is_modelP m cls : reflect (Clauses.For_all (valid_clause m) cls) (is_model cls m). -Proof. - case E: is_model; constructor. - - now move: E; rewrite /is_model -ClausesFact.for_all_iff. - - intros hf. apply ClausesFact.for_all_iff in hf; tc. unfold is_model in E; congruence. -Qed. - -Lemma is_model_invalid_clause cl cls m : is_model cls m -> ~~ valid_clause m cl -> ~ Clauses.In cl cls. -Proof. - move/is_modelP => ism /negP valid hin. - now specialize (ism _ hin). -Qed. - -Lemma strict_subset_leq_right U V W : - strict_subset U V -> V ⊂_lset W -> strict_subset U W. -Proof. - intros [] le. split. lsets. intros eq. rewrite -eq in le. - apply H0. lsets. -Qed. - -Lemma strict_subset_leq_left U V W : - U ⊂_lset V -> strict_subset V W -> strict_subset U W. -Proof. - intros le []. split. lsets. intros eq. rewrite eq in le. - apply H0. lsets. -Qed. - -(* Lemma strict_subset_union_right U U' V W : - strict_subset V W -> U ⊂_lset U' -> - strict_subset (LevelSet.union U V) (LevelSet.union U' W). -Proof. - rewrite /strict_subset. - intros [] hu. split. lsets. intros he. - apply H0. - intros x. split. apply H. - specialize (he x). intros inW. - rewrite !LevelSet.union_spec in he. - destruct he as [he he']. - forward he'. now right. destruct he' => //. - forward he. apply he in - red in he. *) - -Lemma strict_subset_diff_incl V W W' : - strict_subset W' W -> - W ⊂_lset V -> - W' ⊂_lset V -> - strict_subset (LevelSet.diff V W) (LevelSet.diff V W'). -Proof. - intros [] lew lew'. - split. lsets. - intros eq. - apply H0. lsets. -Qed. - -(* To help equations *) -Opaque lexprod_rel_wf. - -Lemma check_model_spec_V {V cls w m w' m'} : - model_of V m -> clauses_conclusions cls ⊂_lset V -> - model_of w m -> - check_model cls (w, m) = Some (w', m') -> - check_model_invariants cls w m w' m' true. -Proof. - cbn; intros mof incl tot cm. - apply check_model_has_invariants in cm => //. - eapply model_of_subset. exact mof. tea. -Qed. - -Section Semantics. - - Section Interpretation. - Context (V : LevelMap.t nat). - - Definition interp_level l := - match LevelMap.find l V with - | Some x => x - | None => 0%nat - end. - - Definition interp_expr '(l, k) := (Z.of_nat (interp_level l) + k)%Z. - Definition interp_prems prems := - let '(hd, tl) := to_nonempty_list prems in - fold_right (fun lk acc => Z.max (interp_expr lk) acc) (interp_expr hd) tl. - - Definition clause_sem (cl : clause) : Prop := - let '(prems, concl) := cl in - (interp_prems prems >= interp_expr concl)%Z. - - Definition clauses_sem (cls : clauses) : Prop := - Clauses.For_all clause_sem cls. - End Interpretation. - - (* There exists a valuation making all clauses true in the natural numbers *) - Definition satisfiable (cls : clauses) := - exists V, clauses_sem V cls. - - (* Any valuation making all clauses valid in the natural numbers also satisfies the clause cl *) - Definition entails_sem (cls : clauses) (cl : clause) := - forall V, clauses_sem V cls -> clause_sem V cl. -End Semantics. - - -Local Open Scope Z_scope. - -Lemma max_min max min k : min <= 0 -> max >= 0 -> k <= max -> k >= min -> (max - k - min) >= 0. -Proof. lia. Qed. - -Definition model_min m := - LevelMap.fold (fun l k acc => Z.min acc (option_get 0 k)) m 0. - -Lemma model_min_spec m : forall l k, LevelMap.MapsTo l (Some k) m -> (model_min m <= k)%Z. -Proof. - intros l k hm. - rewrite /model_min. - move: hm; eapply LevelMapFact.fold_rec. - - move=> m0 he hm. now apply he in hm. - - intros k' e a m' m'' hm nin hadd hle hm''. - specialize (hadd l). - eapply levelmap_find_eq_inv in hadd. eapply hadd in hm''. - rewrite LevelMapFact.F.add_mapsto_iff in hm''. - move: hm''=> [] [h h']. - * subst e. cbn. lia. - * move/hle: h'. lia. -Qed. - - -Lemma model_min_spec2 m : (model_min m <= 0)%Z. -Proof. - rewrite /model_min. - eapply LevelMapFact.fold_rec. - - intros; reflexivity. - - intros k' e a m' m'' hm nin hadd hle. lia. -Qed. - -Definition model_max m := - LevelMap.fold (fun l k acc => Z.max acc (option_get 0 k)) m 0. - -Lemma model_max_spec m : forall l k, LevelMap.MapsTo l k m -> (k ≤ Some (model_max m)). -Proof. - intros l k hm. - rewrite /model_max. - move: hm; eapply LevelMapFact.fold_rec. - - move=> m0 he hm. now apply he in hm. - - intros k' e a m' m'' hm nin hadd hle hm''. - specialize (hadd l). - eapply levelmap_find_eq_inv in hadd. eapply hadd in hm''. - rewrite LevelMapFact.F.add_mapsto_iff in hm''. - move: hm''=> [] [h h']. - * subst k. destruct e; constructor. cbn. lia. - * move/hle: h'. intros h'; depelim h'; constructor; lia. -Qed. - -Lemma model_max_spec2 m : (0 <= model_max m)%Z. -Proof. - rewrite /model_max. - eapply LevelMapFact.fold_rec. - - intros; reflexivity. - - intros k' e a m' m'' hm nin hadd hle. lia. -Qed. - -Definition valuation_of_model (m : model) : LevelMap.t nat := - let max := model_max m in - let min := model_min m in - LevelMap.fold (fun l k acc => LevelMap.add l (Z.to_nat (max - option_get 0 k - min)) acc) m (LevelMap.empty _). - -Lemma valuation_of_model_spec m : - forall l k, LevelMap.MapsTo l (Some k) m -> - let v := (model_max m - k - model_min m)%Z in - LevelMap.MapsTo l (Z.to_nat v) (valuation_of_model m). -Proof. - intros l k hm v. - unfold valuation_of_model. subst v. - move: hm. generalize (model_max m) (model_min m) => n n'. - eapply LevelMapFact.fold_rec. - - intros v he hm. - now eapply he in hm. - - intros. - specialize (H1 l). eapply levelmap_find_eq_inv in H1. eapply H1 in hm. - rewrite LevelMapFact.F.add_mapsto_iff in hm. destruct hm as [[-> ->]|[neq hm]]. - * eapply LevelMapFact.F.add_mapsto_iff. left. split => //. - * eapply LevelMapFact.F.add_mapsto_iff. right. split => //. now apply H2. -Qed. - -Lemma strictly_updates_valid_model {W W' m m' cls} : - is_model (cls ↓ W) m -> - strictly_updates cls W' m m' -> - exists l, LevelSet.In l W' /\ ~ LevelSet.In l W. -Proof. - intros vm. induction 1. - - exists (clause_conclusion cl). split => //. lsets. intros hin. - eapply strict_update_invalid in H0. - eapply is_model_invalid_clause in vm; tea. apply vm. - eapply in_clauses_with_concl. split => //. - - destruct (IHstrictly_updates1 vm). exists x. - rewrite LevelSet.union_spec. firstorder. -Qed. - -Lemma model_of_strictly_updates cls W V m m' : - strictly_updates cls W m m' -> model_of V m -> model_of V m'. -Proof. - intros su. - induction su. - - intros mv l hin. apply mv in hin. - destruct cl as [prems [concl k]]. - destruct H0 as [minv [eqmin nabove eqm]]. rewrite eqm. - rewrite LevelMapFact.F.add_in_iff. now right. - - eauto. -Qed. - -Lemma check_model_ne {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> ~ LevelSet.Empty W. -Proof. - move/check_model_spec => [w'' [su ->]]. - apply strictly_updates_non_empty in su. - intros he. apply su. lsets. -Qed. - -Lemma check_model_update_of {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> - exists W', is_update_of cls W' m m' /\ W = LevelSet.union U W'. -Proof. - move/check_model_spec => [w'' [su ->]]. exists w''. split => //. - now eapply is_update_of_strictly_updates. -Qed. - -Lemma opt_le_lt_trans {x y z} : opt_le Z.le x y -> opt_le Z.lt y z -> opt_le Z.lt x z. -Proof. - destruct 1; intros H'; depelim H'; constructor. lia. -Qed. - -Lemma strictly_updates_all cls V minit m : strictly_updates cls V minit m -> - (forall l k, LevelSet.In l V -> LevelMap.MapsTo l k minit -> exists k', LevelMap.MapsTo l (Some k') m /\ opt_le Z.lt k (Some k')). -Proof. - induction 1. - - intros l k hin hm. - move: H0; rewrite /strict_update. - destruct cl as [prems [concl gain]]. - move=> [] v [] minp hlt. cbn in hin. eapply LevelSet.singleton_spec in hin. red in hin; subst l. - move/negbTE: hlt; rewrite /level_value_above. - intros hle eq. setoid_rewrite eq. - eexists. setoid_rewrite LevelMapFact.F.add_mapsto_iff. split; [left;split;eauto|] => //. - destruct level_value eqn:hl => //. - * rewrite (level_value_MapsTo hm) in hl. noconf hl. constructor. lia. - * rewrite (level_value_MapsTo hm) in hl. noconf hl. constructor. - - intros l k; rewrite LevelSet.union_spec; move=> [] hin hm. - apply IHstrictly_updates1 in hm as [k' [hle hm']]; tea. - eapply strictly_updates_ext in H0. apply H0 in hle as [k'' [hm'' lek'']]. - depelim lek''. - exists y. split => //. depelim hm'; constructor; lia. - eapply strictly_updates_ext in H. eapply H in hm as [k' [hm' lek']]. - eapply IHstrictly_updates2 in hm' as [k'' [hm'' lek'']]; tea. - exists k''. split => //. depelim lek'; depelim lek''; constructor; lia. -Qed. - -Lemma strictly_updates_zero_model cls V mzero m : - (forall l, LevelSet.In l V -> LevelMap.MapsTo l (Some 0%Z) mzero) -> - strictly_updates cls V mzero m -> - forall l, LevelSet.In l V -> exists k, LevelMap.MapsTo l (Some k) m /\ (0 < k)%Z. -Proof. - intros ho. - move/strictly_updates_all => ha l hin. - eapply ha in hin; revgoals. now apply ho. - destruct hin as [k' [hm hle]]. depelim hle. - now exists k'. -Qed. - -Lemma of_level_set_union_spec {ls ls' n hne} hne' hne'' : - of_level_set (ls ∪ ls') n hne = - univ_union (of_level_set ls n hne') (of_level_set ls' n hne''). -Proof. - apply eq_univ_equal. - intros [l k]. rewrite /of_level_set //= !levelexprset_of_levels_spec LevelExprSet.union_spec. - rewrite !levelexprset_of_levels_spec LevelSet.union_spec. clear. firstorder. -Qed. - -Lemma in_singleton l : LevelSet.In l (LevelSet.singleton l). -Proof. lsets. Qed. - -Definition app {A B} (f : A -> B) (x : A) := f x. - -Notation "f $ x" := (app f x) (at level 20). - -Definition model_domain (m : model) V := - forall x, LevelSet.In x V <-> LevelMap.In x m. - -Definition model_rel_partial R V (m m' : model) := - forall l, - (LevelSet.In l V -> forall k, LevelMap.MapsTo l k m -> - exists k', LevelMap.MapsTo l k' m' /\ opt_le R k k') /\ - (~ LevelSet.In l V -> forall k, LevelMap.MapsTo l k m <-> LevelMap.MapsTo l k m'). - -Lemma model_of_sext {R W W' m m'} : - model_of W m -> - model_of W' m -> - model_rel_partial R W m m' -> - model_of W' m'. -Proof. - intros mof mof' ext. - intros l hin. - destruct (mof' l hin). specialize (ext l) as [lin lout]. - destruct (inLevelSet W l) as [hin'|hout]. - - specialize (lin hin' _ H). firstorder. - - specialize (lout hout x). - exists x. now apply lout. -Qed. - -Lemma defined_model_of_sext {R W W' m m'} : - defined_model_of W m -> - defined_model_of W' m -> - model_rel_partial R W m m' -> - defined_model_of W' m'. -Proof. - intros mof mof' ext. - intros l hin. - destruct (mof' l hin). specialize (ext l) as [lin lout]. - destruct (inLevelSet W l) as [hin'|hout]. - - specialize (lin hin' _ H). firstorder. depelim H1. now exists y. - - specialize (lout hout (Some x)). - exists x. now apply lout. -Qed. - -Lemma not_in_union_inv l ls ls' : - ~ LevelSet.In l (LevelSet.union ls ls') -> - ~ LevelSet.In l ls /\ ~ LevelSet.In l ls'. -Proof. - rewrite LevelSet.union_spec. firstorder. -Qed. - -Lemma model_rel_partial_trans {R W W' m m' m''} (HR : Transitive R) : - model_rel_partial R W m m' -> - model_rel_partial R W' m' m'' -> - model_rel_partial R (LevelSet.union W W') m m''. -Proof. - intros mr mr' l. - specialize (mr l) as [inWmr outWmr]. - specialize (mr' l) as [inWmr' outWmr']. - split. - { rewrite LevelSet.union_spec. move=> [] hin k hm. - - specialize (inWmr hin k hm) as [k' [hk' rk']]. - destruct (inLevelSet W' l). - + specialize (inWmr' H k' hk') as [k'' [hk'' rk'']]. - exists k''. split => //. now transitivity k'. - + specialize (outWmr' H k'). exists k'. split => //. now apply outWmr'. - - destruct (inLevelSet W l). - + specialize (inWmr H k hm) as [k'' [hk'' rk'']]. - specialize (inWmr' hin k'' hk'') as [km' [hkm' rkm']]. - exists km'. split => //. now transitivity k''. - + specialize (outWmr H k) as eq. - apply eq in hm. - specialize (inWmr' hin k hm) as [m''k [hm'' rm'']]. - exists m''k. split => //. } - { move/not_in_union_inv => [] ninW ninW' k. - rewrite (outWmr ninW k). - rewrite (outWmr' ninW' k). reflexivity. } -Qed. - -Lemma strictly_updates_model_lt {cls V} {m m'} : - strictly_updates cls V m m' -> - model_of V m -> - model_rel_partial Z.lt V m m'. -Proof. - intros su; induction su. - - intros htot l. split; revgoals. - { intros nin k. destruct cl as [prems [concl conclk]]; cbn in *. - destruct H0 as [minp [hmin nabove hm']]. - rewrite hm'. rewrite LevelMapFact.F.add_mapsto_iff. - assert (concl <> l). intros ->. - apply nin, in_singleton. - firstorder. } - intros inv k hin. - red in htot. - specialize (htot (clause_conclusion cl) (in_singleton _)) as [mconcl mt]. - destruct cl as [prems [concl conclk]]; cbn in *. - destruct H0 as [minp [hmin nabove hm']]. - eapply LevelSet.singleton_spec in inv; red in inv; subst l. - eapply LevelMapFact.F.MapsTo_fun in hin; tea. noconf hin. - exists (Some (conclk + minp)). split => //. - rewrite hm'. - rewrite LevelMapFact.F.add_mapsto_iff. left. split => //. - move/negbTE: nabove; move/level_value_not_above_spec. - now rewrite (level_value_MapsTo mt). - - move/model_of_union_inv => [] totls totls'. - forward IHsu1 by auto. - forward IHsu2. - { eapply model_of_sext. exact totls. assumption. eassumption. } - now eapply model_rel_partial_trans. -Qed. - -Lemma intro_sing {P : Level.t -> Prop} {cl} : - P cl -> (forall l, LevelSet.In l (LevelSet.singleton cl) -> P l). -Proof. - intros H l ins. rewrite LevelSet.singleton_spec in ins. now red in ins; subst. -Qed. - -Lemma elim_sing {P : Level.t -> Prop} {cl} : (forall l, LevelSet.In l (LevelSet.singleton cl) -> P l) -> P cl. -Proof. - intros H. apply H, in_singleton. -Qed. - -Definition defined_map (m : LevelMap.t (option Z)) := - exists l k, LevelMap.MapsTo l (Some k) m. - -Lemma levelmap_add_spec {A} (m m' : LevelMap.t A) {k v}: - LevelMapFact.Add k v m m' -> - m' =m LevelMap.add k v m. -Proof. - trivial. -Qed. - -#[program] -Definition of_level_map (m : LevelMap.t (option Z)) (hne : defined_map m) : premises := - {| t_set := LevelMap.fold (fun l k acc => - if k is (Some k') return _ then LevelExprSet.add (l, k') acc else acc) m LevelExprSet.empty |}. -Next Obligation. apply not_Empty_is_empty. - move: hne. eapply LevelMapFact.fold_rec. firstorder. - intros. rewrite /LevelExprSet.Empty. - intros ha. destruct e eqn:he. - - specialize (ha (k, z)). apply ha; apply LevelExprSet.add_spec. now left. - - destruct hne as [witl [witk hin]]. - apply levelmap_add_spec in H1. rewrite H1 in hin. - rewrite LevelMapFact.F.add_mapsto_iff in hin; - destruct hin as [[? eq]|[new hm]]; try congruence. - eapply H2. now exists witl, witk. exact ha. -Qed. - -Lemma mapsto_some_add_none l k l' (m : model) : - LevelMap.MapsTo l (Some k) (LevelMap.add l' None m) <-> - LevelMap.MapsTo l (Some k) m /\ l <> l'. -Proof. - rewrite LevelMapFact.F.add_mapsto_iff. - firstorder. congruence. congruence. -Qed. - -Lemma of_level_map_spec m hne : - forall l k, LevelExprSet.In (l, k) (of_level_map m hne) <-> LevelMap.MapsTo l (Some k) m. -Proof. - intros l k; rewrite /of_level_map //=. - clear hne. - have : forall acc, - LevelExprSet.In (l, k) - (LevelMap.fold (fun (l0 : LevelMap.key) k0 (acc : LevelExprSet.t) => - if k0 is (Some k') then LevelExprSet.add (l0, k') acc else acc) m acc) <-> - LevelMap.MapsTo l (Some k) m \/ LevelExprSet.In (l, k) acc. - move=> acc; eapply LevelMapFact.fold_rec. - - firstorder. - - intros. - destruct e eqn:he. - { rewrite LevelExprSet.add_spec H2. - split. - * intros [eq|hm]. - + noconf eq. specialize (H1 l). eapply levelmap_find_eq_inv in H1. - erewrite H1. left. apply LevelMapFact.F.add_mapsto_iff. left => //. - + specialize (H1 l). eapply levelmap_find_eq_inv in H1; erewrite H1. - rewrite LevelMapFact.F.add_mapsto_iff. - destruct (eq_dec l k0); subst; firstorder. exact None. - * intros hm'. destruct hm'. - + specialize (H1 l). eapply levelmap_find_eq_inv in H1. eapply H1 in H3. - apply LevelMapFact.F.add_mapsto_iff in H3. destruct H3. firstorder; subst. left. red. red in H3. subst. - noconf H6; reflexivity. - unfold LevelExprSet.E.eq. destruct H3. now right; left. - + unfold LevelExprSet.E.eq. now right. } - { rewrite H2. clear H2; apply levelmap_add_spec in H1; rewrite H1. - rewrite mapsto_some_add_none. firstorder. cbn in H0. - destruct (eq_dec l k0). - * subst. cbn in H0. firstorder. - * left. auto. } - - intros. rewrite H. firstorder. lesets. -Qed. - -Lemma strictly_updates_defined_map {cls W m m'} : - strictly_updates cls W m m' -> defined_map m'. -Proof. - induction 1. - - exists (clause_conclusion cl). - destruct cl as [prems [concl k]]. - destruct H0 as [? [? ? heq]]. cbn. - setoid_rewrite heq. exists (k + x); cbn. - rewrite LevelMapFact.F.add_mapsto_iff. firstorder. - - assumption. -Qed. - - -Definition premise_values (prems : premises) m := - NonEmptySetFacts.map (fun '(l, k) => (l, option_get 0 (level_value m l))) prems. - -Lemma premise_values_spec prems m : - forall l k, LevelExprSet.In (l, k) (premise_values prems m) <-> - (exists k', LevelExprSet.In (l, k') prems /\ k = option_get 0 (level_value m l)). -Proof. - rewrite /premise_values. - intros l k. rewrite NonEmptySetFacts.map_spec. - firstorder. destruct x. noconf H0. - exists z. split => //. exists(l, x); split => //. now rewrite -H0. -Qed. - -Definition hyps_map (hyps : premises) m := - (forall (l : Level.t) k, LevelExprSet.In (l, k) hyps <-> LevelMap.MapsTo l (Some k) m). - -Lemma model_hyps_entails cls m hyps (prems : premises) concl : - Clauses.In (prems, concl) cls -> - (forall l k, LevelExprSet.In (l,k) prems -> exists z, Some z ≤ level_value m l) -> - hyps_map hyps m -> - cls ⊢a hyps → premise_values prems m. -Proof. - intros incls hmx hm. - intros [l k] hin. - rewrite premise_values_spec in hin. destruct hin as [k' [inp ->]]. - red in hm. - constructor. rewrite hm. - specialize (hmx l _ inp). - depelim hmx. depelim H. rewrite H0 //=. - now eapply level_value_MapsTo'. -Qed. - -Lemma entails_succ cls (u v : premises) : - (forall l k, LevelExprSet.In (l, k) v -> exists k', LevelExprSet.In (l, k') u /\ k <= k') -> - cls ⊢a u → v. -Proof. - intros hk [l k] hin. - specialize (hk _ _ hin) as [k' [hin' le]]. - assert (exists n, k' = k + n) as [n ->] by (exists (k' - k); lia). - eapply (entails_pred_closure_n (n := Z.to_nat n)). - constructor. rewrite Z2Nat.id. lia. assumption. -Qed. +Local Open Scope Z_scope. Lemma hyps_entails (hyps : premises) m cls : hyps_map hyps m -> @@ -3124,8 +646,6 @@ Proof. eapply level_value_MapsTo' in hminprem. rewrite -hypss in hminprem. eapply hyps_entails; tea. red in eq; subst. exact entailscl. - (* rewrite hmin. lia_f_equal. *) - (* have -> : k + (z - mink) = k + (z - mink) by lia. now red in eq; subst concl. *) constructor. now rewrite of_level_map_spec. - have hnemid : defined_map m'. by exact: strictly_updates_defined_map su1. specialize (IHsu1 hne hnemid). @@ -3133,27 +653,6 @@ Proof. eapply entails_all_trans; tea. Qed. -Lemma not_empty_exists V : ~ LevelSet.Empty V -> exists l, LevelSet.In l V. -Proof. - intros ne. - destruct (LevelSet.choose V) eqn:ch. exists e. - now eapply LevelSet.choose_spec1 in ch. - now apply LevelSet.choose_spec2 in ch. -Qed. - -(* Lemma of_level_map_of_level_set cls sel V m hne hne' : - max_premise_model cls sel m -> - V =_lset sel cls -> - of_level_map m hne = of_level_set V (max_clause_premise cls) hne'. -Proof. - move=> mp hv. apply: (proj1 (eq_univ_equal _ _)) => [[l k]]. - rewrite of_level_map_spec levelexprset_of_levels_spec. - split. red in mp. - move/(proj2 mp l) => [hin eq]. split. 2:lia. lsets. - move=> [] inl ->. rewrite hv in inl. - now apply mp. -Qed. *) - Lemma infers_atom_of_level_map {cls m hne l k} : infers_atom m l k -> cls ⊢ of_level_map m hne → (l, k). @@ -3168,86 +667,11 @@ Proof. rewrite Z2Nat.id. lia. reflexivity. Qed. -(* Lemma of_level_map_entails_of_level_set cls V m hne hne' : - above_max_premise_model cls m -> - V ⊂_lset clauses_levels cls -> - cls ⊢a of_level_map m hne → of_level_set V (max_clause_premise cls) hne'. -Proof. - move=> mp hv. - intros [l k]. - rewrite levelexprset_of_levels_spec. - intros [hin ->]. - have hi := above_max_premise_model_infers mp. - move: (hi l (hv _ hin)). - eapply infers_atom_of_level_map. -Qed. *) - (* The criterion for loops: when a set of updates manages to strictly update all the levels it started with, then we can deduce a looping constraint `x, ..., z -> x + 1, ... z + 1`. - - TODO: refine the premises, this should work also when some clauses cannot be considered, - so that it can be used for checking and not only inferrence. - *) -(* Lemma strictly_updates_entails_loop cls V (hne : ~ LevelSet.Empty V) mzero m : - max_premise_model cls clauses_levels mzero -> - V =_lset clauses_levels cls -> - model_of V mzero -> - strictly_updates cls V mzero m -> - entails_all cls (of_level_set V (max_clause_premise cls) hne) - (of_level_set V (max_clause_premise cls + 1) hne). -Proof. - intros maxp vincl tot su. - have mp := strictly_updates_model_lt su tot. - have nemzero : ~ LevelMap.Empty mzero. - { have := not_empty_exists V hne => [[l]]. - now move/tot => [v hm] /(_ _ _ hm). } - have nem := strictly_updates_non_empty_map su. - eapply (strictly_updates_entails nemzero nem) in su; tea. - unshelve erewrite of_level_map_of_level_set in su; tea. - move/entails_all_trans: su; apply. - apply: entails_succ => l k. - rewrite levelexprset_of_levels_spec => [[hin ->]]. - rw of_level_map_spec. - move: (mp l) => [] /(_ hin). - move: (tot _ hin) => [x hm]. - move/(_ _ hm) => [k' [hm' lt]]. - intros _. - exists k'. - unfold max_premise_model in maxp. - move: (proj1 maxp l) => hl. - forward hl. apply vincl, hin. - eapply LevelMapFact.F.MapsTo_fun in hm; tea. noconf hm. - split => //. lia. -Qed. *) - -(* Lemma strictly_updates_entails_loop_above_max cls V (hne : ~ LevelSet.Empty V) mzero m : - above_max_premise_model cls mzero -> - V =_lset clauses_levels cls -> - model_of V mzero -> - strictly_updates cls V mzero m -> - entails_all cls (of_level_set V (max_clause_premise cls) hne) - (of_level_set V (max_clause_premise cls + 1) hne). -Proof. - move=> habove hv tot su. - destruct habove as [[V' ha]|eq]. - * apply (strictly_updates_entails_loop cls V hne (max_premise_map cls) m); tea. - - apply max_premise_model_exists. - - have [hs hs'] := max_premise_model_exists cls. red. - intros k hm. rewrite hv in hm. specialize (hs _ hm). now eexists. - - have tr := strictly_updates_trans ha su. rewrite union_idem in tr. - eapply strictly_updates_incl in ha. - assert (V' ∪ V = V). - { apply LevelSet.eq_leibniz. red. - rewrite hv. move: (clauses_conclusions_levels cls). lsets. } - now rewrite H in tr. - * subst mzero. - eapply strictly_updates_entails_loop; tea. - apply max_premise_model_exists. -Qed. *) - Lemma entails_any_one V cls m nem m' nem' : model_of V m -> cls ⊢a of_level_map m nem → of_level_map m' nem' -> @@ -3288,82 +712,6 @@ Proof. eapply entails_any in su; tea. Qed. -Lemma add_prems_add {n lk prems} : add_prems n (add lk prems) = add (add_expr n lk) (add_prems n prems). -Proof. - apply eq_univ_equal. intros x. - rewrite In_add_prems LevelExprSet.add_spec In_add_prems /LevelExprSet.E.eq; rw LevelExprSet.add_spec. - firstorder. subst. red in H; subst x0. now left. -Qed. - -Lemma add_prems_of_level_set k W k' prf : - add_prems k (of_level_set W k' prf) = of_level_set W (k + k') prf. -Proof. - apply eq_univ_equal => [] [l n]. - rewrite In_add_prems /of_level_set //= levelexprset_of_levels_spec. - split. - - move=> [] [l' n']. rewrite levelexprset_of_levels_spec => [] [[inw eq] eq']. - subst n'. noconf eq'. split => //. lia. - - move=> [inW ->]. exists (l, k'). rewrite levelexprset_of_levels_spec. - split => //. cbn. f_equal; lia. -Qed. - -Lemma of_level_set_singleton l k hne : of_level_set (LevelSet.singleton l) k hne = singleton (l, k). -Proof. - apply eq_univ_equal. move=> [l' k']. - rewrite /of_level_set //= levelexprset_of_levels_spec !LevelExprSet.singleton_spec LevelSet.singleton_spec /LevelSet.E.eq /LevelExprSet.E.eq. - firstorder subst => //. now noconf H. now noconf H. -Qed. - -Lemma entails_of_level_set_strenghten cls W k' k prf : - k' <= k -> - cls ⊢a of_level_set W k' prf → of_level_set W (k' + 1) prf -> - cls ⊢a of_level_set W k prf → of_level_set W (k + 1) prf. -Proof. - intros le ea. - have := entails_all_shift (k - k') ea. - rewrite !add_prems_of_level_set. - have -> : k - k' + k' = k by lia. - now have -> : k - k' + (k' + 1) = k + 1 by lia. -Qed. - -Lemma strictly_updates_non_empty_init_map {cls W m m'} : - strictly_updates cls W m m' -> ~ LevelMap.Empty m. -Proof. - induction 1. - - destruct cl as [prems [concl k]]. - destruct H0 as [? [? ? heq]]. - eapply min_premise_spec_aux in H0 as [_ [[] [inprems heq']]]. - unfold min_atom_value in heq'. - destruct level_value eqn:hl => //. apply level_value_MapsTo' in hl. - now intros e; apply e in hl. - - auto. -Qed. - -Lemma strictly_updates_defined_init_map {cls W m m'} : - strictly_updates cls W m m' -> defined_map m. -Proof. - induction 1. - - destruct cl as [prems [concl k]]. - destruct H0 as [? [? ? heq]]. - eapply min_premise_spec_aux in H0 as [_ [[] [inprems heq']]]. - unfold min_atom_value in heq'. - destruct level_value eqn:hl => //. apply level_value_MapsTo' in hl. - now exists t, z0. - - auto. -Qed. - -Lemma check_model_ne_init_map {cls V U minit m W m'} : - [/\ clauses_levels cls ⊂_lset V, only_model_of V minit & is_update_of cls U minit m] -> - check_model cls (U, m) = Some (W, m') -> - ~ LevelMap.Empty minit. -Proof. - intros [_ _ isupd] check. - eapply check_model_is_update_of in check as [su incl]; tea. - rewrite union_idem in su. - now eapply strictly_updates_non_empty_init_map in su. -Qed. - - Lemma check_model_defined_init_map {cls V U minit m W m'} : [/\ clauses_levels cls ⊂_lset V, only_model_of V minit & is_update_of cls U minit m] -> check_model cls (U, m) = Some (W, m') -> @@ -3375,15 +723,6 @@ Proof. now eapply strictly_updates_defined_init_map in su. Qed. -Lemma check_model_ne_map {cls U m W m'} : - check_model cls (U, m) = Some (W, m') -> - ~ LevelMap.Empty m'. -Proof. - intros check. - eapply check_model_spec in check as [W' [su incl]]; tea. - now eapply strictly_updates_non_empty_map in su. -Qed. - Lemma check_model_defined_map {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> defined_map m'. @@ -3481,7 +820,6 @@ Proof. eapply check_model_is_update_of in eqm' as [eqm' incl']; tea. rewrite ClausesProp.union_sym union_with_concl in eqm'. have WcW := model_incl mwc. - (* destruct hsub' as [UWc WcW]. *) have w_incl := strictly_updates_incl eqm. have wcls_incl := strictly_updates_incl eqm'. assert (exists l, LevelSet.In l Wcls /\ ~ LevelSet.In l W). @@ -3529,2380 +867,4 @@ Qed. Transparent lexprod_rel_wf. -Lemma add_prems_0 u : add_prems 0 u = u. -Proof. - rewrite /add_prems. - apply eq_univ_equal. - intros x. rewrite map_spec. - split. - - intros[e [hin ->]]. unfold add_expr. now destruct e; rewrite Z.add_0_r. - - intros inu; exists x. split => //. destruct x. now rewrite /add_expr Z.add_0_r. -Qed. - -Lemma entails_all_tauto cls u : cls ⊢a u → u. -Proof. - intros x hin. now constructor. -Qed. - -Lemma loop_any_successor cls u n : - cls ⊢a u → succ_prems u -> - cls ⊢a u → add_prems (Z.of_nat (S n)) u. -Proof. - induction n. - - auto. - - intros ass. - specialize (IHn ass). - have sh := entails_all_shift 1 IHn. - eapply entails_all_trans. tea. - rewrite add_prems_add_prems in sh. - have eq : 1 + Z.of_nat (S n) = Z.of_nat (S (S n)) by lia. - now rewrite eq in sh. -Qed. - -Lemma entails_pred_closure_neg {cls u concl k p} : - cls ⊢ u → (concl, k) -> - cls ⊢ u → (concl, k + Z.neg p). -Proof. - intros ent. - eapply (entails_pred_closure_n (n := Pos.to_nat p)). - have eq : Z.neg p + Z.of_nat (Pos.to_nat p) = 0. lia. - now rewrite -Z.add_assoc eq Z.add_0_r. -Qed. - -Lemma loop_any cls u n : - cls ⊢a u → succ_prems u -> - cls ⊢a u → add_prems n u. -Proof. - destruct n. - - rewrite add_prems_0. intros _. apply entails_all_tauto. - - assert (exists n, Z.pos p = Z.of_nat n). exists (Pos.to_nat p). now rewrite Z_of_pos_alt. - destruct H as [n ->]. destruct n. cbn. intros. rewrite add_prems_0. apply entails_all_tauto. - apply loop_any_successor. - - intros _ [l k]. rewrite In_add_prems. - intros [[] [hin heq]]. rewrite /add_expr in heq. noconf heq. - apply entails_pred_closure_neg. - now constructor. -Qed. - -Lemma univ_non_empty (u : premises) : ~ LevelSet.Empty (levels u). -Proof. intros he. have := t_ne u. move/not_Empty_is_empty. - intros he'. apply he'. intros [l k] hin. red in he. specialize (he l). apply he. - rewrite levelexprset_levels_spec. now exists k. -Qed. - -(* -Lemma loop_max cls (u : premises) : - cls ⊢a of_level_set (levels u) (premise_max u) (univ_non_empty u) → u. -Proof. - intros [l k] hin. - apply (entails_pred_closure_n (n := premise_max u - k)). - constructor. - rewrite levelexprset_of_levels_spec. split. - - apply levelexprset_levels_spec. now exists k. - - have [min _] := premise_max_spec u. - apply min in hin. cbn in hin. lia. -Qed. - -Lemma loop_any_max cls u n : - cls ⊢a u → add_prems n u -> - cls ⊢a of_level_set (levels u) (premise_max u) (univ_non_empty u) → add_prems n u. -Proof. - intros hl. eapply entails_all_trans; tea. now eapply loop_max. -Qed. - -Lemma loop_any_max_all cls u : - cls ⊢a u → succ_prems u -> - cls ⊢a of_level_set (levels u) (premise_max u) (univ_non_empty u) → - of_level_set (levels u) (premise_max u + 1) (univ_non_empty u). -Proof. - intros hl. eapply entails_all_trans; tea. - eapply (loop_any_max _ _ (premise_max u + 1)). now eapply loop_any. - intros [l k]. - rewrite levelexprset_of_levels_spec => [] []. - rewrite levelexprset_levels_spec => [] [k' hin] ->. - eapply (entails_pred_closure_n (n := k')). - constructor. rewrite In_add_prems. - exists (l, k'). split => //. rewrite /add_expr. lia_f_equal. -Qed. -*) - -(* To handle the constraint inference problem, - we must start with a model where all atoms [l + k] - appearing in premises are true. Otherwise the - [l := 0] model is minimal for [l+1-> l+2]. - Starting with [l := 1], we see that the minimal model above it - has [l := ∞]. - We also ensure that all levels in the conclusions are in the model. - *) - -Definition maximal_prem l n cls := - Clauses.For_all (fun cl => forall n', LevelExprSet.In (l, n') (premise cl) -> n' <= n) cls. - -Definition max_opt_of {A} (max : A -> A -> A) (x : option A) (y : option A) : option A := - match x, y with - | Some x, Some y => Some (max x y) - | Some x, None => Some x - | _, _ => y - end. - -Definition max_premise_of l (u : premises) : option Z := - LevelExprSet.fold (fun '(l', k) acc => if eqb l l' then - max_opt_of Z.max (Some k) acc else acc) u None. - -Lemma max_premise_of_spec l k (u : premises) : LevelExprSet.In (l, k) u -> Some k ≤ max_premise_of l u. -Proof. - rewrite /max_premise_of. - eapply LevelExprSetProp.fold_rec. - - intros s' he hin. now apply he in hin. - - intros x a s' s'' hin nin hadd hle. - intros hs''. destruct x. - apply hadd in hs'' as []. - * noconf H. rewrite eqb_refl. destruct a; cbn. constructor. lia. reflexivity. - * elim: eqb_spec; try intros ->; - specialize (hle H); depelim hle; cbn; constructor; lia. -Qed. - -Definition max_clause_premise_of l (cls : clauses) := - Clauses.fold (fun cl acc => max_opt_of Z.max (max_premise_of l (premise cl)) acc) cls None. - -Lemma max_clause_premise_of_spec l k cls : - forall cl, Clauses.In cl cls -> LevelExprSet.In (l, k) (premise cl) -> Some k ≤ max_clause_premise_of l cls. -Proof. - rewrite /max_clause_premise_of => cl. - eapply ClausesProp.fold_rec. - - intros s' he hin. now apply he in hin. - - intros x a s' s'' hin nin hadd hle. - intros hs''. destruct x. - apply hadd in hs'' as []. - * noconf H. cbn. move/max_premise_of_spec. - intros h; etransitivity; tea. destruct (max_premise_of l n), a; cbn; constructor; lia. - * intros h; specialize (hle H h). depelim hle. cbn. - destruct (max_premise_of l n); cbn; constructor; lia. -Qed. - -Definition max_clause_premises cls : model := - let ls := clauses_levels cls in - let fn l m := LevelMap.add l (max_clause_premise_of l cls) m in - LevelSet.fold fn ls (LevelMap.empty _). - -Lemma max_clause_premises_spec l k cls : - LevelMap.MapsTo l k (max_clause_premises cls) -> - LevelSet.In l (clauses_levels cls) /\ k = max_clause_premise_of l cls. -Proof. - unfold max_clause_premises. - eapply LevelSetProp.fold_rec. - - intros s' he hm. now rewrite LevelMapFact.F.empty_mapsto_iff in hm. - - intros x a s' s'' hin hnin hadd ih. - rewrite LevelMapFact.F.add_mapsto_iff. - intros [[-> [= <-]]|[]] => //. - * split => //. apply hadd. now left. - * split => //. apply hadd; now right. now apply ih. -Qed. - -Lemma max_clause_premises_spec_inv cls : - forall l, LevelSet.In l (clauses_levels cls) -> - LevelMap.MapsTo l (max_clause_premise_of l cls) (max_clause_premises cls). -Proof. - unfold max_clause_premises. - eapply LevelSetProp.fold_rec. - - intros s' he hm. now move/he. - - intros x a s' s'' hin hnin hadd ih l ls''. - rewrite LevelMapFact.F.add_mapsto_iff. - destruct (eq_dec x l). subst. - * now left. - * right. split => //. apply ih. eapply hadd in ls''. destruct ls''; auto. contradiction. -Qed. - -Definition init_model cls := max_clause_premises cls. - -Lemma init_model_levels cls k : - LevelMap.In k (init_model cls) <-> LevelSet.In k (clauses_levels cls). -Proof. - split. - - now move => [] k' /max_clause_premises_spec. - - move/max_clause_premises_spec_inv. now eexists. -Qed. - -Definition init_w (levels : LevelSet.t) : LevelSet.t := LevelSet.empty. - -(* We don't need predecessor clauses as they are trivially satisfied *) -(* Definition add_predecessors (V : LevelSet.t) cls := - LevelSet.fold (fun l acc => - Clauses.add (NonEmptySetFacts.singleton (l, 1), (l, 0)) acc) V cls. *) - -Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). - -Equations? infer (cls : clauses) : infer_result (clauses_levels cls) cls := - infer cls := loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (init_model cls) (And3 _ _ _). -Proof. - - reflexivity. - - intros k. now rewrite -init_model_levels. - - apply is_update_of_empty. -Qed. - -Local Open Scope string_scope2. - -Definition print_level_Z_map (m : LevelMap.t (option Z)) := - let list := LevelMap.elements m in - print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_option string_of_Z w) nl list. - -Definition print_result {V cls} (m : infer_result V cls) := - match m return string with - | Loop _ _ => "looping on " - | Model w m _ => "satisfiable with model: " ^ print_level_Z_map m.(model_model) ^ nl ^ " W = " ^ - print_lset w - ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model m.(model_model)) - end. - -Definition valuation_of_result {V cls} (m : infer_result V cls) := - match m with - | Loop _ _ => "looping" - | Model w m _ => print_level_nat_map (valuation_of_model m.(model_model)) - end. - -Definition to_string_expr (e : LevelExpr.t) : string := - let '(l, n) := e in Level.to_string l ^ (if n is Z0 then "" else "+" ^ string_of_Z n). - -Definition print_premise (l : premises) : string := - let (e, exprs) := NonEmptySetFacts.to_nonempty_list l in - to_string_expr e ^ - match exprs with - | [] => "" - | l => ", " ^ print_list to_string_expr ", " exprs - end. - -Definition print_clauses (cls : clauses) := - let list := Clauses.elements cls in - print_list (fun '(l, r) => - print_premise l ^ " → " ^ to_string_expr r) nl list. - -Definition clauses_of_list := ClausesProp.of_list. -Definition list_of_clauses := Clauses.elements. -Definition valuation := LevelMap.t nat. - -Definition premises_model_map (m : model) cls : model := - let levels := clauses_premises_levels cls in - LevelSet.fold (fun l acc => - LevelMap.add l (max_clause_premise_of l cls) acc) levels m. - -Variant checking_result (cls : clauses) (cl : clause) : Type := - | DoesNotHold : ~ entails cls cl -> checking_result cls cl - | Entails : entails cls cl -> checking_result cls cl. - -Definition zero_model levels : model := - LevelSet.fold (fun l acc => LevelMap.add l None acc) levels (LevelMap.empty _). - -Definition premises_model V cl : LevelSet.t * model := - let levels := LevelSet.union (clause_levels cl) V in - (levels, premises_model_map (zero_model levels) (Clauses.singleton cl)). - -Lemma premises_model_map_spec m cls : - forall l k, - LevelMap.MapsTo l k (premises_model_map m cls) <-> - ((LevelSet.In l (clauses_premises_levels cls) /\ k = max_clause_premise_of l cls /\ isSome k) \/ - (~ LevelSet.In l (clauses_premises_levels cls) /\ LevelMap.MapsTo l k m)). -Proof. - intros l k; rewrite /premises_model_map. - eapply LevelSetProp.fold_rec. - - intros s' he. split. intros hm. right. split => //. - firstorder. - - intros x a s' s'' hin hnin hadd ih. - split. - * rewrite LevelMapFact.F.add_mapsto_iff. - firstorder. subst k. red in H; subst. firstorder. - left; firstorder. - apply clauses_premises_levels_spec in hin as [cl [incl inlev]]. - apply levelexprset_levels_spec in inlev as [k inprem]. - have hs := max_clause_premise_of_spec l k cls cl incl inprem. - depelim hs. now rewrite H3. - * intros [[hin' [-> iss]]|]. - rewrite LevelMapFact.F.add_mapsto_iff. - destruct (eq_dec x l); subst; firstorder. - destruct (eq_dec x l); subst; firstorder. - rewrite LevelMapFact.F.add_mapsto_iff. right; split => //. -Qed. - -Lemma premises_model_map_in m cls l : - LevelMap.In l (premises_model_map m cls) <-> (LevelSet.In l (clauses_premises_levels cls) \/ LevelMap.In l m). -Proof. - rewrite /premises_model_map. - eapply LevelSetProp.fold_rec. - - intros s' he. firstorder. - - intros x a s' s'' hin hnin hadd ih. - rewrite LevelMapFact.F.add_in_iff. - firstorder. -Qed. - -Lemma zero_model_spec {l ls n} : LevelMap.MapsTo l n (zero_model ls) <-> LevelSet.In l ls /\ n = None. -Proof. - unfold zero_model. - eapply LevelSetProp.fold_rec. - - intros s' he. rewrite LevelMapFact.F.empty_mapsto_iff. firstorder. - - intros x a s s' hin hnin hadd eq. - rewrite LevelMapFact.F.add_mapsto_iff. firstorder. - destruct (eq_dec x l). - * subst. now left. - * right. split => //. apply hadd in H1. destruct H1; try congruence. now apply H0. -Qed. - -Lemma in_premises_model V cl : - forall l, - LevelMap.In l (premises_model V cl).2 <-> - LevelSet.In l V \/ LevelSet.In l (clause_levels cl). -Proof. - intros l. rewrite premises_model_map_in. - rewrite clauses_premises_levels_spec. - firstorder. - - right. apply Clauses.singleton_spec in H. - apply clause_levels_spec. left. now subst. - - apply zero_model_spec in H as [hin ->]. - apply LevelSet.union_spec in hin. firstorder. - - right. exists None. apply zero_model_spec. split => //; lsets. - - eapply clause_levels_spec in H as [H|H]. - * left. exists cl. split => //. now apply Clauses.singleton_spec. - * subst. right. exists None. apply zero_model_spec. split => //. - apply LevelSet.union_spec. left. apply clause_levels_spec. now right. -Qed. - -Lemma clauses_levels_add {n cls} : clauses_levels (add_clauses n cls) =_lset clauses_levels cls. -Proof. - rewrite /clauses_levels. - symmetry. - apply ClausesProp.fold_rec. - - intros s' he l. rewrite LevelSetFact.empty_iff. split => //. - move/clauses_levels_spec => [] cl []. - move/in_add_clauses => [] cl' [] hin ->. - now apply he in hin. - - intros x a s s' incls nins hadd -> l. - rewrite LevelSet.union_spec !clauses_levels_spec. - rewrite clause_levels_spec. - split. - * move => [[hin|->]|]. - { exists (add_clause n x). split => //. apply add_clauses_spec. apply hadd. now left. - rewrite clause_levels_spec. left. move: hin. rewrite !levelexprset_levels_spec. - intros [k hin]; exists (k + n). destruct x as [prems concl]. cbn. - apply In_add_prems. exists (l, k). split => //. } - { exists (add_clause n x). rewrite -add_clauses_spec. split => //. apply hadd. now left. - rewrite clause_levels_spec. right. - destruct x; cbn. destruct p => //. } - { intros [cl [hin hl]]; exists cl. split => //. - move/in_add_clauses: hin => [cl' [incl' ->]]. - apply add_clauses_spec. now apply hadd. } - * move=> [] cl [] /in_add_clauses [[prems concl] [incl' ->]] /clause_levels_spec. - apply hadd in incl' as [->|ins]. - { move=> [hin|->]. left. left. move/levelexprset_levels_spec: hin => [] k. cbn [premise add_clause]. cbn. - move/In_add_prems => [] [l' k'] [] hinle' [=] -> _. - apply levelexprset_levels_spec. now exists k'. - now left; right; destruct concl. } - { cbn. move=> [hin|->]. - { right. exists (add_clause n (prems, concl)). - split. now apply add_clauses_spec. - apply clause_levels_spec. left. apply levelexprset_levels_spec in hin as [k hin]. - apply In_add_prems in hin as [[l' k'] [hin eq]]. noconf eq. - apply levelexprset_levels_spec. exists (k' + n). eapply In_add_prems. - now exists (l, k'). } - { right. exists (add_clause n (prems, concl)). - split. now apply add_clauses_spec. - apply clause_levels_spec. now right. } } -Qed. - -Equations? infer_model (cls : clauses) : option model := -infer_model cls with loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (init_model cls) _ := - | Loop _ _ => None - | Model w vm heq => Some vm.(model_model). -Proof. - split. - - reflexivity. - - apply infer_obligation_2. - - apply is_update_of_empty. -Qed. - -Definition enabled_clause (m : model) (cl : clause) := - exists z, min_premise m (premise cl) = Some z. - -Definition enabled_clauses (m : model) (cls : clauses) := - Clauses.For_all (enabled_clause m) cls. - -Definition correct_model (cls : clauses) (m : model) := - enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. - -Definition infer_correctness cls := - match infer_model cls with - | Some m => correct_model cls m - | None => ~ exists v, clauses_sem v cls - end. - -Lemma enabled_clauses_ext m m' cls : m ⩽ m' -> enabled_clauses m cls -> enabled_clauses m' cls. -Proof. - intros hext. - rewrite /enabled_clauses. - intros ha cl; move/ha. - unfold enabled_clause. - intros [minp heq]. - have hp := min_premise_pres (premise cl) hext. - rewrite heq in hp. depelim hp. now exists y. -Qed. - -Lemma interp_prems_ge v (prems : premises) : - forall prem, LevelExprSet.In prem prems -> - interp_expr v prem <= interp_prems v prems. -Proof. - intros. - unfold interp_prems. - have he := to_nonempty_list_spec prems. - destruct to_nonempty_list. - pose proof to_nonempty_list_spec'. - rewrite In_elements in H. rewrite -he in H. clear H0 he. clear -H. - destruct H. subst p. - - induction l. cbn. auto. - cbn. lia. cbn. lia. - - induction l in H |- *. - now cbn in H. - cbn in H. destruct H; subst; cbn. - * cbn. lia. - * specialize (IHl H). lia. -Qed. - -(** Enabled and valid clauses are satisfied by valuation *) -Lemma valid_clause_model model cl : - enabled_clause model cl -> - valid_clause model cl -> - clause_sem (valuation_of_model model) cl. -Proof. - unfold enabled_clause, valid_clause. - destruct min_premise eqn:hmin => //= => //. - 2:{ intros [k' eq]. congruence. } - intros [k' eq]. noconf eq. - destruct cl as [prems [concl k]]; cbn. - unfold level_value_above. - destruct level_value eqn:hl => //. - unfold interp_level. unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. - move/Z.leb_le => hrel. - eapply LevelMap.find_2 in hfind. - have conclm := valuation_of_model_spec _ _ _ hfind. - set (v := (model_max _ - _)) in *. - cbn in conclm. - eapply LevelMap.find_1 in conclm. rewrite conclm. - subst v. - pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. - rewrite hmin in premeq. - eapply Z.le_ge. - eapply Z.le_trans. 2:{ eapply interp_prems_ge; tea. } - unfold interp_expr. destruct prem as [prem k']. - symmetry in premeq. - move: premeq. unfold min_atom_value. - unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. - destruct o => //. - intros [= <-]. - eapply LevelMap.find_2 in findp. - have premm := valuation_of_model_spec _ _ _ findp. - unfold interp_level. - eapply LevelMap.find_1 in premm. rewrite premm. - assert (z1 - k' <= z0 - k). lia. - have hm : z0 <= model_max model. - { eapply model_max_spec in hfind; tea. now depelim hfind. } - have hm' : z1 <= model_max model. - { eapply model_max_spec in findp; tea. now depelim findp. } - have hmi : model_min model <= z0. - { eapply model_min_spec; tea. } - have hmi' : model_min model <= z1. - { eapply model_min_spec; tea. } - assert (0 <= model_max model)%Z by apply model_max_spec2. - assert (model_min model <= 0)%Z by apply model_min_spec2. - lia. -Qed. - -Lemma init_model_enabled cls : enabled_clauses (init_model cls) cls. -Proof. - unfold enabled_clauses. - intros x hin. unfold enabled_clause. - pose proof (@min_premise_spec (init_model cls) (premise x)) as [premmin [prem [premin premeq]]]. - have inV : LevelSet.In prem (clauses_levels cls). - { rewrite clauses_levels_spec. exists x; split => //. rewrite /clause_levels. - eapply LevelSet.union_spec; left. rewrite levelexprset_levels_spec. exists prem.2. - destruct prem. exact premin. } - unfold init_model. rewrite premeq. unfold min_atom_value. - destruct prem as [l k]. - have hm := max_clause_premises_spec_inv cls l inV. - rewrite (level_value_MapsTo hm). - have hs := max_clause_premise_of_spec l k _ _ hin premin. - depelim hs. rewrite H0. - eexists => //. -Qed. - -Lemma interp_add_expr V n e : interp_expr V (add_expr n e) = n + interp_expr V e. -Proof. - destruct e as [l k]; cbn. lia. -Qed. - -(* From Stdlib Require Import Structures.OrdersEx. - -Module Nat_as_OT. - Include OrdersEx.Nat_as_DT. - - Lemma eq_leibniz : forall x y, eq x y -> Logic.eq x y. - Proof. auto. Qed. - -End Nat_as_OT. - -Module NatSet := MSetList.MakeWithLeibniz Nat_as_OT. *) - -Lemma interp_prems_singleton V e : - interp_prems V (singleton e) = interp_expr V e. -Proof. - rewrite /interp_prems. - now rewrite singleton_to_nonempty_list /=. -Qed. - - (*have leq : (interp_expr V cl <= fold_right (fun x acc : nat => Nat.max x acc) 0 - (map (interp_expr V) (rev (LevelExprSet.elements u)))). - { eapply fold_right_max_in. - apply in_map_iff. exists cl. split => //. - rewrite -In_rev. apply InA_In_eq. - now apply LevelExprSet.elements_spec1. } - lia. - unshelve erewrite LevelExprSetProp.fold_add => //. 1-2:tc. red; lia. -Qed.*) - -Lemma fold_right_max_in {a l} n : In a l -> a <= fold_right Z.max n l. -Proof. - induction l. - - now cbn. - - intros [eq|inl]. subst a0. cbn. lia. - cbn. specialize (IHl inl). lia. -Qed. - -Lemma fold_right_max_acc {n l} : n <= fold_right Z.max n l. -Proof. - induction l. - - now cbn. - - cbn. lia. -Qed. - -Lemma fold_right_impl n l l' : - (forall x, In x l -> In x l') -> fold_right Z.max n l <= fold_right Z.max n l'. -Proof. - induction l in l' |- *. - - cbn. destruct l'; cbn. lia. - intros. have := @fold_right_max_acc n l'. lia. - - cbn; intros h. - have inal' := (h a (or_introl eq_refl)). - have := fold_right_max_in n inal'. - specialize (IHl l'). - forward IHl. - intros. apply h. now right. - lia. -Qed. - -Lemma fold_right_equivlist n l l' : - equivlistA eq l l' -> fold_right Z.max n l = fold_right Z.max n l'. -Proof. - intros eq. - have h := fold_right_impl n l l'. - forward h. intros x; rewrite -!InA_In_eq. apply eq. - have h' := fold_right_impl n l' l. - forward h'. intros x; rewrite -!InA_In_eq. apply eq. - lia. -Qed. - -Fixpoint max_list (l : list Z) : option Z := - match l with - | [] => None - | x :: xs => match max_list xs with - | Some m => Some (Z.max x m) - | None => Some x end - end. - -Lemma max_list_fold_right n l : max_list (n :: l) = Some (fold_right Z.max n l). -Proof. - induction l; cbn. - - reflexivity. - - cbn in IHl. destruct max_list. f_equal. noconf IHl. lia. - f_equal; noconf IHl. lia. -Qed. - -Lemma fold_right_max_spec n l : - let fn := fold_right Z.max in - (forall x, In x (n :: l) -> x <= fn n l) /\ - (exists x, In x (n :: l) /\ fn n l = x). -Proof. - induction l; cbn. - - split. intros x [] => //. now subst. - exists n. firstorder. - - cbn in IHl. destruct IHl as [h h']. - split. - intros x [|[]]; subst. - * specialize (h x). forward h by auto. lia. - * lia. - * specialize (h x). forward h by auto. lia. - * destruct h' as [x []]. exists (Z.max a x). rewrite -{4}H0. split => //. - destruct H; subst. - destruct (Z.max_spec a x) as [[]|[]]; firstorder; subst. - destruct (Z.max_spec a (fold_right Z.max n l)) as [[]|[]]; firstorder; subst. rewrite H1. - auto. -Qed. - -(* -Lemma maX_list_equivlist l l' : - equivlistA eq l l' -> max_list l = max_list l'. -Proof. - induction l in l' |- *; destruct l'; cbn; auto. - - move/(_ z) => [] _. rewrite InA_In_eq. move/(_ (or_introl eq_refl)). - intros ina; depelim ina. - - now move/(_ a) => []; rewrite !InA_In_eq => /(_ (or_introl eq_refl)). - - intros eql. - rewrite INa eqnc. intros [eqnc eqnc']. - *) - - -Lemma fold_right_equivlist_all n n' l l' : - equivlistA eq (n :: l) (n' :: l') -> fold_right Z.max n l = fold_right Z.max n' l'. -Proof. - intros eq. - have [hla [maxl [inmaxl eqmaxl]]] := fold_right_max_spec n l. - have [hra [maxr [inmaxr eqmaxr]]] := fold_right_max_spec n' l'. - rewrite eqmaxl eqmaxr. - red in eq; setoid_rewrite InA_In_eq in eq. - apply (eq _) in inmaxl. apply hra in inmaxl. - apply eq in inmaxr. apply hla in inmaxr. lia. -Qed. - -Lemma interp_prems_elements V u : - interp_prems V u = fold_right Z.max (interp_expr V (to_nonempty_list u).1) (map (interp_expr V) (to_nonempty_list u).2). -Proof. - rewrite /interp_prems. - have he := to_nonempty_list_spec u. - destruct to_nonempty_list. - now rewrite Universes.fold_right_map. -Qed. - -Lemma fold_right_interp {V x l x' l'} : - equivlistA eq (x :: l) (x' :: l') -> - fold_right Z.max (interp_expr V x) (map (interp_expr V) l) = fold_right Z.max (interp_expr V x') (map (interp_expr V) l'). -Proof. - intros eq. apply fold_right_equivlist_all. - intros a. rewrite !InA_In_eq. - rewrite !(in_map_iff (interp_expr V) (_ :: _)). - setoid_rewrite <-InA_In_eq. - split. - - move=> [b [<- ]]. - eexists; split; trea. now apply eq in b0. - - move=> [b [<- ]]. - eexists; split; trea. now apply eq in b0. -Qed. - -Lemma equivlistA_add le u : let l := to_nonempty_list (add le u) in - equivlistA eq (l.1 :: l.2) (le :: LevelExprSet.elements u). -Proof. - have he := to_nonempty_list_spec (add le u). - destruct to_nonempty_list. cbn. - intros x. rewrite he. - rewrite !LevelExprSet.elements_spec1. - split. - - move/LevelExprSet.add_spec => [->|hin]. - now constructor. constructor 2. now apply LevelExprSet.elements_spec1. - - intros h; depelim h; subst. now apply LevelExprSet.add_spec; left. - apply LevelExprSet.add_spec. now apply LevelExprSet.elements_spec1 in h. -Qed. - -Lemma fold_right_comm acc l : l <> [] -> fold_right Z.max acc l = Z.max acc (fold_right Z.max (List.hd acc l) (List.tl l)). -Proof. - induction l in acc |- *. - - intros; congruence. - - intros _. cbn. destruct l; cbn. lia. - cbn in IHl. rewrite (IHl acc). congruence. - rewrite (IHl a). congruence. lia. -Qed. - -Lemma interp_prems_add V le (u : premises) : - interp_prems V (add le u) = Z.max (interp_expr V le) (interp_prems V u). -Proof. - rewrite 2!interp_prems_elements. - erewrite fold_right_interp. 2:apply equivlistA_add. - rewrite fold_right_comm. - { apply map_nil, elements_not_empty. } - f_equal. eapply fold_right_equivlist_all. - have he := to_nonempty_list_spec u. - destruct to_nonempty_list. rewrite -he //=. -Qed. - -Lemma interp_prems_eq (P : premises -> Z -> Prop) V : - (forall le, P (singleton le) (interp_expr V le)) -> - (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (add le u) (Z.max (interp_expr V le) k)) -> - forall u, P u (interp_prems V u). -Proof. - intros hs hadd. - eapply premises_elim. - - intros le. rewrite interp_prems_singleton. apply hs. - - intros le prems ih hnin. - rewrite interp_prems_add. now apply hadd. -Qed. - -Lemma add_prems_singleton n cl : add_prems n (singleton cl) = singleton (add_expr n cl). -Proof. - apply eq_univ_equal => [] [l k]. - rewrite In_add_prems LevelExprSet.singleton_spec. - firstorder. - - destruct x; noconf H0. - eapply LevelExprSet.singleton_spec in H. - now red in H; noconf H. - - destruct cl. exists (t, z). split => //. - red in H; noconf H. now apply LevelExprSet.singleton_spec. -Qed. - -Lemma interp_add_prems V n e : interp_prems V (add_prems n e) = n + interp_prems V e. -Proof. - revert e. - refine (interp_prems_eq (fun u z => interp_prems V (add_prems n u) = n + z) _ _ _). - - intros le. - rewrite add_prems_singleton interp_prems_singleton //=. - destruct le; cbn. lia. - - intros le u k heq hnin. - rewrite add_prems_add. - rewrite interp_prems_add heq interp_add_expr. lia. -Qed. - -Lemma in_pred_closure_entails cls cl : - in_pred_closure cls cl -> - (forall V, clauses_sem V cls -> clause_sem V cl). -Proof. - induction 1. - - intros V. rewrite /clauses_sem. intros ha. - apply ha in H. - move: H; rewrite /clause_sem. - destruct cl as [prems concl]. - cbn. rewrite interp_add_prems. - destruct concl as [concl conclk]. - rewrite /add_expr; cbn. lia. - - intros V clsm. cbn. - rewrite interp_prems_singleton. - cbn. lia. -Qed. - -Lemma interp_prems_in {V le} {u : premises} : LevelExprSet.In le u -> interp_prems V u >= interp_expr V le. -Proof. - revert u. - refine (interp_prems_eq (fun u z => LevelExprSet.In le u -> z >= interp_expr V le) V _ _). - - intros le' u'. - apply LevelExprSet.singleton_spec in u'. red in u'; subst. lia. - - move=> le' u z hz hnin /LevelExprSet.add_spec [->|hin]. lia. - specialize (hz hin). lia. -Qed. - -Lemma clauses_sem_subset {u u' : premises} : u ⊂_leset u' -> - forall V, interp_prems V u' >= interp_prems V u. -Proof. - intros hsub V. - revert u u' hsub. - refine (interp_prems_eq (fun u z => forall u' : premises, u ⊂_leset u' -> interp_prems V u' >= z) V _ _). - - intros le u' hsing. - specialize (hsing le). forward hsing by now apply LevelExprSet.singleton_spec. - now apply interp_prems_in. - - intros le u k ih hin u' sub. - have hle := sub le. - specialize (ih u'). - forward ih. intros x hin'. apply sub. now apply LevelExprSet.add_spec; right. - forward hle by now apply LevelExprSet.add_spec; left. - have hi := interp_prems_in (V := V) hle. lia. -Qed. - -#[refine] Instance ge_refl : Reflexive Z.ge := _. -Proof. red. lia. Qed. - -#[refine] Instance ge_trans : Transitive Z.ge := _. -Proof. red. lia. Qed. - -Lemma clauses_sem_entails {cls cl} : - entails cls cl -> - (forall V, clauses_sem V cls -> clause_sem V cl). -Proof. - induction 1. - - intros v clls. red. - destruct concl0 as [concl k]. - have hge := interp_prems_ge v prems _ H. - by lia. - - move=> V Hcls. - move: {IHentails} (IHentails _ Hcls). - unfold clause_sem. unfold ge => hyp. - etransitivity; tea. rewrite interp_prems_add. - rewrite interp_prems_add in hyp. - eapply in_pred_closure_entails in H; tea. - move: H; rewrite /clause_sem. unfold ge. - have ssub := clauses_sem_subset H1 V. lia. -Qed. - -Lemma clauses_sem_entails_all {cls prems concl} : - cls ⊢a prems → concl -> - (forall V, clauses_sem V cls -> interp_prems V prems >= interp_prems V concl). -Proof. - intros ha V hcls. - red in ha. - move: ha. - revert concl. - refine (@interp_prems_eq (fun concl z => _ -> interp_prems V prems >= z) V _ _). - - move=> le //=. move/(_ le). - intros h; forward h by now apply LevelExprSet.singleton_spec. - now have ent := (clauses_sem_entails h _ hcls). - - intros le u k ih hnin. - intros hf. - forward ih. intros x hin; apply (hf x). - rewrite LevelExprSet.add_spec; now right. - specialize (hf le). - forward hf by now apply LevelExprSet.add_spec; left. - cbn in hf. - have ent := (clauses_sem_entails hf _ hcls). cbn in ent. - lia. -Qed. - -Lemma infer_correct cls : infer_correctness cls. -Proof. - unfold infer_correctness. - destruct infer_model as [m|] eqn:hi. - - (* Correct *) move: hi. - funelim (infer_model cls) => //. - intros [= <-]. - set (obl := infer_model_obligation_1 cls). clearbody obl. - clear Heq Heqcall. - have mincl := model_incl vm. - destruct vm as [model ofV isupd clsconcl ism]; cbn in *. - set (V := clauses_levels cls) in *. - unfold correct_model. - have encl : enabled_clauses model cls. - { eapply enabled_clauses_ext. apply is_update_of_ext in isupd. exact isupd. - apply init_model_enabled. } - split => //. - unfold clauses_sem. - intros cl hin. - eapply valid_clause_model. now eapply encl in hin. - eapply Clauses.for_all_spec in ism; tc. now specialize (ism _ hin). - - intros [v clssem]. - move: hi. - funelim (infer_model cls) => //. intros _. - red in islooping. - have sem := clauses_sem_entails_all islooping v0. - specialize (sem clssem). - rewrite interp_add_prems in sem. lia. -Qed. - -Definition valid_entailment cls cl := forall V, clauses_sem V cls -> clause_sem V cl. - -Program Definition loop_check cls (cl : clause) : result (premises_model (clauses_levels cls) cl).1 LevelSet.empty cls (premises_model (clauses_levels cls) cl).2 := - let V := clauses_levels cls in - loop (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 (premises_model V cl).2 _. -Next Obligation. - split => //. - - lsets. - - intros l. rewrite LevelSet.union_spec. - rewrite -/(LevelMap.In l (premises_model (clauses_levels cls) cl).2). - rewrite in_premises_model. intuition auto. - - apply is_update_of_empty. -Qed. - -Definition premises_of_level_set (l : LevelSet.t) := - LevelSet.fold (fun l acc => (l, 0) :: acc) l []. - -Definition extendV V (cl : clause) := - let '(prems, concl) := cl in - (add_list (premises_of_level_set V) prems, concl). - -Lemma premises_model_map_min_premise {levels cls prems z} : - min_premise (premises_model_map (zero_model levels) cls) prems = Some z -> - (exists minp mink, LevelExprSet.In (minp, mink) prems /\ - exists maxp, max_clause_premise_of minp cls = Some maxp /\ - z = maxp - mink) \/ - (exists minp mink, LevelExprSet.In (minp, mink) prems /\ z + mink <= 0)%Z. -Proof. - set (m := premises_model_map _ _). - have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m prems. - rewrite mineq. rewrite /min_atom_value. - destruct level_value eqn:hl => //. intros [= <-]. - eapply level_value_MapsTo' in hl. - eapply premises_model_map_spec in hl as [[inpcls [hm _]]|[ninpcls h']]. left. - 2:{ apply zero_model_spec in h' as [h' [= ->]]. } - exists minp, mink. split => //. noconf hm. rewrite -hm. - eexists; split => //. -Qed. - -Lemma premises_model_map_min_premise_inv {levels cls} : - forall cl, Clauses.In cl cls -> - exists z, min_premise (premises_model_map (zero_model levels) cls) (premise cl) = Some z /\ (0 <= z)%Z. -Proof. - set (m := premises_model_map _ _). - move=> cl hin. - have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m (premise cl). - rewrite mineq. rewrite /min_atom_value. - destruct level_value eqn:hl => //. - - eexists. split; trea. - have ps := proj1 (premises_model_map_spec _ cls minp (Some z)) (level_value_MapsTo' hl). - destruct ps as [[minpsl [eq _]]|]. - * symmetry in eq. - have sp := (max_clause_premise_of_spec _ _ _ _ hin inminp). - depelim sp. rewrite eq in H0. noconf H0. lia. - * destruct H. elim H. - eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. - - unfold level_value in hl. - destruct LevelMap.find eqn:hl'. subst o. - 2:{ move/LevelMapFact.F.not_find_in_iff: hl'. elim. - rewrite premises_model_map_in. left. - eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. } - eapply LevelMap.find_2 in hl'. - move/premises_model_map_spec: hl' => [[]|[nin hm]] => //. - * now intros hnminp [_ hn]. - * move: nin; elim. - eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. -Qed. - -Lemma is_update_of_entails {cls V m m' hne hne'} : is_update_of cls V m m' -> - cls ⊢a of_level_map m hne → of_level_map m' hne'. -Proof. - rewrite /is_update_of. - destruct LevelSet.is_empty. - - intros heq []. - rewrite !of_level_map_spec. rewrite -heq. - constructor. now apply of_level_map_spec. - - eapply strictly_updates_entails. -Qed. - -Lemma is_update_of_non_empty {cls V m m'} : ~ LevelMap.Empty m -> - is_update_of cls V m m' -> - ~ LevelMap.Empty m'. -Proof. - rewrite /is_update_of. destruct LevelSet.is_empty. - - now intros he <-. - - intros he su. now eapply strictly_updates_non_empty_map in su. -Qed. - -Instance defined_map_proper : Proper (LevelMap.Equal ==> iff) defined_map. -Proof. - intros x y eq; rewrite /defined_map. - now setoid_rewrite eq. -Qed. - -Lemma is_update_of_defined_map {cls V m m'} : defined_map m -> - is_update_of cls V m m' -> - defined_map m'. -Proof. - rewrite /is_update_of. destruct LevelSet.is_empty. - - now intros he <-. - - intros he su. now eapply strictly_updates_defined_map in su. -Qed. - -Lemma inj_add_prems_sub {n u u'} : add_prems n u ⊂_leset add_prems n u' -> u ⊂_leset u'. -Proof. - rewrite /add_prems. - intros hm [l k]. specialize (hm (l, k + n)). - rewrite !map_spec in hm. - intros hin. - forward hm. exists (l, k); split => //. - destruct hm as [[] [hin' eq]]. - apply (@add_expr_inj n (l, k)) in eq. now noconf eq. -Qed. - -Lemma premises_of_level_set_spec l k V : LevelSet.In l V /\ k = 0 <-> In (l, k) (premises_of_level_set V). -Proof. - rewrite /premises_of_level_set. - eapply LevelSetProp.fold_rec. - - intros s' he. firstorder. - - intros x a s' s'' hin hnin hadd ih. - red in hadd. rewrite {}hadd. - cbn. firstorder. subst. now left. noconf H1. now left. now noconf H1. -Qed. - -Lemma in_succ_add_premises {V u x k} : LevelExprSet.In (x, Z.of_nat (k + 1)) (add_list (premises_of_level_set V) u) -> LevelExprSet.In (x, Z.of_nat (k + 1)) u. -Proof. - rewrite add_list_spec. intros [hn|hn] => //. - eapply premises_of_level_set_spec in hn as []. lia. -Qed. - -(* Lemma inj_succ_prems {V u u'} : succ_prems u ⊂_leset add_list (premises_of_level_set V) u' -> succ_prems u ⊂_leset u'. -Proof. - intros sub x. rewrite In_add_prems => [] [[l k] [hin ->]]. - specialize (sub (l, Z.of_nat (k + 1))). - forward sub. - apply In_add_prems. exists (l, k). split => //. - now apply in_succ_add_premises in sub. -Qed. *) - -Lemma succ_clauses_equiv cls prems concl : - succ_clauses cls ⊢ succ_prems prems → succ_expr concl -> - cls ⊢ prems → concl. -Proof. - intros ha; depind ha. - - constructor. - move: H. - rewrite In_add_prems => [] [le [hin heq]]. - move/add_expr_inj: heq. now intros ->. - - depelim H. - + destruct cl as [prems concl]. noconf H0. - eapply in_add_clauses in H as [[prems' concl'] [hin heq]]. - noconf heq. - eapply (clause_cut _ (add_prems n prems') (add_expr n concl')). 2:eapply IHha. - 2:{ f_equal. rewrite !add_expr_add_expr. now rewrite add_prems_add add_expr_add_expr Z.add_comm. } - exact: (incls cls (prems', concl') n hin). - rewrite add_prems_add_prems in H1. rewrite Z.add_comm in H1. - rewrite -(add_prems_add_prems 1 n prems') in H1. - now move/inj_add_prems_sub: H1. - + specialize (H0 (x, k + 1)). forward H0. now apply LevelExprSet.singleton_spec. - eapply In_add_prems in H0 as [[l' k'] [hin heq]]. noconf heq. - have eq: k' = k by lia. subst k'. clear H. - eapply clause_cut. 2:eapply IHha. eapply (predcl _ x (k - 1)). - 2:{ intros x'. move/LevelExprSet.singleton_spec => ->. now have -> : k - 1 + 1 = k by lia. } - f_equal. rewrite add_prems_add. f_equal. - rewrite /succ_expr //=. lia_f_equal. -Qed. - -Lemma entails_weak_list {cls prem concl concl'} : - cls ⊢ prem → concl -> - cls ⊢ add_list concl' prem → concl. -Proof. - intros hcl. - induction concl' in prem, hcl |- *. - - exact hcl. - - cbn. eapply IHconcl'. now eapply entails_weak. -Qed. - -Lemma entails_all_weak_list {cls prem concl concl'} : - entails_all cls prem concl -> - entails_all cls (add_list concl' prem) concl. -Proof. - intros hcl x hin. - specialize (hcl _ hin). cbn in hcl. - now eapply entails_weak_list. -Qed. - -Lemma premises_of_level_set_empty : premises_of_level_set LevelSet.empty = []. -Proof. - now rewrite /premises_of_level_set LevelSetProp.fold_empty. -Qed. - -(* Lemma succ_clauses_equiv_weak cls prems concl : - succ_clauses cls ⊢ succ_prems prems → succ_expr concl -> - cls ⊢ prems → concl. -Proof. - move/(entails_weak_list (concl' := [])) => he. - eapply (succ_clauses_equiv _ LevelSet.empty). - cbn. now rewrite premises_of_level_set_empty. -Qed. *) - -Lemma entails_all_succ_clauses cls prems concl : - succ_clauses cls ⊢a succ_prems prems → succ_prems concl -> - cls ⊢a prems → concl. -Proof. - intros ha l hin. specialize (ha (succ_expr l)). forward ha. - eapply In_add_prems. exists l. split => //. cbn in ha. - now eapply succ_clauses_equiv in ha. -Qed. - -Definition entails_equiv cls u u' := - cls ⊢a u → u' /\ cls ⊢a u' → u. - -Notation "cls '⊢a' u ↔ u'" := (entails_equiv cls u u') (at level 90). - -Lemma max_premise_of_spec_aux s l k : - max_premise_of l s = k -> - (forall k', LevelExprSet.In (l, k') s -> (Some k' ≤ k)) /\ - ((exists k', LevelExprSet.In (l, k') s /\ k = Some k') \/ - ((~ exists k', LevelExprSet.In (l, k') s) /\ k = None)). -Proof. - unfold max_premise_of. - revert k. - eapply LevelExprSetProp.fold_rec. - - intros s' he k <-. cbn. split => //. - * now move=> k' /he. - * right; split => //. now move=> [] k' /he. - - intros [l' k'] a s' s'' hin hnin hadd ih k. - specialize (ih _ eq_refl) as [hle hex]. - intros hmax. - split. move=> k'0 /hadd => [] []. - { move=> [=] eq eq'. subst l' k'. rewrite eqb_refl in hmax. - destruct a; cbn in hmax; subst; constructor; lia. } - { move/hle. move: hmax. destruct (eqb_spec l l'); subst. - intros <-. intros h; depelim h; cbn. constructor; lia. - intros -> h; depelim h; constructor; lia. } - destruct hex as [[k'' [hin' heq]]|nex]. subst a. - { left. destruct (eqb_spec l l'). subst. exists (Z.max k' k''); split; trea. - 2:{ subst k. eexists; split => //. apply hadd. now right. } - eapply hadd. - destruct (Z.max_spec k' k'') as [[hlt ->]|[hle' ->]] => //. now right. now left. } - destruct nex as [nex ->]. - destruct (eqb_spec l l'). subst. left. exists k'. split => //. apply hadd; now left. - subst k. right. split => //. - intros [k'' hin']. apply hadd in hin' as []. noconf H0. congruence. - apply nex. now exists k''. -Qed. - -Lemma max_premise_of_prems_max {l prems k} : - max_premise_of l prems = Some k -> LevelExprSet.In (l, k) prems. -Proof. - destruct max_premise_of eqn:maxp => //. intros [= ->]. - apply max_premise_of_spec_aux in maxp as [hle hex]. - destruct hex as [[k' [hin [= ->]]]|hne] => //. - destruct hne; congruence. -Qed. - -Lemma max_premise_of_singleton l k : max_premise_of l (singleton (l, k)) = Some k. -Proof. - remember (max_premise_of l (singleton (l, k))) as mp. symmetry in Heqmp. - apply max_premise_of_spec_aux in Heqmp as [hle hex]. - destruct hex as [[k' [hin heq]]|hne] => //. - eapply LevelExprSet.singleton_spec in hin. now noconf hin. - destruct hne as [nein ->]. elim nein. - exists k. now eapply LevelExprSet.singleton_spec. -Qed. - -Lemma max_premise_of_spec2 l k (u : premises) : LevelExprSet.In (l, k) u -> - exists k', LevelExprSet.In (l, k') u /\ max_premise_of l u = Some k'. -Proof. - remember (max_premise_of l u) as mp. symmetry in Heqmp. - apply max_premise_of_spec_aux in Heqmp as [hle hex]. - intros hin. destruct hex. firstorder. - destruct H as [nein ->]. elim nein. now exists k. -Qed. - -Lemma max_premise_of_spec_in l (u : premises) : LevelSet.In l (levels u) -> - exists k, max_premise_of l u = Some k /\ LevelExprSet.In (l, k) u. -Proof. - intros hexi. - remember (max_premise_of l u) as mp. symmetry in Heqmp. - apply max_premise_of_spec_aux in Heqmp as [hle hex]. - destruct hex. destruct H as [l' [hin heq]]. subst mp. - - eexists; split => //. - - destruct H as [nein ->]. elim nein. - now eapply levelexprset_levels_spec in hexi. -Qed. - -Lemma max_opt_of_l {A} {f : A -> A -> A} l : max_opt_of f l None = l. -Proof. - destruct l => //. -Qed. - -Lemma max_opt_of_r {A} {f : A -> A -> A} l : max_opt_of f None l = l. -Proof. - destruct l => //. -Qed. - -(* Lemma of_level_map_premises_model_map cls cl V ne : - (forall l, LevelSet.In l (clause_levels cl) -> LevelSet.In l V) -> - cls ⊢a add_list (premises_of_level_set V) (premise cl) → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. -Proof. - intros hin [l k]. - rewrite of_level_map_spec. move/premises_model_map_spec; cbn. - rewrite max_opt_of_l. - cbn; rewrite LevelSet.union_spec. firstorder try lsets. - cbn in H1. - - rewrite Z.max_comm. - destruct (Z.max_spec 0 (max_premise_of l (premise cl))) as [[hle ->]|[hge ->]]. - * constructor. rewrite add_list_spec; right. - now eapply max_premise_of_spec_in. - * constructor. rewrite add_list_spec. left. - apply premises_of_level_set_spec. split => //. - apply hin. apply clause_levels_spec. now left. - - eapply zero_model_spec in H1 as [hin' [= ->]]. -Qed. *) - -(* Lemma max_premise_of_pos l prems : max_premise_of l prems >= 0. -Proof. - have hs := max_premise_of_spec_aux prems l. - destruct max_premise_of. lia. lia. - specialize (hs _ eq_refl) as [_ [[k' []]|[_ hne]]]; lia. -Qed. - *) - -Lemma of_level_map_premises_model_map cls cl V ne : - cls ⊢a premise cl → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. -Proof. - intros [l k]. - rewrite of_level_map_spec. move/premises_model_map_spec; cbn. - intros [[hin' [[= heq] _]]|[hnin hm]]. - 2:{ now apply zero_model_spec in hm as []. } - move: hin'; cbn; rewrite LevelSet.union_spec. intros []; [|lsets]. - eapply max_premise_of_spec_in in H as [maxp' [eq hin']]. - rewrite eq in heq; noconf heq. - now constructor. -Qed. - -Lemma entails_all_satisfies {cls prems m hne l k} : - cls ⊢a prems → of_level_map m hne -> - infers_atom m l k -> - cls ⊢ prems → (l, k). -Proof. - intros hl hi. - eapply entails_all_one; tea. now apply infers_atom_of_level_map. -Qed. - -Lemma premises_model_map_ne V cls : - ~ LevelMap.Empty V -> - ~ LevelMap.Empty (premises_model_map V cls). -Proof. - intros ne he. apply ne. - have ne' := premises_model_map_in V cls. - intros l k hin. - specialize (ne' l). destruct ne'. forward H0. right. now exists k. - destruct H0 as [k' hin']. - now move/he: hin'. -Qed. - -Lemma clauses_ne_exist cls : ~ Clauses.Empty cls -> exists cl, Clauses.In cl cls. -Proof. - intros ne. - destruct (Clauses.choose cls) eqn:hc. - - exists e. now apply Clauses.choose_spec1 in hc. - - now apply Clauses.choose_spec2 in hc. -Qed. - -Lemma premises_model_map_defined V cls : - ~ Clauses.Empty cls -> - defined_map (premises_model_map V cls). -Proof. - move/clauses_ne_exist => [cl hin]. - destruct cl as [prems concl]. - pose proof (to_nonempty_list_spec' prems). - set (l := (to_nonempty_list prems).1) in *. - have hs := max_clause_premise_of_spec l l.2 cls (prems, concl) hin. - forward hs. cbn. eapply LevelExprSet.elements_spec1; rewrite -H. - constructor. destruct l; reflexivity. depelim hs. - exists l, y. apply premises_model_map_spec. left. - split => //. - eapply clauses_premises_levels_spec. eexists; split; tea => //. - rewrite //= levelexprset_levels_spec. exists l.2. - setoid_rewrite <- LevelExprSet.elements_spec1. rewrite -H //=. - constructor. destruct l; reflexivity. -Qed. - -Variant check_result {cls} := - | IsLooping (v : premises) (islooping : loop_on_univ cls v) - | Invalid - | Valid. -Arguments check_result : clear implicits. - -Equations check_atom_value (z : option Z) (l : option Z) : bool := - | Some _, None => false - | Some z, Some v => z <=? v - | None, _ => true. - -Lemma check_atom_value_spec z l : reflectProp (z ≤ l) (check_atom_value z l). -Proof. - funelim (check_atom_value z l). - - destruct (Z.leb_spec z v); constructor. - * now constructor. - * intros h; depelim h. lia. - - constructor. intros h; depelim h. - - constructor. constructor. -Qed. - -Lemma valid_model_find {V W cl cls} : - forall v : valid_model (clause_levels cl ∪ V) W (premises_model_map (zero_model (clause_levels cl ∪ V)) (Clauses.singleton cl)) cls, - ~ LevelMap.find (concl cl).1 (model_model v) = None. -Proof. - intros v hfind. - destruct cl as [prems [concl k]]; cbn in *. - have vmupd := model_of_V v. - set (pm := premises_model_map _ _) in *. - move/LevelMapFact.F.not_find_in_iff: hfind; apply. - apply vmupd. rewrite LevelSet.union_spec; left. - rewrite clause_levels_spec. now right. -Qed. - -Equations check (cls : clauses) (cl : clause) : check_result cls := - check cls cl with loop_check cls cl := - | Loop v isl => IsLooping v isl - | Model W v _ with inspect (LevelMap.find (concl cl).1 v.(model_model)) := { - | exist (Some val) he with check_atom_value (Some (concl cl).2) val := - { | true => Valid - | false => Invalid } - | exist None he with valid_model_find v he := {} - }. - -Definition check_clauses (cls : clauses) (cls' : clauses) : bool := - let check_one cl := - match check cls cl with - | IsLooping v isl => false - | Valid => true - | Invalid => false - end - in - Clauses.for_all check_one cls'. - -(* If a clause checks, then it should be valid in any extension of the model *) -Lemma check_entails {cls cl} : - check cls cl = Valid -> valid_entailment cls cl. -Proof. - destruct cl as [prems [concl k]]. - funelim (check cls _) => // _. - set (V := clause_levels _ ∪ clauses_levels cls) in *. - clear Heqcall H. cbn [concl fst snd] in *. clear Heq0. - unfold valid_entailment, valid_clause, level_value_above. - move/check_atom_value_spec: Heq; intros h; depelim h. rename H into hgt. - intros valuation ext. - have vmupd := model_updates v. - have vmok := model_ok v. - set (pm := premises_model_map _ _) in *. - have nepm : defined_map pm. - { apply premises_model_map_defined. - set (cl := (prems, _)) in *. - move/(_ cl). rewrite Clauses.singleton_spec. congruence. } - have nev : defined_map (model_model v). - by apply (is_update_of_defined_map nepm vmupd). - move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. - set (cl := (prems, (concl0, k))) in V. - have of_lset := of_level_map_premises_model_map cls cl V nepm. - have tr := entails_all_trans of_lset ent. - eapply (entails_all_satisfies (l := concl0) (k := k)) in tr. - 2:{ red. rewrite /level_value he. now constructor. } - eapply clauses_sem_entails in tr ; tea. -Qed. - -Definition invalid_entailment cls cl := - forall V, clauses_sem V cls -> clause_sem V cl -> False. - -Definition infers_univ (m : model) (u : premises) := - exists z, min_premise m u = Some z /\ (0 <= z)%Z. - -Definition infers_expr (m : model) (le : LevelExpr.t) := - let '(l, k) := le in infers_atom m l k. - -Lemma valid_clause_elim {m prems concl k} : valid_clause m (prems, (concl, k)) -> - forall z, min_premise m prems = Some z -> - Some (z + k) ≤ level_value m concl. -Proof. - rewrite /valid_clause => hcl z eqmin. - rewrite eqmin in hcl. cbn in *. - move: hcl. rewrite /level_value_above. destruct level_value eqn:hl => //. - move/Z.leb_le. constructor. lia. -Qed. - -Lemma valid_clause_intro {m prems concl k} : - (forall z, - min_premise m prems = Some z -> - Some (z + k) ≤ level_value m concl) -> - valid_clause m (prems, (concl, k)). -Proof. - rewrite /valid_clause //=. - destruct min_premise => //. - intros hz. - specialize (hz _ eq_refl). depelim hz. - rewrite /level_value_above H0. - apply Z.leb_le. lia. -Qed. - -Lemma infers_expr_min_atom_value m le : infers_expr m le -> exists k, min_atom_value m le = Some k /\ (0 <= k)%Z. -Proof. - destruct le as [l k]; rewrite /infers_expr //=. - rewrite /infers_atom. destruct level_value => // hle; depelim hle. - eexists; split; trea. lia. -Qed. - -Lemma min_premise_add_infers m prems le lev : - level_value m le.1 = Some lev -> - forall z, min_premise m prems = Some z -> - exists z', min_premise m (add le prems) = Some z' /\ - ((z' = lev - le.2 /\ z' <= z) \/ z' = z). -Proof. - intros hlev z hmin. - have [hle [min' [hin hm]]] := min_premise_spec m (add le prems). - have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. - move/LevelExprSet.add_spec: hin => [heq|hin]. - - noconf heq. destruct le as [le k]. - rewrite /min_atom_value hlev in hm. - eexists; split => //; trea. left. - specialize (hle min''). forward hle. - { rewrite LevelExprSet.add_spec. now right. } - rewrite hm -hm' hmin in hle. now depelim hle. - - exists z. split => //. 2:right; reflexivity. rewrite hm -hmin hm'. - move: (hle' _ hin). rewrite hmin. intros h; depelim h. - rewrite H0 in hm. - specialize (hle min''). forward hle. eapply LevelExprSet.add_spec. now right. - rewrite hm in hle. rewrite -hm' hmin in hle. depelim hle. - rewrite H0 -hm' hmin. f_equal. lia. -Qed. - -Lemma fold_left_map {A B C} (f : B -> A -> A) (g : C -> B) l acc : - fold_left (fun acc l => f (g l) acc) l acc = - fold_left (fun acc l => f l acc) (map g l) acc. -Proof. - induction l in acc |- *; cbn; auto. -Qed. - -Lemma fold_left_max_acc {n l} : (forall x, In x l -> x = n) -> n = fold_left (option_map2 Z.min) l n. -Proof. - induction l in n |- *. - - now cbn. - - cbn. intros he. transitivity (option_map2 Z.min n a). 2:apply IHl. - specialize (he a). forward he. now left. subst. destruct n => //= //. lia_f_equal. - intros. have h := (he x). forward h by now right. - have h' := (he a). forward h' by now left. subst. - destruct n => //=; lia_f_equal. -Qed. - -Lemma option_map2_comm x y : option_map2 Z.min x y = option_map2 Z.min y x. -Proof. - destruct x, y; cbn; lia_f_equal. -Qed. - -Lemma option_map2_assoc x y z : - option_map2 Z.min x (option_map2 Z.min y z) = - option_map2 Z.min (option_map2 Z.min x y) z. -Proof. - destruct x, y, z; cbn; lia_f_equal. -Qed. - -Local Notation fn := (fold_left (option_map2 Z.min)). - -Lemma fold_left_impl n l : - (forall x, In x (n :: l) -> fn l n ≤ x) /\ - (exists x, In x (n :: l) /\ fn l n = x). -Proof. - induction l in n |- *. - - cbn. split; intros. - destruct H => //. subst. reflexivity. - exists n. split => //. now left. - - cbn. split; intros. - { destruct (IHl n) as [hle [min [hin heq]]]. - rewrite fold_left_comm. - { now intros; rewrite -option_map2_assoc (option_map2_comm x0 y) option_map2_assoc. } - repeat destruct H; subst. - * specialize (hle n). forward hle. now left. - transitivity (fn l n); auto. eapply Zmin_opt_left. - * eapply Zmin_opt_right. - * transitivity (fn l n); auto. apply Zmin_opt_left. - apply hle. now right. } - * specialize (IHl (option_map2 Z.min n a)). - destruct IHl as [hle [min [hin heq]]]. subst min. eexists. split; trea. - destruct hin. - rewrite -H. - destruct n, a; cbn; firstorder. - destruct (Z.min_spec z z0) as [[? heq]|[? heq]]. - rewrite -{1}heq. now left. right; left. f_equal. lia. - now right. -Qed. - -Lemma fold_left_impl_eq n n' l l' : - (forall x, In x (n :: l) <-> In x (n' :: l' )) -> - fn l n = fn l' n'. -Proof. - intros heq. - destruct (fold_left_impl n l) as [hle [minl [hin heq']]]. - destruct (fold_left_impl n' l') as [hle' [minl' [hin' heq'']]]. - rewrite heq' heq''. - specialize (hle minl'). forward hle. now apply heq. - specialize (hle' minl). forward hle'. now apply heq. - rewrite heq'' in hle'. rewrite heq' in hle. depelim hle'. depelim hle. f_equal; lia. - now depelim hle. -Qed. - -Lemma fold_left_comm_f {A} (f : A -> A -> A) n l : - (forall x y, f x y = f y x) -> - fold_left f l n = fold_left (flip f) l n. -Proof. - induction l in n |- *; cbn; auto. - intros hf. rewrite IHl //. - unfold flip. now rewrite hf. -Qed. - -Lemma min_premise_add {m le prems} : min_premise m (add le prems) = - option_map2 Z.min (min_atom_value m le) (min_premise m prems). -Proof. - rewrite {1}/min_premise. - have hs' := to_nonempty_list_spec (add le prems). - destruct to_nonempty_list. - have eqf : (fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (min_atom_value m p)) = - (option_map2 Z.min (min_atom_value m le) (min_premise m prems)). - 2:{ now rewrite eqf. } - rewrite -(to_nonempty_list_spec' (add le prems)) in hs'. noconf hs'. - rewrite fold_left_map. rewrite fold_left_comm_f. intros [] []; cbn; auto. lia_f_equal. unfold flip. - have l := fold_left_impl_eq (min_atom_value m (to_nonempty_list (add le prems)).1) (min_atom_value m le) - (map (min_atom_value m) (to_nonempty_list (add le prems)).2) (map (min_atom_value m) (LevelExprSet.elements prems)). - rewrite l. - intros x. - { rewrite -!map_cons to_nonempty_list_spec' !in_map_iff. - split. - - move=> [] lk [] <-. - rewrite -InA_In_eq. - move/LevelExprSet.elements_spec1. - rewrite LevelExprSet.add_spec. - intros [->|inp]. - * exists le. split => //. now left. - * exists lk. split => //. right. now apply InA_In_eq, LevelExprSet.elements_spec1. - - intros [x' [<- hin]]. - exists x'. split => //. rewrite -InA_In_eq. - eapply LevelExprSet.elements_spec1. rewrite LevelExprSet.add_spec. - apply InA_In_eq in hin. depelim hin. now left. - eapply LevelExprSet.elements_spec1 in hin. now right. } - rewrite option_map2_comm. - rewrite /min_premise. - destruct (to_nonempty_list prems) eqn:he. - rewrite fold_left_map. - rewrite (fold_left_comm_f _ _ (map _ l0)). intros. apply option_map2_comm. - rewrite -(fold_left_comm (option_map2 Z.min)). - { intros. now rewrite -option_map2_assoc (option_map2_comm x y) option_map2_assoc. } - rewrite -(to_nonempty_list_spec' prems) he; cbn. - now rewrite option_map2_comm. -Qed. - -Lemma min_premise_elim m (P : premises -> option Z -> Prop): - (forall le, P (singleton le) (min_atom_value m le)) -> - (forall prems acc le, P prems acc -> ~ LevelExprSet.In le prems -> P (add le prems) (option_map2 Z.min (min_atom_value m le) acc)) -> - forall prems, P prems (min_premise m prems). -Proof. - intros hs hadd. - eapply premises_elim. - - intros le. rewrite /min_premise. - rewrite singleton_to_nonempty_list. cbn. apply hs. - - intros le prems hp. now rewrite min_premise_add. -Qed. - -Lemma min_premise_add_down {m} {prems : premises} {l k} : - LevelExprSet.In (l, k + 1) prems -> - forall z, min_premise m prems = Some z -> - min_premise m (add (l, k) prems) = Some z. -Proof. - intros ine z hmin. - have [hle [min' [hin hm]]] := min_premise_spec m (add (l, k) prems). - have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. - move/LevelExprSet.add_spec: hin => [heq|hin]. - - noconf heq. - specialize (hle (l, k + 1)). - forward hle. eapply LevelExprSet.add_spec. now right. - rewrite hm in hle. - depelim hle. destruct level_value eqn:hl. noconf H0; noconf H1. lia. congruence. - destruct level_value eqn:hl' => //. - specialize (hle' _ ine). rewrite hmin in hle'; depelim hle'. - now rewrite hl' in H1. - - rewrite hm. specialize (hle' min' hin). rewrite hmin in hle'. - depelim hle'. rewrite H0. f_equal. rewrite H0 in hm. - specialize (hle min''). forward hle. eapply LevelExprSet.add_spec. now right. - rewrite hm in hle. rewrite -hm' hmin in hle. depelim hle. lia. -Qed. - - -Lemma min_premise_singleton m u : min_premise m (singleton u) = min_atom_value m u. -Proof. - now rewrite /min_premise singleton_to_nonempty_list; cbn. -Qed. - -Lemma min_atom_value_add m e x n : - min_atom_value m e = Some x -> - min_atom_value m (add_expr n e) = Some (x - n)%Z. -Proof. - rewrite /min_atom_value. destruct e. cbn. - destruct level_value => //. intros [= <-]. - f_equal. lia. -Qed. - - -Lemma min_atom_value_add_inv m e x n : - min_atom_value m (add_expr n e) = Some x -> - min_atom_value m e = Some (x + n)%Z. -Proof. - rewrite /min_atom_value. destruct e. cbn. - destruct level_value => //. intros [= <-]. - f_equal. lia. -Qed. - -Lemma min_premise_add_prems {m n prems z} : min_premise m prems = Some z -> min_premise m (add_prems n prems) = Some (z - n)%Z. -Proof. - revert z. - eapply min_premise_elim. - - intros le hm. - destruct le as [concl k]. - rewrite add_prems_singleton min_premise_singleton. - apply min_atom_value_add. - - intros prems' acc le ih nle z hm. - destruct acc; cbn in hm. 2:{ destruct (min_atom_value m le); cbn in hm; congruence. } - specialize (ih _ eq_refl). - rewrite add_prems_add min_premise_add. - destruct (min_atom_value m le) eqn:hm'; cbn in hm => //. noconf hm. - apply (min_atom_value_add _ _ _ n) in hm'. - rewrite ih hm'. cbn. f_equal. lia. -Qed. - -Lemma min_premise_add_prems_inv {m n prems z} : min_premise m (add_prems n prems) = Some z -> - min_premise m prems = Some (z + n)%Z. -Proof. - revert z. - pattern prems. - set (P := (fun n0 hm => - forall z : Z, - min_premise m (add_prems n n0) = Some z -> hm = Some (z + n)%Z)). - apply (@min_premise_elim _ P); subst P; cbn. - - intros le z hm. - destruct le as [concl k]. - rewrite add_prems_singleton min_premise_singleton in hm. - now apply min_atom_value_add_inv. - - intros prems' acc le ih nle z. - rewrite add_prems_add min_premise_add. - destruct (min_premise m (add_prems n prems')) eqn:he => //=. - * destruct (min_atom_value m (add_expr n le)) eqn:ha => //=. - intros [= <-]. - eapply min_atom_value_add_inv in ha. rewrite ha. - specialize (ih _ eq_refl). subst acc. cbn. lia_f_equal. - * destruct (min_atom_value m (add_expr n le)) eqn:ha => //=. -Qed. - -Lemma level_value_above_leq {m l k} : - Some k ≤ level_value m l -> - level_value_above m l k. -Proof. - intros h; rewrite /level_value_above. - depelim h. rewrite H0. apply Z.leb_le. lia. -Qed. - -Lemma valid_clause_shift m n cl : - valid_clause m cl -> valid_clause m (add_clause n cl). -Proof. - destruct cl as [prems [concl k]]. - move/valid_clause_elim => hv. - apply valid_clause_intro => z eqmin. - eapply min_premise_add_prems_inv in eqmin. - specialize (hv _ eqmin). - etransitivity; tea. constructor; lia. -Qed. - -Lemma entails_model_valid cls cl : entails cls cl -> - forall m, is_model cls m -> valid_clause m cl. -Proof. - induction 1. - - intros m ism. - destruct concl0 as [concl k]. - apply valid_clause_intro => z hmin. - eapply min_premise_spec_aux in hmin as [hle [x [hin heq]]]. - specialize (hle _ H). depelim hle. - destruct level_value eqn:hl => //. noconf H1. - constructor. lia. - - intros. - specialize (IHentails m H2). - depelim H. - * destruct cl as [premsc conclc]. - noconf H0. - eapply Clauses.for_all_spec in H3. - eapply H3 in H. 2:tc. - destruct concl0 as [concl k]. - eapply valid_clause_intro => z eqmin. - have mins := min_premise_subset m (add_prems n premsc) prems H2. - rewrite eqmin in mins; depelim mins. - destruct conclc as [conclc k']. - have vshift : valid_clause m (add_prems n premsc, add_expr n (conclc, k')). - { now eapply (valid_clause_shift _ n) in H. } - have hv := valid_clause_elim vshift _ H4. - depelim hv. rename y0 into vmconclc. - eapply (min_premise_add_infers _ _ (add_expr n (conclc, k'))) in eqmin as [minadd [eqminadd disj]]; tea. - move/valid_clause_elim: IHentails => //=. - move/(_ _ eqminadd). - destruct disj as [[eq le']| ->]. - + move=> h. cbn in le'. cbn in eq. subst minadd. - depelim h. rewrite H8. constructor. lia. - + intros h; depelim h. rewrite H8; constructor; lia. - * destruct concl0 as [concl0 k']. - apply valid_clause_intro => z hmin. - have mins := min_premise_subset m _ _ H1. - rewrite min_premise_singleton in mins. - specialize (H1 (x, k+1)); forward H1 by now apply LevelExprSet.singleton_spec. - have hadd := min_premise_add_down H1 _ hmin. - exact: valid_clause_elim IHentails _ hadd. -Qed. - -Lemma check_entails_looping {cls cl v isl} : - check cls cl = IsLooping v isl -> cls ⊢a v → succ_prems v. -Proof. - funelim (check cls cl) => //. -Qed. - -Lemma enabled_clause_ext {m m' cl} : - m ⩽ m' -> enabled_clause m cl -> enabled_clause m' cl. -Proof. - intros hext; rewrite /enabled_clause. - destruct cl as [prems [concl k]]; cbn; move=> [z hm]. - have pr := min_premise_pres prems hext. - rewrite hm in pr. depelim pr. now exists y. -Qed. - -Lemma check_entails_false {cls cl} : - check cls cl = Invalid -> ~ entails cls cl. -Proof. - funelim (check cls cl) => //. - set (V := clause_levels cl ∪ clauses_levels cls) in *. - destruct cl as [prems [concl k]]. - rename val into conclval_v => _. clear H Heq0 Heqcall prf. cbn in he. - move: (check_atom_value_spec (Some k) conclval_v). rewrite Heq. - intros r; depelim r. rename H into nent. intros H. - have vmupd := model_updates v. - have vmok := model_ok v. - set (pm := premises_model_map _ _) in *. - set (cl := (prems, _)) in V. - have nepm : defined_map pm. - { apply premises_model_map_defined. - move/(_ cl). rewrite Clauses.singleton_spec /cl. congruence. } - have nev : defined_map (model_model v). - by apply (is_update_of_defined_map nepm vmupd). - move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. - move/entails_model_valid/(_ _ vmok): H. - have [z minp] : enabled_clause (model_model v) cl. - { apply (@enabled_clause_ext pm). - exact: is_update_of_ext (model_updates v). - red; cbn. - have hcl : Clauses.In cl (Clauses.singleton cl). - { now eapply Clauses.singleton_spec. } - have hs:= @premises_model_map_min_premise_inv V _ _ hcl. firstorder. } - move/valid_clause_elim/(_ z minp). - cbn in minp. - rewrite /level_value he => h; depelim h. apply nent. - constructor. - have posz : 0 <= z. - { have hsu := model_updates v. - eapply is_update_of_ext in hsu. - have hs := min_premise_pres prems hsu. - rewrite minp in hs. - have hmin := @premises_model_map_min_premise_inv V (Clauses.singleton cl) cl. - forward hmin. now apply Clauses.singleton_spec. - destruct hmin as [minp' [hmineq hpos]]. - rewrite hmineq in hs. depelim hs. lia. } - lia. -Qed. - -Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) - (prf : clauses_levels cls ⊂_lset V /\ clauses_levels cls' ⊂_lset V /\ only_model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := - | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m m _. -Proof. - split. - - intros x. rewrite clauses_levels_spec. - move=> [] cl. rewrite Clauses.union_spec. - intros [[] incls]. apply H. apply clauses_levels_spec. exists cl. split => //. - apply H0. apply clauses_levels_spec. exists cl; split => //. - - exact H1. - - eapply is_update_of_empty. -Qed. - - -(* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by - setting a minimal value for the new atoms in [clauses_levels cls \ V] - such that the new clauses [cls] do not hold vacuously. -*) - -Variant level_value_spec (m : model) (l : Level.t) : option Z -> Prop := -| level_value_in k : LevelMap.MapsTo l k m -> level_value_spec m l k -| level_value_nin : ~ LevelMap.In l m -> level_value_spec m l None. - -Lemma level_valueP {m l} : level_value_spec m l (level_value m l). -Proof. - rewrite /level_value. - case: find_spec. - - now move=> k0 hm; apply level_value_in. - - now move=> hnin; apply level_value_nin. -Qed. - -Lemma maps_to_update {l k} {m : model} {k'} : LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m <-> k = k'. -Proof. - firstorder. now eapply LevelMapFact.F.MapsTo_fun in H; tea. now subst. -Qed. - -Equations add_max (l : Level.t) (k : option Z) (m : model) : model := -add_max l k m with level_value m l := - { | Some k' with check_atom_value k (Some k') := - { | true => m - | false => LevelMap.add l k m } - | None => LevelMap.add l k m }. - -Lemma nleq k k' : ~ k ≤ Some k' -> exists z, k = Some z /\ k' < z. -Proof. - destruct k. - - exists z. split => //. eapply Znot_ge_lt => hl; apply H. constructor. lia. - - elim. constructor. -Qed. - -Lemma add_max_spec l l' k k' (m : model) : - LevelMap.MapsTo l k (add_max l' k' m) <-> - (l = l' /\ k = max_opt_of Z.max k' (level_value m l)) \/ - (l <> l' /\ LevelMap.MapsTo l k m). -Proof. - funelim (add_max l' k' m). - - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. firstorder; subst. - left. split => //. rewrite Heq. now rewrite max_opt_of_l. - left. firstorder. now rewrite Heq max_opt_of_l. - - clear Heqcall. - destruct (eq_dec l0 l). - * subst l0. rewrite Heq0. - move/check_atom_value_spec: Heq. - rewrite (maps_to_update (level_value_MapsTo' Heq0)). - firstorder; subst; try left; try split; auto; depelim Heq; cbn; lia_f_equal. - * firstorder. - - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. - have := check_atom_value_spec k (Some k'). rewrite {}Heq. - intros h; depelim h. apply nleq in H as [z [-> hlt]]. - firstorder; subst. - * left; split => //. rewrite Heq0 //=. lia_f_equal. - * left; split => //. rewrite Heq0 //=. lia_f_equal. -Qed. - -Definition min_model_clause cl m := - LevelExprSet.fold (fun '(l, k) acc => add_max l (Some k) acc) (premise cl) - (add_max (concl cl) None m). - -Definition min_model_map (m : model) cls : model := - Clauses.fold min_model_clause cls m. - -Lemma In_add_max l l' k acc : - LevelMap.In l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). -Proof. - rewrite /LevelMap.In. - rw add_max_spec. firstorder subst. - eexists; left; eauto. - destruct (eq_dec l l'); subst; eexists; eauto. -Qed. - -Definition is_max k' k l acc := - match LevelMap.find l acc with - | Some k'' => k' = Nat.max k k'' - | _ => k' = k - end. - -Lemma max_opt_of_spec {x y k'} : max_opt_of Z.max x y = k' -> - (x ≤ y /\ k' = y) \/ (y ≤ x /\ k' = x). -Proof. - destruct x, y; cbn; firstorder subst. - - destruct (Z.max_spec z z0) as [[]|[]]; - [left|right]; split; try constructor; lia_f_equal. - - right. split; constructor. - - left. split; constructor. - - left; split; constructor. -Qed. - -(*Lemma In_fold_aadd_dd_max k n a : - LevelMap.In (elt:=nat) k - (LevelExprSet.fold - (fun '(l, k0) acc => add_max l k0 acc) n a) <-> - (LevelSet.In k (levels n)) \/ LevelMap.In k a. -Proof. - eapply LevelExprSetProp.fold_rec. - - intros s' he. - rewrite (LevelExprSetProp.empty_is_empty_1 he). - cbn. unfold levels. rewrite LevelExprSetProp.fold_empty. rewrite LevelSetFact.empty_iff. intuition auto. - - intros. - destruct x as [l k']. - rewrite In_add_max. - rewrite H2 !levelexprset_levels_spec. - split. - * intros []; subst. - left. exists k'. apply H1. now left. - destruct H3 as [[k'' ?]|?]. left; exists k''. apply H1. now right. - now right. - * red in H1. setoid_rewrite H1. - intros [[k'' []]|]. noconf H3. now left. - right. now left; exists k''. right; right. apply H3. -Qed.*) - - -Definition max_of_premises l kl n := - (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ kl). - -Definition is_expr l (e : LevelExpr.t) := - let '(concl, k) := e in concl = l. - -Definition max_of_clause l kl cl := - max_of_premises l kl (premise cl). - -Definition max_of_map l kl m := - (forall kl', LevelMap.MapsTo l kl' m -> kl' ≤ kl). - -Definition is_max_of_clause_and_map l cl m k := - max_of_premises l k (premise cl) /\ max_of_map l k m. - -Definition is_in_premise l k (u : LevelExprSet.t) := - (exists kl, LevelExprSet.In (l, kl) u /\ k = Some kl). - -Definition is_in_clause l k (cl : clause) := - is_in_premise l k (premise cl) \/ (l = (clause_conclusion cl) /\ k = None). - -Definition is_max_of_clause_model l cl m k := - is_max_of_clause_and_map l cl m k /\ - (is_in_clause l k cl \/ LevelMap.MapsTo l k m). - -Definition is_higher l k m := exists k', LevelMap.MapsTo l k' m /\ k ≤ k'. - -Definition is_max_of_clause_map (map : model) l cl (m : model) : Prop := - (forall k, LevelMap.MapsTo l k map -> is_max_of_clause_model l cl m k) - /\ (forall l k, LevelMap.MapsTo l k m \/ is_in_clause l k cl -> is_higher l k map). - - -Lemma max_opt_of_le_l z z' : z ≤ max_opt_of Z.max z z'. -Proof. - destruct z, z'; cbn; constructor; lia. -Qed. - -Lemma max_opt_of_le_r z z' : z' ≤ max_opt_of Z.max z z'. -Proof. - destruct z, z'; cbn; constructor; lia. -Qed. - -Lemma is_higher_le l k l' k' m : is_higher l k m -> is_higher l k (add_max l' k' m). -Proof. - rewrite /is_higher. - rw add_max_spec. - intros [k'0 [hm hle]]. - destruct (eq_dec l l'). - - subst. eexists. split; eauto. rewrite (level_value_MapsTo hm). - transitivity k'0 => //. apply max_opt_of_le_r. - - exists k'0. split; eauto. -Qed. - -Lemma is_higher_add l k m : is_higher l k (add_max l k m). -Proof. - rewrite /is_higher. - rw add_max_spec. eexists. split; eauto. - apply max_opt_of_le_l. -Qed. - -Lemma is_higher_mon l k k' m : is_higher l k' m -> k ≤ k' -> is_higher l k m. -Proof. - intros [? []] le. exists x. split => //. now transitivity k'. -Qed. - -Lemma MapsTo_fold_add_max l n a : - let map := LevelExprSet.fold (fun '(l, k0) acc => add_max l (Some k0) acc) n a in - (forall k, LevelMap.MapsTo l k map -> - ((exists kl, - [/\ LevelExprSet.In (l, kl) n, k = Some kl, - (forall kl', LevelExprSet.In (l, kl') n -> kl' <= kl) & - (forall kl', LevelMap.MapsTo l kl' a -> kl' ≤ Some kl)]) \/ - (LevelMap.MapsTo l k a /\ (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ k)))) - /\ (forall l k, LevelMap.MapsTo l k a \/ is_in_premise l k n -> is_higher l k map) /\ - a ⩽ map. - (* ~ LevelMap.In l map -> ~ (exists k, LevelExprSet.In (l, k) n) /\ ~ (LevelMap.In l a)). *) -Proof. - eapply LevelExprSetProp.fold_rec. - - intros s' he. cbn. - rewrite /is_in_premise /is_higher. - setoid_rewrite (LevelExprSetProp.empty_is_empty_1 he). - intuition auto. right. split; eauto. - intros kl. now move/LevelExprSet.empty_spec. - exists k; split => //. reflexivity. - destruct H0 as [x [hin ->]]. now apply LevelExprSet.empty_spec in hin. - reflexivity. - - cbn; intros. - destruct x as [xl k']. split. - 2:{ split. - { intros l0 hnin. destruct H2 as [hm [H2 _]]. specialize (H2 l0). - intros [ina|ins'']. - { specialize (H2 hnin (or_introl ina)). eapply is_higher_le; tea. } - { destruct ins'' as [x [ins'' ->]]. - apply H1 in ins'' as [[=]|ins']. - * subst. apply is_higher_add. - * apply is_higher_le, H2. right. eexists; eauto. } } - { destruct H2 as [_ [_ H2]]. - intros l' hin. move/H2 => [k'0 [hm hle]]. - rw add_max_spec. destruct (eq_dec l' xl). - - eexists; split. left; eauto. subst l'. - rewrite (level_value_MapsTo hm). transitivity (k'0) => //. - apply max_opt_of_le_r. - - eexists; split; eauto. } } - intros. - rewrite add_max_spec in H3; destruct H3 as [[<- hk]|[hdiff hm]]. - * destruct H2 as [hin hnin]. symmetry in hk. - have [[leacc eqms]|[len eqms]] := max_opt_of_spec hk. - { depelim leacc. specialize (hin _ (level_value_MapsTo' H3)) as [[kl [inkl [= <-] les' lea]]|]. - { left. exists y. split => //. apply H1; now right. congruence. intros. - apply H1 in H4 as [[=]|ins']. 2:now apply les'. subst kl'. lia. } - { destruct H4. right. split. now rewrite -H3 -eqms in H4. intros. - apply H1 in H6 as [[=]|ins']; subst; trea. rewrite H3; cbn; constructor; lia_f_equal. - rewrite H3; cbn; constructor. apply H5 in ins'. depelim ins'. lia. } } - { left. exists k'. split => //. - * apply H1. now left. - * move=> kl' /H1 [[=]|ins']. lia. depelim len. transitivity x; tea. specialize (hin _ (level_value_MapsTo' H3)) as - [[kl [inkl [= <-] les' lea]]|[]]. - { now eapply les'. } - { specialize (H5 _ ins'). depelim H5. lia. } - { move: H2 hk. rewrite /level_value. destruct (find_spec l a0). - * intros ->. apply hin in H2 as [[kl []]|[hm hkl']] => //. apply hkl' in ins'. depelim ins'. - * intros _; cbn; intros <-. - destruct hnin as [hnin _]. - specialize (hnin l (Some kl')); forward hnin. right. - red. exists kl'. split => //. - destruct hnin as [ka [hma hge]]. elim H2. now exists ka. } - * subst k. intros kl' mt. move: len. case: level_valueP => [k ma0 le|]. - specialize (hin _ ma0) as [[kl []]|[hm hkl']] => //. - + subst k. eapply H5 in mt. now depelim le; depelim mt; constructor; lia. - + transitivity k => //. eapply LevelMapFact.F.MapsTo_fun in mt; tea. subst. reflexivity. - + intros hnin' _. destruct hnin as [hnin _]. specialize (hnin l kl'). - forward hnin. now left. destruct hnin as [? [hm ?]]. elim hnin'. now exists x. } - * destruct H2. eapply H2 in hm as [[kl []]|[hm hkl']] => //. - { left. exists kl. split => //. apply H1. now right. intros kl' h. subst k. - apply H6. apply H1 in h. destruct h as [[=]|?] => //. subst. congruence. } - { right. split => //. intros kl' hin. apply H1 in hin as [[=]|?] => //; subst; try congruence. eauto. } -Qed. - -Lemma min_model_clause_spec l cl a : - let map := min_model_clause cl a in - is_max_of_clause_map map l cl a. -Proof. - intros m. rewrite /is_max_of_clause_map /is_max_of_clause_model. - have h := MapsTo_fold_add_max l (premise cl) (add_max (concl cl) None a). - change (LevelExprSet.fold (fun '(l, k0) (acc : model) => add_max l (Some k0) acc) (premise cl) - (add_max (concl cl) None a)) with (min_model_clause cl a) in h. - cbn in h. destruct h. split. - - intros k hm. specialize (H k hm) as [[kl []]|[hm' hle]]. - * split => //. subst k. red. split. intros kl' hin. constructor. now apply H2. - move=> kl' hm''. specialize (H3 kl'). - rewrite add_max_spec in H3. forward H3. - destruct (eq_dec l (concl cl)). - { subst l. left. split => //. rewrite max_opt_of_r. apply level_value_MapsTo in hm''. now rewrite hm''. } - { right. split => //. } - exact H3. left. - red. left. red. subst k. eauto. - * rewrite add_max_spec in hm'. - rewrite max_opt_of_r in hm'. destruct hm' as [[]|[]]; try subst l. - { repeat split => //. - { intros l hin'. subst k. rewrite (level_value_MapsTo hin'). reflexivity. } - { destruct k. right. symmetry in H1. now apply level_value_MapsTo' in H1. - left. red. right. split => //. } } - { split => //. split => //. - { intros l' hin'. eapply LevelMapFact.F.MapsTo_fun in H1; tea. subst. reflexivity. } - firstorder. } - - intros l' k. destruct H0 as [H0 hext]. specialize (H0 l' k). - intros [hm|hinc]. - { forward H0. left. rewrite add_max_spec. - destruct (eq_dec l' (concl cl)); eauto. - { left. split => //. rewrite max_opt_of_r. - now rewrite (level_value_MapsTo hm). } - destruct H0 as [? [hinm hle]]. - eapply is_higher_mon; tea. exists x. split; eauto. reflexivity. } - { red in hinc. destruct hinc. apply H0. now right. - destruct H1 as [-> ->]. - destruct (eq_dec l (concl cl)). - red. - destruct (LevelMap.find (concl cl) a) eqn:hl. - * apply LevelMap.find_2 in hl. - specialize (hext (concl cl) o). - forward hext. rewrite add_max_spec. left. split => //. - rewrite max_opt_of_r. now rewrite (level_value_MapsTo hl). - destruct hext as [k' []]. exists k'. split => //. constructor. - * specialize (hext (concl cl) None). - forward hext. rewrite add_max_spec. left. split => //. - now rewrite /level_value hl. - destruct cl; unfold clause_conclusion in *. exact hext. - * specialize (hext (concl cl) (level_value a (concl cl))). - forward hext. rewrite add_max_spec. left. split => //. - destruct hext as [l' []]; exists l'; split => //. constructor. } -Qed. - -Lemma min_model_map_acc l cls m : - let map := min_model_map m cls in - (forall k, LevelMap.MapsTo l k map -> max_of_map l k m) /\ - m ⩽ map. -Proof. - cbn. rewrite /min_model_map. - eapply ClausesProp.fold_rec. - 2:{ intros. destruct H2 as [hf hin]. - have [hm hnin] := min_model_clause_spec l x a. - split. - intros k. - move/hm. rewrite /is_max_of_clause_model. intros [[ism' ism] hasm]. - destruct hasm; eauto. intros kl'. move/hin => [k' [hmk' lek']]. - red in ism. specialize (ism _ hmk'). now transitivity k'. - transitivity a => //. - intros l' k ha. specialize (hnin l' k (or_introl ha)). - exact hnin. } - split; [|reflexivity]. - intros k hin k' hin'. - eapply LevelMapFact.F.MapsTo_fun in hin; tea. subst; reflexivity. -Qed. - -Lemma max_of_map_ext l k m m' : m ⩽ m' -> max_of_map l k m' -> max_of_map l k m. -Proof. - intros hext hm l'; move/hext => [k' [hm' le]]. - apply hm in hm'. now transitivity k'. -Qed. - -Lemma mapsto_max_of_map l k m : LevelMap.MapsTo l k m -> max_of_map l k m. -Proof. - intros hm l' k'. eapply LevelMapFact.F.MapsTo_fun in hm; tea. - subst; reflexivity. -Qed. - -Lemma min_model_map_spec l cls m : - let map := min_model_map m cls in - (forall k, LevelMap.MapsTo l k map -> - [/\ (exists cl, Clauses.In cl cls /\ is_in_clause l k cl) \/ LevelMap.MapsTo l k m, - (forall cl, Clauses.In cl cls -> max_of_premises l k (premise cl)) & max_of_map l k m]) /\ - (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l map) /\ - m ⩽ map. -Proof. - cbn. - rewrite /min_model_map. - have hgen : forall cls m, (forall k, LevelMap.MapsTo l k (Clauses.fold min_model_clause cls m) -> - [/\ (exists cl : Clauses.elt, Clauses.In cl cls /\ is_in_clause l k cl) \/ - LevelMap.MapsTo l k m, - forall cl : Clauses.elt, Clauses.In cl cls -> max_of_premises l k (premise cl) - & max_of_map l k (Clauses.fold min_model_clause cls m)]) /\ - (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l (Clauses.fold min_model_clause cls m)) /\ - m ⩽ Clauses.fold min_model_clause cls m. - 2:{ specialize (hgen cls m). destruct hgen as [hgen [hcls H]]; split; eauto. - intros k hm. specialize (hgen k hm) as [] => //. - split => //. eapply max_of_map_ext; tea. } - clear. - intros cls m. - eapply ClausesProp.fold_rec. - - intros s' he. split; [ | split; [|reflexivity]]. - * intros k hin. split => //. now right. - intros cl hin'. clsets. now apply mapsto_max_of_map. - * intros cl ins'; clsets. - - intros x a s' s'' hin hnin hadd [ih [ihcls hext]]. split; [|split]; revgoals. - { transitivity a => //. intros l' hin' hm. - have := min_model_clause_spec l' x a. cbn. - intros [_ hm']. specialize (hm' l' hin'). - now forward hm' by eauto. } - { intros cl ins'' l' inlev. - apply hadd in ins'' as [<-|]. - * have := min_model_clause_spec l' x a. cbn. - intros [_ hm']. eapply clause_levels_spec in inlev as []. - + eapply levelexprset_levels_spec in H as [k' incl]. - specialize (hm' l' (Some k')). forward hm'. right. left. rewrite /is_in_premise. exists k'; eauto. - destruct hm' as [? []]; now eexists. - + subst l'. specialize (hm' (concl x) None). forward hm'. - right. right. split => //. - destruct hm' as [? []]; now eexists. - * specialize (ihcls _ H _ inlev) as [k' ina]. - have := min_model_clause_spec l' x a. cbn. - move=> [] _ /(_ l' k' (or_introl ina)). - clear. firstorder. } - intros k. - have := min_model_clause_spec l x a. cbn. - intros [hm hm'] hmk. destruct (hm _ hmk). - split => //. - { destruct H0; eauto. - { left; exists x. split => //. apply hadd. now left. } - { specialize (ih _ H0) as []. destruct H1; eauto. left. - move: H1 => [] w []; exists w; split; eauto. apply hadd. now right. } } - { move=> cl /hadd => [] [<-|hin']. - { now move: H => []. } - { specialize (hm' l k). forward hm' by (destruct H0; eauto). - intros k' h. - specialize (ihcls _ hin' l). - forward ihcls. - { eapply clause_levels_spec. left. eapply levelexprset_levels_spec. now exists k'. } - destruct ihcls as [ka ihcls]. - specialize (ih _ ihcls) as [ihm ihcls' maxm]. - specialize (ihcls' _ hin' _ h). - transitivity ka => //. - destruct H as [mp mmap]. - now apply mmap. } } - { intros kl inma. eapply LevelMapFact.F.MapsTo_fun in hmk; tea. subst. reflexivity. } -Qed. - -Equations? infer_extension {V W init cls} (m : valid_model V W init cls) - (hincl : only_model_of V init) - (hs : clauses_levels cls ⊂_lset V) - (cls' : clauses) : - result (LevelSet.union (clauses_levels cls') V) LevelSet.empty (Clauses.union cls cls') (min_model_map m.(model_model) cls') := - infer_extension m hincl hs cls' := - infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model_map m.(model_model) cls') cls cls' _. -Proof. - repeat split. - - lsets. - - lsets. - - have ms := min_model_map_spec k cls' (model_model m). - set (map := min_model_map _ _) in *. - destruct ms as [hm [hcls hext]]. - rewrite LevelSet.union_spec => [] []. - * move/clauses_levels_spec. - intros [cl [hin ink]]. - now move: hcls => /(_ _ hin _ ink). - * move/(model_of_V m k). - move=> [] x /hext. firstorder. - - have ms := min_model_map_spec k cls' (model_model m). - set (map := min_model_map _ _) in *. - destruct ms as [hm [hcls hext]]. - rewrite LevelSet.union_spec. - move=> [] v /hm [] [[cl [incl inclv]]|hm'] ihcls mmap. - * left. - red in inclv. eapply clauses_levels_spec. - exists cl. split => //. eapply clause_levels_spec. - destruct inclv as [[? []]|]. - + left. eapply levelexprset_levels_spec. now eexists. - + right. intuition. - * have [_ ho] := valid_model_only_model _ _ _ _ m hincl k. - forward ho by now exists v. now right. -Qed. - -Lemma only_model_of_min_model_map cls V m : - clauses_levels cls ⊂_lset V -> - only_model_of V m -> only_model_of V (min_model_map m cls). -Proof. - intros incl om l. - split. - - move=> /om => [] [k inm]. - have [hmap [hcls hext]] := min_model_map_spec l cls m. - specialize (hext l k inm). firstorder. - - have [hmap [hcls hext]] := min_model_map_spec l cls m. - move=> [] x /hmap => [] [excl allcl maxm]. - red in maxm. - destruct excl as [[cl [incls incl']]|inm]. - * apply incl. apply clauses_levels_spec. exists cl. split => //. - red in incl'. - apply clause_levels_spec. - clear -incl'. firstorder. subst. left. apply levelexprset_levels_spec. - firstorder. - * rewrite (om l). now exists x. -Qed. - -Module CorrectModel. - Record t {V cls} := - { the_model : model; - only_model_of_V : only_model_of V the_model; - model_updates : LevelSet.t; - clauses_declared : clauses_levels cls ⊂_lset V; - model_valid : valid_model V model_updates the_model cls }. - Arguments t : clear implicits. - - Equations? infer_extension_correct {V W init cls} (m : valid_model V W init cls) - (hincl : only_model_of V init) - (hs : clauses_levels cls ⊂_lset V) - (cls' : clauses) - (hs' : clauses_levels cls' ⊂_lset V) : (t V (Clauses.union cls cls')) + premises := - infer_extension_correct m hincl hs cls' hs' with infer_extension m hincl hs cls' := - | Loop u _ => inr u - | Model w m' _ => - inl {| - the_model := min_model_map m.(model_model) cls'; - only_model_of_V := _; - model_updates := w; clauses_declared := _; - model_valid := {| model_model := m'.(model_model) |} |}. - Proof. - - have := valid_model_only_model _ _ _ _ m hincl. - now apply only_model_of_min_model_map. - - intros x; rewrite clauses_levels_spec; rw Clauses.union_spec. - intros [cl [[hin|hin] incl]]. apply hs. apply clauses_levels_spec. clear -hin incl; firstorder. - apply hs'. apply clauses_levels_spec. clear -hin incl; firstorder. - - have vm := model_of_V m'. eapply model_of_subset; tea. lsets. - - apply m'. - - intros ?; rewrite clauses_conclusions_spec. - intros [cl [H H']]. apply Clauses.union_spec in H as [H|H]; - [apply hs|apply hs']; subst a; apply clauses_levels_spec; exists cl; split => //; - eapply clause_levels_spec; auto. - - apply m'. - Qed. - - Equations? infer_extension_valid {V cls} (m : t V cls) cls' : option (t V (Clauses.union cls cls') + premises) := - infer_extension_valid m cls' with inspect (LevelSet.subset (clauses_levels cls') V) := - | exist false heq => None - | exist true heq := Some (infer_extension_correct (model_valid m) _ _ cls' _). - Proof. - - apply only_model_of_V. - - apply m. - - now apply LevelSet.subset_spec in heq. - Qed. -End CorrectModel. - -Module Abstract. - Import CorrectModel. - Record t := - { levels : LevelSet.t; - clauses : Clauses.t; - model : CorrectModel.t levels clauses }. - - Program Definition init_model : t := - {| levels := LevelSet.empty; - clauses := Clauses.empty; - model := _ |}. - Next Obligation. - refine {| the_model := LevelMap.empty _; - only_model_of_V := _; - model_updates := LevelSet.empty; |}. - - intros l. split. lsets. - intros [x hm]. now eapply LevelMapFact.F.empty_mapsto_iff in hm. - - now intros l; rewrite clauses_levels_spec. - - refine {| model_model := LevelMap.empty _ |}. - * red. lsets. - * red. rewrite (proj2 (LevelSet.is_empty_spec _)). lsets. - reflexivity. - * now intros l; rewrite clauses_conclusions_spec. - * rewrite /is_model. eapply Clauses.for_all_spec. tc. - intros x hin. now apply Clauses.empty_spec in hin. - Qed. - - Equations? declare_level (m : t) (l : Level.t) : option t := - declare_level m l with inspect (LevelSet.mem l m.(levels)) := - | exist true _ => None - | exist false hneq => Some {| levels := LevelSet.add l m.(levels); clauses := m.(clauses) |}. - Proof. - refine {| the_model := LevelMap.add l None m.(model).(the_model); - only_model_of_V := _; - model_updates := m.(model).(model_updates); |}. - - intros k. rewrite LevelSet.add_spec /LevelSet.E.eq. - rw LevelMapFact.F.add_mapsto_iff. - have hyp := m.(model).(only_model_of_V) k. - firstorder; subst. all:rewrite /Level.eq. - * now exists None. - * exists x. right; split => //. intros ->. - apply LevelSetFact.not_mem_iff in hneq. contradiction. - - have hyp := m.(model).(clauses_declared). lsets. - - destruct m as [levels clauses vm]; cbn in *. - destruct vm as [init omofV W incl vm]. - destruct vm as [M mofV mupd mcls mok]. cbn in *. - refine {| model_model := LevelMap.add l None M |}. - * intros k. rewrite LevelSet.add_spec LevelMapFact.F.add_in_iff. firstorder. now left. - * move: mupd. - rewrite /is_update_of. - destruct (LevelSet.is_empty) eqn:hw. - now intros ->. - { apply (todo "strict update weakening"). } - * lsets. - * apply (todo "cannot activate more clauses"). - Qed. - - Equations enforce_clauses (m : t) (cls : Clauses.t) : option (t + premises) := - enforce_clauses m cls with infer_extension_valid m.(model) cls := - | None => None - | Some (inl m') => Some (inl {| model := m' |}) - | Some (inr u) => Some (inr u). - -End Abstract. End LoopCheckingImpl. - -Module LoopChecking (LS : LevelSets). - Module Impl := LoopCheckingImpl(LS). - Import Impl.Model. - - Definition model := Impl.Abstract.t. - - Notation univ := LS.LevelExprSet.nonEmptyLevelExprSet. - - Inductive constraint_type := UnivEq | UnivLe. - Notation constraint := (univ * constraint_type * univ). - - Definition enforce_constraint (cstr : constraint) (cls : Clauses.t) : Clauses.t := - let '(l, d, r) := cstr in - match d with - | UnivLe => - LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) (LevelExprSet.t_set l) cls - | UnivEq => - let cls := - LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) (LevelExprSet.t_set l) cls - in - let cls' := - LevelExprSet.fold (fun rk acc => Clauses.add (l, rk) acc) (LevelExprSet.t_set r) cls - in cls' - end. - - Definition init_model := Impl.Abstract.init_model. - - (* Returns None if already declared *) - Definition declare_level l m := Impl.Abstract.declare_level m l. - - (* Returns either a model or a looping universe, i.e. such that u >= u + 1 is implied - by the constraint *) - Definition enforce c (m : model) : option (model + univ) := - Impl.Abstract.enforce_clauses m (enforce_constraint c Clauses.empty). - - (* Returns true is the clause is valid in the model and all its possible consistent extensions. - Returns false if the constraint results in an inconsistent set of constraints or it simply - is not valid. *) - Definition check m c := - Impl.check_clauses m.(Impl.Abstract.clauses) (enforce_constraint c Clauses.empty). - - (* Returns the valuation of the model: a minimal assignement from levels to constraints - that make the enforced clauses valid. *) - Definition valuation m := Impl.valuation_of_model m.(Impl.Abstract.model).(Impl.CorrectModel.the_model). - -End LoopChecking. \ No newline at end of file From cdbb10b4bd6815f2604967b4648c4d8224651b21 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 11 Sep 2025 10:17:07 +0200 Subject: [PATCH 040/164] Cleaned up deciders and loopchecking, Model.v to split --- common/theories/LoopChecking/Common.v | 179 ++ common/theories/LoopChecking/Deciders.v | 1547 +---------------- common/theories/LoopChecking/HornClauses.v | 202 ++- common/theories/LoopChecking/Model.v | 1255 ++++++++++++- .../LoopChecking/PartialLoopChecking.v | 141 -- 5 files changed, 1617 insertions(+), 1707 deletions(-) diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v index 0232fd684..0cd5d096b 100644 --- a/common/theories/LoopChecking/Common.v +++ b/common/theories/LoopChecking/Common.v @@ -167,6 +167,17 @@ Definition max_opt_of {A} (max : A -> A -> A) (x : option A) (y : option A) : op | _, _ => y end. +Lemma max_opt_of_spec {x y k'} : max_opt_of Z.max x y = k' -> + (x ≤ y /\ k' = y) \/ (y ≤ x /\ k' = x). +Proof. + destruct x, y; cbn; firstorder subst. + - destruct (Z.max_spec z z0) as [[]|[]]; + [left|right]; split; try constructor; lia_f_equal. + - right. split; constructor. + - left. split; constructor. + - left; split; constructor. +Qed. + Lemma max_opt_of_l {A} {f : A -> A -> A} l : max_opt_of f l None = l. Proof. destruct l => //. @@ -177,6 +188,16 @@ Proof. destruct l => //. Qed. +Lemma max_opt_of_le_l z z' : z ≤ max_opt_of Z.max z z'. +Proof. + destruct z, z'; cbn; constructor; lia. +Qed. + +Lemma max_opt_of_le_r z z' : z' ≤ max_opt_of Z.max z z'. +Proof. + destruct z, z'; cbn; constructor; lia. +Qed. + Lemma pair_inj {A B} (x x' : A) (y y' : B) P : (x = x' -> y = y' -> P) -> ((x, y) = (x', y') -> P). @@ -213,6 +234,158 @@ Proof. now rewrite (assoc (f := option_map2 Z.max)) (comm (f := option_map2 Z.max) x y) -assoc. Qed. +Local Open Scope Z_scope. +Lemma fold_right_max_in {a l} n : In a l -> a <= fold_right Z.max n l. +Proof. + induction l. + - now cbn. + - intros [eq|inl]. subst a0. cbn. lia. + cbn. specialize (IHl inl). lia. +Qed. + +Lemma fold_right_max_acc {n l} : n <= fold_right Z.max n l. +Proof. + induction l. + - now cbn. + - cbn. lia. +Qed. + +Lemma fold_right_impl n l l' : + (forall x, In x l -> In x l') -> fold_right Z.max n l <= fold_right Z.max n l'. +Proof. + induction l in l' |- *. + - cbn. destruct l'; cbn. lia. + intros. have := @fold_right_max_acc n l'. lia. + - cbn; intros h. + have inal' := (h a (or_introl eq_refl)). + have := fold_right_max_in n inal'. + specialize (IHl l'). + forward IHl. + intros. apply h. now right. + lia. +Qed. + +Lemma fold_right_max_spec n l : + let fn := fold_right Z.max in + (forall x, In x (n :: l) -> x <= fn n l) /\ + (exists x, In x (n :: l) /\ fn n l = x). +Proof. + induction l; cbn. + - split. intros x [] => //. now subst. + exists n. firstorder. + - cbn in IHl. destruct IHl as [h h']. + split. + intros x [|[]]; subst. + * specialize (h x). forward h by auto. lia. + * lia. + * specialize (h x). forward h by auto. lia. + * destruct h' as [x []]. exists (Z.max a x). rewrite -{4}H0. split => //. + destruct H; subst. + destruct (Z.max_spec a x) as [[]|[]]; firstorder; subst. + destruct (Z.max_spec a (fold_right Z.max n l)) as [[]|[]]; firstorder; subst. rewrite H1. + auto. +Qed. + +Lemma fold_right_equivlist_all n n' l l' : + equivlistA eq (n :: l) (n' :: l') -> fold_right Z.max n l = fold_right Z.max n' l'. +Proof. + intros eq. + have [hla [maxl [inmaxl eqmaxl]]] := fold_right_max_spec n l. + have [hra [maxr [inmaxr eqmaxr]]] := fold_right_max_spec n' l'. + rewrite eqmaxl eqmaxr. + red in eq; setoid_rewrite InA_In_eq in eq. + apply (eq _) in inmaxl. apply hra in inmaxl. + apply eq in inmaxr. apply hla in inmaxr. lia. +Qed. + +Lemma fold_right_comm acc l : l <> [] -> fold_right Z.max acc l = Z.max acc (fold_right Z.max (List.hd acc l) (List.tl l)). +Proof. + induction l in acc |- *. + - intros; congruence. + - intros _. cbn. destruct l; cbn. lia. + cbn in IHl. rewrite (IHl acc). congruence. + rewrite (IHl a). congruence. lia. +Qed. + +Lemma fold_left_map {A B C} (f : B -> A -> A) (g : C -> B) l acc : + fold_left (fun acc l => f (g l) acc) l acc = + fold_left (fun acc l => f l acc) (List.map g l) acc. +Proof. + induction l in acc |- *; cbn; auto. +Qed. + +Lemma option_map2_comm x y : option_map2 Z.min x y = option_map2 Z.min y x. +Proof. + destruct x, y; cbn; lia_f_equal. +Qed. + +Lemma option_map2_assoc x y z : + option_map2 Z.min x (option_map2 Z.min y z) = + option_map2 Z.min (option_map2 Z.min x y) z. +Proof. + destruct x, y, z; cbn; lia_f_equal. +Qed. + +Local Notation fn := (fold_left (option_map2 Z.min)). + +Lemma fold_left_impl n l : + (forall x, In x (n :: l) -> fn l n ≤ x) /\ + (exists x, In x (n :: l) /\ fn l n = x). +Proof. + induction l in n |- *. + - cbn. split; intros. + destruct H => //. subst. reflexivity. + exists n. split => //. now left. + - cbn. split; intros. + { destruct (IHl n) as [hle [min [hin heq]]]. + rewrite fold_left_comm. + { now intros; rewrite -option_map2_assoc (option_map2_comm x0 y) option_map2_assoc. } + repeat destruct H; subst. + * specialize (hle n). forward hle. now left. + transitivity (fn l n); auto. eapply Zmin_opt_left. + * eapply Zmin_opt_right. + * transitivity (fn l n); auto. apply Zmin_opt_left. + apply hle. now right. } + * specialize (IHl (option_map2 Z.min n a)). + destruct IHl as [hle [min [hin heq]]]. subst min. eexists. split; trea. + destruct hin. + rewrite -H. + destruct n, a; cbn; firstorder. + destruct (Z.min_spec z z0) as [[? heq]|[? heq]]. + rewrite -{1}heq. now left. right; left. f_equal. lia. + now right. +Qed. + +Lemma fold_left_impl_eq n n' l l' : + (forall x, In x (n :: l) <-> In x (n' :: l' )) -> + fn l n = fn l' n'. +Proof. + intros heq. + destruct (fold_left_impl n l) as [hle [minl [hin heq']]]. + destruct (fold_left_impl n' l') as [hle' [minl' [hin' heq'']]]. + rewrite heq' heq''. + specialize (hle minl'). forward hle. now apply heq. + specialize (hle' minl). forward hle'. now apply heq. + rewrite heq'' in hle'. rewrite heq' in hle. depelim hle'. depelim hle. f_equal; lia. + now depelim hle. +Qed. + +Lemma fold_left_comm_f {A} (f : A -> A -> A) n l : + (forall x y, f x y = f y x) -> + fold_left f l n = fold_left (flip f) l n. +Proof. + induction l in n |- *; cbn; auto. + intros hf. rewrite IHl //. + unfold flip. now rewrite hf. +Qed. + +Lemma nleq_optZ k k' : ~ k ≤ Some k' -> exists z, k = Some z /\ k' < z. +Proof. + destruct k. + - exists z. split => //. eapply Znot_ge_lt => hl; apply H. constructor. lia. + - elim. constructor. +Qed. + Notation max_opt := (option_map2 Z.max). Lemma max_opt_spec x y z : max_opt x y = Some z -> exists x' y', x = Some x' /\ y = Some y' /\ z = Z.max x' y'. @@ -236,3 +409,9 @@ Proof. repeat intro. split; intros []; split; intuition auto. Qed. +#[export, refine] Instance ge_refl : Reflexive Z.ge := _. +Proof. red. lia. Qed. + +#[export, refine] Instance ge_trans : Transitive Z.ge := _. +Proof. red. lia. Qed. + diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index a17b0319e..4dcb09c05 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -20,6 +20,10 @@ Module Type LoopCheckingItf (LS : LevelSets). Inductive constraint_type := UnivEq | UnivLe. Notation constraint := (univ * constraint_type * univ). + (* Returns the valuation of the model: a minimal assignement from levels to constraints + that make the enforced clauses valid. *) + Parameter valuation : model -> LS.LevelMap.t nat. + Parameter init_model : model. (* Returns None if already declared *) @@ -30,14 +34,18 @@ Module Type LoopCheckingItf (LS : LevelSets). by the constraint *) Parameter enforce : constraint -> model -> option (model + univ). + (* Definition valid_constraint m c := + let v := valuation m in + clause_sem v c. + + Parameter enforce_spec : forall c m, enforce c m = Some (inl m') -> + valid_constraint m c. *) + (* Returns true is the clause is valid in the model and all its possible consistent extensions. Returns false if the constraint results in an inconsistent set of constraints or it simply is not valid. *) Parameter check : model -> constraint -> bool. - (* Returns the valuation of the model: a minimal assignement from levels to constraints - that make the enforced clauses valid. *) - Parameter valuation : model -> LS.LevelMap.t nat. End LoopCheckingItf. Module Deciders (LS : LevelSets). @@ -122,408 +130,12 @@ Proof. - apply is_update_of_empty. Qed. -Definition enabled_clause (m : model) (cl : clause) := - exists z, min_premise m (premise cl) = Some z. - -Definition enabled_clauses (m : model) (cls : clauses) := - Clauses.For_all (enabled_clause m) cls. - -Definition correct_model (cls : clauses) (m : model) := - enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. - Definition infer_correctness cls := match infer_model cls with | Some m => correct_model cls m | None => ~ exists v, clauses_sem v cls end. -Lemma enabled_clauses_ext m m' cls : m ⩽ m' -> enabled_clauses m cls -> enabled_clauses m' cls. -Proof. - intros hext. - rewrite /enabled_clauses. - intros ha cl; move/ha. - unfold enabled_clause. - intros [minp heq]. - have hp := min_premise_pres (premise cl) hext. - rewrite heq in hp. depelim hp. now exists y. -Qed. - -Lemma interp_prems_ge v (prems : premises) : - forall prem, LevelExprSet.In prem prems -> - interp_expr v prem <= interp_prems v prems. -Proof. - intros. - unfold interp_prems. - have he := to_nonempty_list_spec prems. - destruct to_nonempty_list. - pose proof to_nonempty_list_spec'. - rewrite In_elements in H. rewrite -he in H. clear H0 he. clear -H. - destruct H. subst p. - - induction l. cbn. auto. - cbn. lia. cbn. lia. - - induction l in H |- *. - now cbn in H. - cbn in H. destruct H; subst; cbn. - * cbn. lia. - * specialize (IHl H). lia. -Qed. - -(** Enabled and valid clauses are satisfied by valuation *) -Lemma valid_clause_model model cl : - enabled_clause model cl -> - valid_clause model cl -> - clause_sem (valuation_of_model model) cl. -Proof. - unfold enabled_clause, valid_clause. - destruct min_premise eqn:hmin => //= => //. - 2:{ intros [k' eq]. congruence. } - intros [k' eq]. noconf eq. - destruct cl as [prems [concl k]]; cbn. - unfold level_value_above. - destruct level_value eqn:hl => //. - unfold interp_level. unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. - move/Z.leb_le => hrel. - eapply LevelMap.find_2 in hfind. - have conclm := valuation_of_model_spec _ _ _ hfind. - set (v := (model_max _ - _)) in *. - cbn in conclm. - eapply LevelMap.find_1 in conclm. rewrite conclm. - subst v. - pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. - rewrite hmin in premeq. - eapply Z.le_ge. - eapply Z.le_trans. 2:{ eapply interp_prems_ge; tea. } - unfold interp_expr. destruct prem as [prem k']. - symmetry in premeq. - move: premeq. unfold min_atom_value. - unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. - destruct o => //. - intros [= <-]. - eapply LevelMap.find_2 in findp. - have premm := valuation_of_model_spec _ _ _ findp. - unfold interp_level. - eapply LevelMap.find_1 in premm. rewrite premm. - assert (z1 - k' <= z0 - k). lia. - have hm : z0 <= model_max model. - { eapply model_max_spec in hfind; tea. now depelim hfind. } - have hm' : z1 <= model_max model. - { eapply model_max_spec in findp; tea. now depelim findp. } - have hmi : model_min model <= z0. - { eapply model_min_spec; tea. } - have hmi' : model_min model <= z1. - { eapply model_min_spec; tea. } - assert (0 <= model_max model)%Z by apply model_max_spec2. - assert (model_min model <= 0)%Z by apply model_min_spec2. - lia. -Qed. - -Lemma init_model_enabled cls : enabled_clauses (init_model cls) cls. -Proof. - unfold enabled_clauses. - intros x hin. unfold enabled_clause. - pose proof (@min_premise_spec (init_model cls) (premise x)) as [premmin [prem [premin premeq]]]. - have inV : LevelSet.In prem (clauses_levels cls). - { rewrite clauses_levels_spec. exists x; split => //. rewrite /clause_levels. - eapply LevelSet.union_spec; left. rewrite levelexprset_levels_spec. exists prem.2. - destruct prem. exact premin. } - unfold init_model. rewrite premeq. unfold min_atom_value. - destruct prem as [l k]. - have hm := max_clause_premises_spec_inv cls l inV. - rewrite (level_value_MapsTo hm). - have hs := max_clause_premise_of_spec l k _ _ hin premin. - depelim hs. rewrite H0. - eexists => //. -Qed. - -Lemma interp_add_expr V n e : interp_expr V (add_expr n e) = n + interp_expr V e. -Proof. - destruct e as [l k]; cbn. lia. -Qed. - -Lemma interp_prems_singleton V e : - interp_prems V (singleton e) = interp_expr V e. -Proof. - rewrite /interp_prems. - now rewrite singleton_to_nonempty_list /=. -Qed. - -Lemma fold_right_max_in {a l} n : In a l -> a <= fold_right Z.max n l. -Proof. - induction l. - - now cbn. - - intros [eq|inl]. subst a0. cbn. lia. - cbn. specialize (IHl inl). lia. -Qed. - -Lemma fold_right_max_acc {n l} : n <= fold_right Z.max n l. -Proof. - induction l. - - now cbn. - - cbn. lia. -Qed. - -Lemma fold_right_impl n l l' : - (forall x, In x l -> In x l') -> fold_right Z.max n l <= fold_right Z.max n l'. -Proof. - induction l in l' |- *. - - cbn. destruct l'; cbn. lia. - intros. have := @fold_right_max_acc n l'. lia. - - cbn; intros h. - have inal' := (h a (or_introl eq_refl)). - have := fold_right_max_in n inal'. - specialize (IHl l'). - forward IHl. - intros. apply h. now right. - lia. -Qed. - -Lemma fold_right_equivlist n l l' : - equivlistA eq l l' -> fold_right Z.max n l = fold_right Z.max n l'. -Proof. - intros eq. - have h := fold_right_impl n l l'. - forward h. intros x; rewrite -!InA_In_eq. apply eq. - have h' := fold_right_impl n l' l. - forward h'. intros x; rewrite -!InA_In_eq. apply eq. - lia. -Qed. - -Fixpoint max_list (l : list Z) : option Z := - match l with - | [] => None - | x :: xs => match max_list xs with - | Some m => Some (Z.max x m) - | None => Some x end - end. - -Lemma max_list_fold_right n l : max_list (n :: l) = Some (fold_right Z.max n l). -Proof. - induction l; cbn. - - reflexivity. - - cbn in IHl. destruct max_list. f_equal. noconf IHl. lia. - f_equal; noconf IHl. lia. -Qed. - -Lemma fold_right_max_spec n l : - let fn := fold_right Z.max in - (forall x, In x (n :: l) -> x <= fn n l) /\ - (exists x, In x (n :: l) /\ fn n l = x). -Proof. - induction l; cbn. - - split. intros x [] => //. now subst. - exists n. firstorder. - - cbn in IHl. destruct IHl as [h h']. - split. - intros x [|[]]; subst. - * specialize (h x). forward h by auto. lia. - * lia. - * specialize (h x). forward h by auto. lia. - * destruct h' as [x []]. exists (Z.max a x). rewrite -{4}H0. split => //. - destruct H; subst. - destruct (Z.max_spec a x) as [[]|[]]; firstorder; subst. - destruct (Z.max_spec a (fold_right Z.max n l)) as [[]|[]]; firstorder; subst. rewrite H1. - auto. -Qed. - -Lemma fold_right_equivlist_all n n' l l' : - equivlistA eq (n :: l) (n' :: l') -> fold_right Z.max n l = fold_right Z.max n' l'. -Proof. - intros eq. - have [hla [maxl [inmaxl eqmaxl]]] := fold_right_max_spec n l. - have [hra [maxr [inmaxr eqmaxr]]] := fold_right_max_spec n' l'. - rewrite eqmaxl eqmaxr. - red in eq; setoid_rewrite InA_In_eq in eq. - apply (eq _) in inmaxl. apply hra in inmaxl. - apply eq in inmaxr. apply hla in inmaxr. lia. -Qed. - -Lemma interp_prems_elements V u : - interp_prems V u = fold_right Z.max (interp_expr V (to_nonempty_list u).1) (List.map (interp_expr V) (to_nonempty_list u).2). -Proof. - rewrite /interp_prems. - have he := to_nonempty_list_spec u. - destruct to_nonempty_list. - now rewrite Universes.fold_right_map. -Qed. - -Lemma fold_right_interp {V x l x' l'} : - equivlistA eq (x :: l) (x' :: l') -> - fold_right Z.max (interp_expr V x) (List.map (interp_expr V) l) = fold_right Z.max (interp_expr V x') (List.map (interp_expr V) l'). -Proof. - intros eq. apply fold_right_equivlist_all. - intros a. rewrite !InA_In_eq. - rewrite !(in_map_iff (interp_expr V) (_ :: _)). - setoid_rewrite <-InA_In_eq. - split. - - move=> [b [<- ]]. - eexists; split; trea. now apply eq in b0. - - move=> [b [<- ]]. - eexists; split; trea. now apply eq in b0. -Qed. - -Lemma equivlistA_add le u : let l := to_nonempty_list (add le u) in - equivlistA eq (l.1 :: l.2) (le :: LevelExprSet.elements u). -Proof. - have he := to_nonempty_list_spec (add le u). - destruct to_nonempty_list. cbn. - intros x. rewrite he. - rewrite !LevelExprSet.elements_spec1. - split. - - move/LevelExprSet.add_spec => [->|hin]. - now constructor. constructor 2. now apply LevelExprSet.elements_spec1. - - intros h; depelim h; subst. now apply LevelExprSet.add_spec; left. - apply LevelExprSet.add_spec. now apply LevelExprSet.elements_spec1 in h. -Qed. - -Lemma fold_right_comm acc l : l <> [] -> fold_right Z.max acc l = Z.max acc (fold_right Z.max (List.hd acc l) (List.tl l)). -Proof. - induction l in acc |- *. - - intros; congruence. - - intros _. cbn. destruct l; cbn. lia. - cbn in IHl. rewrite (IHl acc). congruence. - rewrite (IHl a). congruence. lia. -Qed. - -Lemma interp_prems_add V le (u : premises) : - interp_prems V (add le u) = Z.max (interp_expr V le) (interp_prems V u). -Proof. - rewrite 2!interp_prems_elements. - erewrite fold_right_interp. 2:apply equivlistA_add. - rewrite fold_right_comm. - { apply map_nil, elements_not_empty. } - f_equal. eapply fold_right_equivlist_all. - have he := to_nonempty_list_spec u. - destruct to_nonempty_list. rewrite -he //=. -Qed. - -Lemma interp_prems_eq (P : premises -> Z -> Prop) V : - (forall le, P (singleton le) (interp_expr V le)) -> - (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (add le u) (Z.max (interp_expr V le) k)) -> - forall u, P u (interp_prems V u). -Proof. - intros hs hadd. - eapply premises_elim. - - intros le. rewrite interp_prems_singleton. apply hs. - - intros le prems ih hnin. - rewrite interp_prems_add. now apply hadd. -Qed. - -Lemma add_prems_singleton n cl : add_prems n (singleton cl) = singleton (add_expr n cl). -Proof. - apply eq_univ_equal => [] [l k]. - rewrite In_add_prems LevelExprSet.singleton_spec. - firstorder. - - destruct x; noconf H0. - eapply LevelExprSet.singleton_spec in H. - now red in H; noconf H. - - destruct cl. exists (t, z). split => //. - red in H; noconf H. now apply LevelExprSet.singleton_spec. -Qed. - -Lemma interp_add_prems V n e : interp_prems V (add_prems n e) = n + interp_prems V e. -Proof. - revert e. - refine (interp_prems_eq (fun u z => interp_prems V (add_prems n u) = n + z) _ _ _). - - intros le. - rewrite add_prems_singleton interp_prems_singleton //=. - destruct le; cbn. lia. - - intros le u k heq hnin. - rewrite add_prems_add. - rewrite interp_prems_add heq interp_add_expr. lia. -Qed. - -Lemma in_pred_closure_entails cls cl : - in_pred_closure cls cl -> - (forall V, clauses_sem V cls -> clause_sem V cl). -Proof. - induction 1. - - intros V. rewrite /clauses_sem. intros ha. - apply ha in H. - move: H; rewrite /clause_sem. - destruct cl as [prems concl]. - cbn. rewrite interp_add_prems. - destruct concl as [concl conclk]. - rewrite /add_expr; cbn. lia. - - intros V clsm. cbn. - rewrite interp_prems_singleton. - cbn. lia. -Qed. - -Lemma interp_prems_in {V le} {u : premises} : LevelExprSet.In le u -> interp_prems V u >= interp_expr V le. -Proof. - revert u. - refine (interp_prems_eq (fun u z => LevelExprSet.In le u -> z >= interp_expr V le) V _ _). - - intros le' u'. - apply LevelExprSet.singleton_spec in u'. red in u'; subst. lia. - - move=> le' u z hz hnin /LevelExprSet.add_spec [->|hin]. lia. - specialize (hz hin). lia. -Qed. - -Lemma clauses_sem_subset {u u' : premises} : u ⊂_leset u' -> - forall V, interp_prems V u' >= interp_prems V u. -Proof. - intros hsub V. - revert u u' hsub. - refine (interp_prems_eq (fun u z => forall u' : premises, u ⊂_leset u' -> interp_prems V u' >= z) V _ _). - - intros le u' hsing. - specialize (hsing le). forward hsing by now apply LevelExprSet.singleton_spec. - now apply interp_prems_in. - - intros le u k ih hin u' sub. - have hle := sub le. - specialize (ih u'). - forward ih. intros x hin'. apply sub. now apply LevelExprSet.add_spec; right. - forward hle by now apply LevelExprSet.add_spec; left. - have hi := interp_prems_in (V := V) hle. lia. -Qed. - -#[refine] Instance ge_refl : Reflexive Z.ge := _. -Proof. red. lia. Qed. - -#[refine] Instance ge_trans : Transitive Z.ge := _. -Proof. red. lia. Qed. - -Lemma clauses_sem_entails {cls cl} : - entails cls cl -> - (forall V, clauses_sem V cls -> clause_sem V cl). -Proof. - induction 1. - - intros v clls. red. - destruct concl0 as [concl k]. - have hge := interp_prems_ge v prems _ H. - by lia. - - move=> V Hcls. - move: {IHentails} (IHentails _ Hcls). - unfold clause_sem. unfold ge => hyp. - etransitivity; tea. rewrite interp_prems_add. - rewrite interp_prems_add in hyp. - eapply in_pred_closure_entails in H; tea. - move: H; rewrite /clause_sem. unfold ge. - have ssub := clauses_sem_subset H1 V. lia. -Qed. - -Lemma clauses_sem_entails_all {cls prems concl} : - cls ⊢a prems → concl -> - (forall V, clauses_sem V cls -> interp_prems V prems >= interp_prems V concl). -Proof. - intros ha V hcls. - red in ha. - move: ha. - revert concl. - refine (@interp_prems_eq (fun concl z => _ -> interp_prems V prems >= z) V _ _). - - move=> le //=. move/(_ le). - intros h; forward h by now apply LevelExprSet.singleton_spec. - now have ent := (clauses_sem_entails h _ hcls). - - intros le u k ih hnin. - intros hf. - forward ih. intros x hin; apply (hf x). - rewrite LevelExprSet.add_spec; now right. - specialize (hf le). - forward hf by now apply LevelExprSet.add_spec; left. - cbn in hf. - have ent := (clauses_sem_entails hf _ hcls). cbn in ent. - lia. -Qed. - Lemma infer_correct cls : infer_correctness cls. Proof. unfold infer_correctness. @@ -554,8 +166,6 @@ Proof. rewrite interp_add_prems in sem. lia. Qed. -Definition valid_entailment cls cl := forall V, clauses_sem V cls -> clause_sem V cl. - Program Definition loop_check cls (cl : clause) : result (premises_model (clauses_levels cls) cl).1 LevelSet.empty cls (premises_model (clauses_levels cls) cl).2 := let V := clauses_levels cls in loop (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 (premises_model V cl).2 _. @@ -568,391 +178,12 @@ Next Obligation. - apply is_update_of_empty. Qed. -Definition premises_of_level_set (l : LevelSet.t) := - LevelSet.fold (fun l acc => (l, 0) :: acc) l []. - -Definition extendV V (cl : clause) := - let '(prems, concl) := cl in - (add_list (premises_of_level_set V) prems, concl). - -Lemma premises_model_map_min_premise {levels cls prems z} : - min_premise (premises_model_map (zero_model levels) cls) prems = Some z -> - (exists minp mink, LevelExprSet.In (minp, mink) prems /\ - exists maxp, max_clause_premise_of minp cls = Some maxp /\ - z = maxp - mink) \/ - (exists minp mink, LevelExprSet.In (minp, mink) prems /\ z + mink <= 0)%Z. -Proof. - set (m := premises_model_map _ _). - have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m prems. - rewrite mineq. rewrite /min_atom_value. - destruct level_value eqn:hl => //. intros [= <-]. - eapply level_value_MapsTo' in hl. - eapply premises_model_map_spec in hl as [[inpcls [hm _]]|[ninpcls h']]. left. - 2:{ apply zero_model_spec in h' as [h' [= ->]]. } - exists minp, mink. split => //. noconf hm. rewrite -hm. - eexists; split => //. -Qed. - -Lemma premises_model_map_min_premise_inv {levels cls} : - forall cl, Clauses.In cl cls -> - exists z, min_premise (premises_model_map (zero_model levels) cls) (premise cl) = Some z /\ (0 <= z)%Z. -Proof. - set (m := premises_model_map _ _). - move=> cl hin. - have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m (premise cl). - rewrite mineq. rewrite /min_atom_value. - destruct level_value eqn:hl => //. - - eexists. split; trea. - have ps := proj1 (premises_model_map_spec _ cls minp (Some z)) (level_value_MapsTo' hl). - destruct ps as [[minpsl [eq _]]|]. - * symmetry in eq. - have sp := (max_clause_premise_of_spec _ _ _ _ hin inminp). - depelim sp. rewrite eq in H0. noconf H0. lia. - * destruct H. elim H. - eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. - - unfold level_value in hl. - destruct LevelMap.find eqn:hl'. subst o. - 2:{ move/LevelMapFact.F.not_find_in_iff: hl'. elim. - rewrite premises_model_map_in. left. - eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. } - eapply LevelMap.find_2 in hl'. - move/premises_model_map_spec: hl' => [[]|[nin hm]] => //. - * now intros hnminp [_ hn]. - * move: nin; elim. - eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. -Qed. - -Lemma is_update_of_entails {cls V m m' hne hne'} : is_update_of cls V m m' -> - cls ⊢a of_level_map m hne → of_level_map m' hne'. -Proof. - rewrite /is_update_of. - destruct LevelSet.is_empty. - - intros heq []. - rewrite !of_level_map_spec. rewrite -heq. - constructor. now apply of_level_map_spec. - - eapply strictly_updates_entails. -Qed. - -Lemma is_update_of_non_empty {cls V m m'} : ~ LevelMap.Empty m -> - is_update_of cls V m m' -> - ~ LevelMap.Empty m'. -Proof. - rewrite /is_update_of. destruct LevelSet.is_empty. - - now intros he <-. - - intros he su. now eapply strictly_updates_non_empty_map in su. -Qed. - -Instance defined_map_proper : Proper (LevelMap.Equal ==> iff) defined_map. -Proof. - intros x y eq; rewrite /defined_map. - now setoid_rewrite eq. -Qed. - -Lemma is_update_of_defined_map {cls V m m'} : defined_map m -> - is_update_of cls V m m' -> - defined_map m'. -Proof. - rewrite /is_update_of. destruct LevelSet.is_empty. - - now intros he <-. - - intros he su. now eapply strictly_updates_defined_map in su. -Qed. - -Lemma inj_add_prems_sub {n u u'} : add_prems n u ⊂_leset add_prems n u' -> u ⊂_leset u'. -Proof. - rewrite /add_prems. - intros hm [l k]. specialize (hm (l, k + n)). - rewrite !map_spec in hm. - intros hin. - forward hm. exists (l, k); split => //. - destruct hm as [[] [hin' eq]]. - apply (@add_expr_inj n (l, k)) in eq. now noconf eq. -Qed. - -Lemma premises_of_level_set_spec l k V : LevelSet.In l V /\ k = 0 <-> In (l, k) (premises_of_level_set V). -Proof. - rewrite /premises_of_level_set. - eapply LevelSetProp.fold_rec. - - intros s' he. firstorder. - - intros x a s' s'' hin hnin hadd ih. - red in hadd. rewrite {}hadd. - cbn. firstorder. subst. now left. noconf H1. now left. now noconf H1. -Qed. - -Lemma in_succ_add_premises {V u x k} : LevelExprSet.In (x, Z.of_nat (k + 1)) (add_list (premises_of_level_set V) u) -> LevelExprSet.In (x, Z.of_nat (k + 1)) u. -Proof. - rewrite add_list_spec. intros [hn|hn] => //. - eapply premises_of_level_set_spec in hn as []. lia. -Qed. - -(* Lemma inj_succ_prems {V u u'} : succ_prems u ⊂_leset add_list (premises_of_level_set V) u' -> succ_prems u ⊂_leset u'. -Proof. - intros sub x. rewrite In_add_prems => [] [[l k] [hin ->]]. - specialize (sub (l, Z.of_nat (k + 1))). - forward sub. - apply In_add_prems. exists (l, k). split => //. - now apply in_succ_add_premises in sub. -Qed. *) - -Lemma succ_clauses_equiv cls prems concl : - succ_clauses cls ⊢ succ_prems prems → succ_expr concl -> - cls ⊢ prems → concl. -Proof. - intros ha; depind ha. - - constructor. - move: H. - rewrite In_add_prems => [] [le [hin heq]]. - move/add_expr_inj: heq. now intros ->. - - depelim H. - + destruct cl as [prems concl]. noconf H0. - eapply in_add_clauses in H as [[prems' concl'] [hin heq]]. - noconf heq. - eapply (clause_cut _ (add_prems n prems') (add_expr n concl')). 2:eapply IHha. - 2:{ f_equal. rewrite !add_expr_add_expr. now rewrite add_prems_add add_expr_add_expr Z.add_comm. } - exact: (incls cls (prems', concl') n hin). - rewrite add_prems_add_prems in H1. rewrite Z.add_comm in H1. - rewrite -(add_prems_add_prems 1 n prems') in H1. - now move/inj_add_prems_sub: H1. - + specialize (H0 (x, k + 1)). forward H0. now apply LevelExprSet.singleton_spec. - eapply In_add_prems in H0 as [[l' k'] [hin heq]]. noconf heq. - have eq: k' = k by lia. subst k'. clear H. - eapply clause_cut. 2:eapply IHha. eapply (predcl _ x (k - 1)). - 2:{ intros x'. move/LevelExprSet.singleton_spec => ->. now have -> : k - 1 + 1 = k by lia. } - f_equal. rewrite add_prems_add. f_equal. - rewrite /succ_expr //=. lia_f_equal. -Qed. - -Lemma entails_weak_list {cls prem concl concl'} : - cls ⊢ prem → concl -> - cls ⊢ add_list concl' prem → concl. -Proof. - intros hcl. - induction concl' in prem, hcl |- *. - - exact hcl. - - cbn. eapply IHconcl'. now eapply entails_weak. -Qed. - -Lemma entails_all_weak_list {cls prem concl concl'} : - entails_all cls prem concl -> - entails_all cls (add_list concl' prem) concl. -Proof. - intros hcl x hin. - specialize (hcl _ hin). cbn in hcl. - now eapply entails_weak_list. -Qed. - -Lemma premises_of_level_set_empty : premises_of_level_set LevelSet.empty = []. -Proof. - now rewrite /premises_of_level_set LevelSetProp.fold_empty. -Qed. - -(* Lemma succ_clauses_equiv_weak cls prems concl : - succ_clauses cls ⊢ succ_prems prems → succ_expr concl -> - cls ⊢ prems → concl. -Proof. - move/(entails_weak_list (concl' := [])) => he. - eapply (succ_clauses_equiv _ LevelSet.empty). - cbn. now rewrite premises_of_level_set_empty. -Qed. *) - -Lemma entails_all_succ_clauses cls prems concl : - succ_clauses cls ⊢a succ_prems prems → succ_prems concl -> - cls ⊢a prems → concl. -Proof. - intros ha l hin. specialize (ha (succ_expr l)). forward ha. - eapply In_add_prems. exists l. split => //. cbn in ha. - now eapply succ_clauses_equiv in ha. -Qed. - -Definition entails_equiv cls u u' := - cls ⊢a u → u' /\ cls ⊢a u' → u. - -Notation "cls '⊢a' u ↔ u'" := (entails_equiv cls u u') (at level 90). - -Lemma max_premise_of_spec_aux s l k : - max_premise_of l s = k -> - (forall k', LevelExprSet.In (l, k') s -> (Some k' ≤ k)) /\ - ((exists k', LevelExprSet.In (l, k') s /\ k = Some k') \/ - ((~ exists k', LevelExprSet.In (l, k') s) /\ k = None)). -Proof. - unfold max_premise_of. - revert k. - eapply LevelExprSetProp.fold_rec. - - intros s' he k <-. cbn. split => //. - * now move=> k' /he. - * right; split => //. now move=> [] k' /he. - - intros [l' k'] a s' s'' hin hnin hadd ih k. - specialize (ih _ eq_refl) as [hle hex]. - intros hmax. - split. move=> k'0 /hadd => [] []. - { move=> [=] eq eq'. subst l' k'. rewrite eqb_refl in hmax. - destruct a; cbn in hmax; subst; constructor; lia. } - { move/hle. move: hmax. destruct (eqb_spec l l'); subst. - intros <-. intros h; depelim h; cbn. constructor; lia. - intros -> h; depelim h; constructor; lia. } - destruct hex as [[k'' [hin' heq]]|nex]. subst a. - { left. destruct (eqb_spec l l'). subst. exists (Z.max k' k''); split; trea. - 2:{ subst k. eexists; split => //. apply hadd. now right. } - eapply hadd. - destruct (Z.max_spec k' k'') as [[hlt ->]|[hle' ->]] => //. now right. now left. } - destruct nex as [nex ->]. - destruct (eqb_spec l l'). subst. left. exists k'. split => //. apply hadd; now left. - subst k. right. split => //. - intros [k'' hin']. apply hadd in hin' as []. noconf H0. congruence. - apply nex. now exists k''. -Qed. - -Lemma max_premise_of_prems_max {l prems k} : - max_premise_of l prems = Some k -> LevelExprSet.In (l, k) prems. -Proof. - destruct max_premise_of eqn:maxp => //. intros [= ->]. - apply max_premise_of_spec_aux in maxp as [hle hex]. - destruct hex as [[k' [hin [= ->]]]|hne] => //. - destruct hne; congruence. -Qed. - -Lemma max_premise_of_singleton l k : max_premise_of l (singleton (l, k)) = Some k. -Proof. - remember (max_premise_of l (singleton (l, k))) as mp. symmetry in Heqmp. - apply max_premise_of_spec_aux in Heqmp as [hle hex]. - destruct hex as [[k' [hin heq]]|hne] => //. - eapply LevelExprSet.singleton_spec in hin. now noconf hin. - destruct hne as [nein ->]. elim nein. - exists k. now eapply LevelExprSet.singleton_spec. -Qed. - -Lemma max_premise_of_spec2 l k (u : premises) : LevelExprSet.In (l, k) u -> - exists k', LevelExprSet.In (l, k') u /\ max_premise_of l u = Some k'. -Proof. - remember (max_premise_of l u) as mp. symmetry in Heqmp. - apply max_premise_of_spec_aux in Heqmp as [hle hex]. - intros hin. destruct hex. firstorder. - destruct H as [nein ->]. elim nein. now exists k. -Qed. - -Lemma max_premise_of_spec_in l (u : premises) : LevelSet.In l (levels u) -> - exists k, max_premise_of l u = Some k /\ LevelExprSet.In (l, k) u. -Proof. - intros hexi. - remember (max_premise_of l u) as mp. symmetry in Heqmp. - apply max_premise_of_spec_aux in Heqmp as [hle hex]. - destruct hex. destruct H as [l' [hin heq]]. subst mp. - - eexists; split => //. - - destruct H as [nein ->]. elim nein. - now eapply levelexprset_levels_spec in hexi. -Qed. - -(* Lemma of_level_map_premises_model_map cls cl V ne : - (forall l, LevelSet.In l (clause_levels cl) -> LevelSet.In l V) -> - cls ⊢a add_list (premises_of_level_set V) (premise cl) → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. -Proof. - intros hin [l k]. - rewrite of_level_map_spec. move/premises_model_map_spec; cbn. - rewrite max_opt_of_l. - cbn; rewrite LevelSet.union_spec. firstorder try lsets. - cbn in H1. - - rewrite Z.max_comm. - destruct (Z.max_spec 0 (max_premise_of l (premise cl))) as [[hle ->]|[hge ->]]. - * constructor. rewrite add_list_spec; right. - now eapply max_premise_of_spec_in. - * constructor. rewrite add_list_spec. left. - apply premises_of_level_set_spec. split => //. - apply hin. apply clause_levels_spec. now left. - - eapply zero_model_spec in H1 as [hin' [= ->]]. -Qed. *) - -(* Lemma max_premise_of_pos l prems : max_premise_of l prems >= 0. -Proof. - have hs := max_premise_of_spec_aux prems l. - destruct max_premise_of. lia. lia. - specialize (hs _ eq_refl) as [_ [[k' []]|[_ hne]]]; lia. -Qed. - *) - -Lemma of_level_map_premises_model_map cls cl V ne : - cls ⊢a premise cl → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. -Proof. - intros [l k]. - rewrite of_level_map_spec. move/premises_model_map_spec; cbn. - intros [[hin' [[= heq] _]]|[hnin hm]]. - 2:{ now apply zero_model_spec in hm as []. } - move: hin'; cbn; rewrite LevelSet.union_spec. intros []; [|lsets]. - eapply max_premise_of_spec_in in H as [maxp' [eq hin']]. - rewrite eq in heq; noconf heq. - now constructor. -Qed. - -Lemma entails_all_satisfies {cls prems m hne l k} : - cls ⊢a prems → of_level_map m hne -> - infers_atom m l k -> - cls ⊢ prems → (l, k). -Proof. - intros hl hi. - eapply entails_all_one; tea. now apply infers_atom_of_level_map. -Qed. - -Lemma premises_model_map_ne V cls : - ~ LevelMap.Empty V -> - ~ LevelMap.Empty (premises_model_map V cls). -Proof. - intros ne he. apply ne. - have ne' := premises_model_map_in V cls. - intros l k hin. - specialize (ne' l). destruct ne'. forward H0. right. now exists k. - destruct H0 as [k' hin']. - now move/he: hin'. -Qed. - -Lemma clauses_ne_exist cls : ~ Clauses.Empty cls -> exists cl, Clauses.In cl cls. -Proof. - intros ne. - destruct (Clauses.choose cls) eqn:hc. - - exists e. now apply Clauses.choose_spec1 in hc. - - now apply Clauses.choose_spec2 in hc. -Qed. - -Lemma premises_model_map_defined V cls : - ~ Clauses.Empty cls -> - defined_map (premises_model_map V cls). -Proof. - move/clauses_ne_exist => [cl hin]. - destruct cl as [prems concl]. - pose proof (to_nonempty_list_spec' prems). - set (l := (to_nonempty_list prems).1) in *. - have hs := max_clause_premise_of_spec l l.2 cls (prems, concl) hin. - forward hs. cbn. eapply LevelExprSet.elements_spec1; rewrite -H. - constructor. destruct l; reflexivity. depelim hs. - exists l, y. apply premises_model_map_spec. left. - split => //. - eapply clauses_premises_levels_spec. eexists; split; tea => //. - rewrite //= levelexprset_levels_spec. exists l.2. - setoid_rewrite <- LevelExprSet.elements_spec1. rewrite -H //=. - constructor. destruct l; reflexivity. -Qed. - Variant check_result {cls} := | IsLooping (v : premises) (islooping : loop_on_univ cls v) | Invalid | Valid. Arguments check_result : clear implicits. -Equations check_atom_value (z : option Z) (l : option Z) : bool := - | Some _, None => false - | Some z, Some v => z <=? v - | None, _ => true. - -Lemma check_atom_value_spec z l : reflectProp (z ≤ l) (check_atom_value z l). -Proof. - funelim (check_atom_value z l). - - destruct (Z.leb_spec z v); constructor. - * now constructor. - * intros h; depelim h. lia. - - constructor. intros h; depelim h. - - constructor. constructor. -Qed. - Lemma valid_model_find {V W cl cls} : forall v : valid_model (clause_levels cl ∪ V) W (premises_model_map (zero_model (clause_levels cl ∪ V)) (Clauses.singleton cl)) cls, ~ LevelMap.find (concl cl).1 (model_model v) = None. @@ -987,7 +218,7 @@ Definition check_clauses (cls : clauses) (cls' : clauses) : bool := Clauses.for_all check_one cls'. (* If a clause checks, then it should be valid in any extension of the model *) -Lemma check_entails {cls cl} : +Theorem check_entails {cls cl} : check cls cl = Valid -> valid_entailment cls cl. Proof. destruct cl as [prems [concl k]]. @@ -1013,355 +244,7 @@ Proof. eapply (entails_all_satisfies (l := concl0) (k := k)) in tr. 2:{ red. rewrite /level_value he. now constructor. } eapply clauses_sem_entails in tr ; tea. -Qed. - -Definition invalid_entailment cls cl := - forall V, clauses_sem V cls -> clause_sem V cl -> False. - -Definition infers_univ (m : model) (u : premises) := - exists z, min_premise m u = Some z /\ (0 <= z)%Z. - -Definition infers_expr (m : model) (le : LevelExpr.t) := - let '(l, k) := le in infers_atom m l k. - -Lemma valid_clause_elim {m prems concl k} : valid_clause m (prems, (concl, k)) -> - forall z, min_premise m prems = Some z -> - Some (z + k) ≤ level_value m concl. -Proof. - rewrite /valid_clause => hcl z eqmin. - rewrite eqmin in hcl. cbn in *. - move: hcl. rewrite /level_value_above. destruct level_value eqn:hl => //. - move/Z.leb_le. constructor. lia. -Qed. - -Lemma valid_clause_intro {m prems concl k} : - (forall z, - min_premise m prems = Some z -> - Some (z + k) ≤ level_value m concl) -> - valid_clause m (prems, (concl, k)). -Proof. - rewrite /valid_clause //=. - destruct min_premise => //. - intros hz. - specialize (hz _ eq_refl). depelim hz. - rewrite /level_value_above H0. - apply Z.leb_le. lia. -Qed. - -Lemma infers_expr_min_atom_value m le : infers_expr m le -> exists k, min_atom_value m le = Some k /\ (0 <= k)%Z. -Proof. - destruct le as [l k]; rewrite /infers_expr //=. - rewrite /infers_atom. destruct level_value => // hle; depelim hle. - eexists; split; trea. lia. -Qed. - -Lemma min_premise_add_infers m prems le lev : - level_value m le.1 = Some lev -> - forall z, min_premise m prems = Some z -> - exists z', min_premise m (add le prems) = Some z' /\ - ((z' = lev - le.2 /\ z' <= z) \/ z' = z). -Proof. - intros hlev z hmin. - have [hle [min' [hin hm]]] := min_premise_spec m (add le prems). - have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. - move/LevelExprSet.add_spec: hin => [heq|hin]. - - noconf heq. destruct le as [le k]. - rewrite /min_atom_value hlev in hm. - eexists; split => //; trea. left. - specialize (hle min''). forward hle. - { rewrite LevelExprSet.add_spec. now right. } - rewrite hm -hm' hmin in hle. now depelim hle. - - exists z. split => //. 2:right; reflexivity. rewrite hm -hmin hm'. - move: (hle' _ hin). rewrite hmin. intros h; depelim h. - rewrite H0 in hm. - specialize (hle min''). forward hle. eapply LevelExprSet.add_spec. now right. - rewrite hm in hle. rewrite -hm' hmin in hle. depelim hle. - rewrite H0 -hm' hmin. f_equal. lia. -Qed. - -Lemma fold_left_map {A B C} (f : B -> A -> A) (g : C -> B) l acc : - fold_left (fun acc l => f (g l) acc) l acc = - fold_left (fun acc l => f l acc) (List.map g l) acc. -Proof. - induction l in acc |- *; cbn; auto. -Qed. - -Lemma fold_left_max_acc {n l} : (forall x, In x l -> x = n) -> n = fold_left (option_map2 Z.min) l n. -Proof. - induction l in n |- *. - - now cbn. - - cbn. intros he. transitivity (option_map2 Z.min n a). 2:apply IHl. - specialize (he a). forward he. now left. subst. destruct n => //= //. lia_f_equal. - intros. have h := (he x). forward h by now right. - have h' := (he a). forward h' by now left. subst. - destruct n => //=; lia_f_equal. -Qed. - -Lemma option_map2_comm x y : option_map2 Z.min x y = option_map2 Z.min y x. -Proof. - destruct x, y; cbn; lia_f_equal. -Qed. - -Lemma option_map2_assoc x y z : - option_map2 Z.min x (option_map2 Z.min y z) = - option_map2 Z.min (option_map2 Z.min x y) z. -Proof. - destruct x, y, z; cbn; lia_f_equal. -Qed. - -Local Notation fn := (fold_left (option_map2 Z.min)). - -Lemma fold_left_impl n l : - (forall x, In x (n :: l) -> fn l n ≤ x) /\ - (exists x, In x (n :: l) /\ fn l n = x). -Proof. - induction l in n |- *. - - cbn. split; intros. - destruct H => //. subst. reflexivity. - exists n. split => //. now left. - - cbn. split; intros. - { destruct (IHl n) as [hle [min [hin heq]]]. - rewrite fold_left_comm. - { now intros; rewrite -option_map2_assoc (option_map2_comm x0 y) option_map2_assoc. } - repeat destruct H; subst. - * specialize (hle n). forward hle. now left. - transitivity (fn l n); auto. eapply Zmin_opt_left. - * eapply Zmin_opt_right. - * transitivity (fn l n); auto. apply Zmin_opt_left. - apply hle. now right. } - * specialize (IHl (option_map2 Z.min n a)). - destruct IHl as [hle [min [hin heq]]]. subst min. eexists. split; trea. - destruct hin. - rewrite -H. - destruct n, a; cbn; firstorder. - destruct (Z.min_spec z z0) as [[? heq]|[? heq]]. - rewrite -{1}heq. now left. right; left. f_equal. lia. - now right. -Qed. - -Lemma fold_left_impl_eq n n' l l' : - (forall x, In x (n :: l) <-> In x (n' :: l' )) -> - fn l n = fn l' n'. -Proof. - intros heq. - destruct (fold_left_impl n l) as [hle [minl [hin heq']]]. - destruct (fold_left_impl n' l') as [hle' [minl' [hin' heq'']]]. - rewrite heq' heq''. - specialize (hle minl'). forward hle. now apply heq. - specialize (hle' minl). forward hle'. now apply heq. - rewrite heq'' in hle'. rewrite heq' in hle. depelim hle'. depelim hle. f_equal; lia. - now depelim hle. -Qed. - -Lemma fold_left_comm_f {A} (f : A -> A -> A) n l : - (forall x y, f x y = f y x) -> - fold_left f l n = fold_left (flip f) l n. -Proof. - induction l in n |- *; cbn; auto. - intros hf. rewrite IHl //. - unfold flip. now rewrite hf. -Qed. - -Lemma min_premise_add {m le prems} : min_premise m (add le prems) = - option_map2 Z.min (min_atom_value m le) (min_premise m prems). -Proof. - rewrite {1}/min_premise. - have hs' := to_nonempty_list_spec (add le prems). - destruct to_nonempty_list. - have eqf : (fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (min_atom_value m p)) = - (option_map2 Z.min (min_atom_value m le) (min_premise m prems)). - 2:{ now rewrite eqf. } - rewrite -(to_nonempty_list_spec' (add le prems)) in hs'. noconf hs'. - rewrite fold_left_map. rewrite fold_left_comm_f. intros [] []; cbn; auto. lia_f_equal. unfold flip. - have l := fold_left_impl_eq (min_atom_value m (to_nonempty_list (add le prems)).1) (min_atom_value m le) - (List.map (min_atom_value m) (to_nonempty_list (add le prems)).2) (List.map (min_atom_value m) (LevelExprSet.elements prems)). - rewrite l. - intros x. - { rewrite -!map_cons to_nonempty_list_spec' !in_map_iff. - split. - - move=> [] lk [] <-. - rewrite -InA_In_eq. - move/LevelExprSet.elements_spec1. - rewrite LevelExprSet.add_spec. - intros [->|inp]. - * exists le. split => //. now left. - * exists lk. split => //. right. now apply InA_In_eq, LevelExprSet.elements_spec1. - - intros [x' [<- hin]]. - exists x'. split => //. rewrite -InA_In_eq. - eapply LevelExprSet.elements_spec1. rewrite LevelExprSet.add_spec. - apply InA_In_eq in hin. depelim hin. now left. - eapply LevelExprSet.elements_spec1 in hin. now right. } - rewrite option_map2_comm. - rewrite /min_premise. - destruct (to_nonempty_list prems) eqn:he. - rewrite fold_left_map. - rewrite (fold_left_comm_f _ _ (List.map _ l0)). intros. apply option_map2_comm. - rewrite -(fold_left_comm (option_map2 Z.min)). - { intros. now rewrite -option_map2_assoc (option_map2_comm x y) option_map2_assoc. } - rewrite -(to_nonempty_list_spec' prems) he; cbn. - now rewrite option_map2_comm. -Qed. - -Lemma min_premise_elim m (P : premises -> option Z -> Prop): - (forall le, P (singleton le) (min_atom_value m le)) -> - (forall prems acc le, P prems acc -> ~ LevelExprSet.In le prems -> P (add le prems) (option_map2 Z.min (min_atom_value m le) acc)) -> - forall prems, P prems (min_premise m prems). -Proof. - intros hs hadd. - eapply premises_elim. - - intros le. rewrite /min_premise. - rewrite singleton_to_nonempty_list. cbn. apply hs. - - intros le prems hp. now rewrite min_premise_add. -Qed. - -Lemma min_premise_add_down {m} {prems : premises} {l k} : - LevelExprSet.In (l, k + 1) prems -> - forall z, min_premise m prems = Some z -> - min_premise m (add (l, k) prems) = Some z. -Proof. - intros ine z hmin. - have [hle [min' [hin hm]]] := min_premise_spec m (add (l, k) prems). - have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. - move/LevelExprSet.add_spec: hin => [heq|hin]. - - noconf heq. - specialize (hle (l, k + 1)). - forward hle. eapply LevelExprSet.add_spec. now right. - rewrite hm in hle. - depelim hle. destruct level_value eqn:hl. noconf H0; noconf H1. lia. congruence. - destruct level_value eqn:hl' => //. - specialize (hle' _ ine). rewrite hmin in hle'; depelim hle'. - now rewrite hl' in H1. - - rewrite hm. specialize (hle' min' hin). rewrite hmin in hle'. - depelim hle'. rewrite H0. f_equal. rewrite H0 in hm. - specialize (hle min''). forward hle. eapply LevelExprSet.add_spec. now right. - rewrite hm in hle. rewrite -hm' hmin in hle. depelim hle. lia. -Qed. - - -Lemma min_premise_singleton m u : min_premise m (singleton u) = min_atom_value m u. -Proof. - now rewrite /min_premise singleton_to_nonempty_list; cbn. -Qed. - -Lemma min_atom_value_add m e x n : - min_atom_value m e = Some x -> - min_atom_value m (add_expr n e) = Some (x - n)%Z. -Proof. - rewrite /min_atom_value. destruct e. cbn. - destruct level_value => //. intros [= <-]. - f_equal. lia. -Qed. - - -Lemma min_atom_value_add_inv m e x n : - min_atom_value m (add_expr n e) = Some x -> - min_atom_value m e = Some (x + n)%Z. -Proof. - rewrite /min_atom_value. destruct e. cbn. - destruct level_value => //. intros [= <-]. - f_equal. lia. -Qed. - -Lemma min_premise_add_prems {m n prems z} : min_premise m prems = Some z -> min_premise m (add_prems n prems) = Some (z - n)%Z. -Proof. - revert z. - eapply min_premise_elim. - - intros le hm. - destruct le as [concl k]. - rewrite add_prems_singleton min_premise_singleton. - apply min_atom_value_add. - - intros prems' acc le ih nle z hm. - destruct acc; cbn in hm. 2:{ destruct (min_atom_value m le); cbn in hm; congruence. } - specialize (ih _ eq_refl). - rewrite add_prems_add min_premise_add. - destruct (min_atom_value m le) eqn:hm'; cbn in hm => //. noconf hm. - apply (min_atom_value_add _ _ _ n) in hm'. - rewrite ih hm'. cbn. f_equal. lia. -Qed. - -Lemma min_premise_add_prems_inv {m n prems z} : min_premise m (add_prems n prems) = Some z -> - min_premise m prems = Some (z + n)%Z. -Proof. - revert z. - pattern prems. - set (P := (fun n0 hm => - forall z : Z, - min_premise m (add_prems n n0) = Some z -> hm = Some (z + n)%Z)). - apply (@min_premise_elim _ P); subst P; cbn. - - intros le z hm. - destruct le as [concl k]. - rewrite add_prems_singleton min_premise_singleton in hm. - now apply min_atom_value_add_inv. - - intros prems' acc le ih nle z. - rewrite add_prems_add min_premise_add. - destruct (min_premise m (add_prems n prems')) eqn:he => //=. - * destruct (min_atom_value m (add_expr n le)) eqn:ha => //=. - intros [= <-]. - eapply min_atom_value_add_inv in ha. rewrite ha. - specialize (ih _ eq_refl). subst acc. cbn. lia_f_equal. - * destruct (min_atom_value m (add_expr n le)) eqn:ha => //=. -Qed. - -Lemma level_value_above_leq {m l k} : - Some k ≤ level_value m l -> - level_value_above m l k. -Proof. - intros h; rewrite /level_value_above. - depelim h. rewrite H0. apply Z.leb_le. lia. -Qed. - -Lemma valid_clause_shift m n cl : - valid_clause m cl -> valid_clause m (add_clause n cl). -Proof. - destruct cl as [prems [concl k]]. - move/valid_clause_elim => hv. - apply valid_clause_intro => z eqmin. - eapply min_premise_add_prems_inv in eqmin. - specialize (hv _ eqmin). - etransitivity; tea. constructor; lia. -Qed. - -Lemma entails_model_valid cls cl : entails cls cl -> - forall m, is_model cls m -> valid_clause m cl. -Proof. - induction 1. - - intros m ism. - destruct concl0 as [concl k]. - apply valid_clause_intro => z hmin. - eapply min_premise_spec_aux in hmin as [hle [x [hin heq]]]. - specialize (hle _ H). depelim hle. - destruct level_value eqn:hl => //. noconf H1. - constructor. lia. - - intros. - specialize (IHentails m H2). - depelim H. - * destruct cl as [premsc conclc]. - noconf H0. - eapply Clauses.for_all_spec in H3. - eapply H3 in H. 2:tc. - destruct concl0 as [concl k]. - eapply valid_clause_intro => z eqmin. - have mins := min_premise_subset m (add_prems n premsc) prems H2. - rewrite eqmin in mins; depelim mins. - destruct conclc as [conclc k']. - have vshift : valid_clause m (add_prems n premsc, add_expr n (conclc, k')). - { now eapply (valid_clause_shift _ n) in H. } - have hv := valid_clause_elim vshift _ H4. - depelim hv. rename y0 into vmconclc. - eapply (min_premise_add_infers _ _ (add_expr n (conclc, k'))) in eqmin as [minadd [eqminadd disj]]; tea. - move/valid_clause_elim: IHentails => //=. - move/(_ _ eqminadd). - destruct disj as [[eq le']| ->]. - + move=> h. cbn in le'. cbn in eq. subst minadd. - depelim h. rewrite H8. constructor. lia. - + intros h; depelim h. rewrite H8; constructor; lia. - * destruct concl0 as [concl0 k']. - apply valid_clause_intro => z hmin. - have mins := min_premise_subset m _ _ H1. - rewrite min_premise_singleton in mins. - specialize (H1 (x, k+1)); forward H1 by now apply LevelExprSet.singleton_spec. - have hadd := min_premise_add_down H1 _ hmin. - exact: valid_clause_elim IHentails _ hadd. + now apply tr. Qed. Lemma check_entails_looping {cls cl v isl} : @@ -1370,16 +253,7 @@ Proof. funelim (check cls cl) => //. Qed. -Lemma enabled_clause_ext {m m' cl} : - m ⩽ m' -> enabled_clause m cl -> enabled_clause m' cl. -Proof. - intros hext; rewrite /enabled_clause. - destruct cl as [prems [concl k]]; cbn; move=> [z hm]. - have pr := min_premise_pres prems hext. - rewrite hm in pr. depelim pr. now exists y. -Qed. - -Lemma check_entails_false {cls cl} : +Theorem check_invalid {cls cl} : check cls cl = Invalid -> ~ entails cls cl. Proof. funelim (check cls cl) => //. @@ -1436,378 +310,6 @@ Proof. Qed. -(* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by - setting a minimal value for the new atoms in [clauses_levels cls \ V] - such that the new clauses [cls] do not hold vacuously. -*) - -Equations add_max (l : Level.t) (k : option Z) (m : model) : model := -add_max l k m with level_value m l := - { | Some k' with check_atom_value k (Some k') := - { | true => m - | false => LevelMap.add l k m } - | None => LevelMap.add l k m }. - -Lemma nleq_optZ k k' : ~ k ≤ Some k' -> exists z, k = Some z /\ k' < z. -Proof. - destruct k. - - exists z. split => //. eapply Znot_ge_lt => hl; apply H. constructor. lia. - - elim. constructor. -Qed. - -Lemma add_max_spec l l' k k' (m : model) : - LevelMap.MapsTo l k (add_max l' k' m) <-> - (l = l' /\ k = max_opt_of Z.max k' (level_value m l)) \/ - (l <> l' /\ LevelMap.MapsTo l k m). -Proof. - funelim (add_max l' k' m). - - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. firstorder; subst. - left. split => //. rewrite Heq. now rewrite max_opt_of_l. - left. firstorder. now rewrite Heq max_opt_of_l. - - clear Heqcall. - destruct (eq_dec l0 l). - * subst l0. rewrite Heq0. - move/check_atom_value_spec: Heq. - rewrite (maps_to_update (level_value_MapsTo' Heq0)). - firstorder; subst; try left; try split; auto; depelim Heq; cbn; lia_f_equal. - * firstorder. - - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. - have := check_atom_value_spec k (Some k'). rewrite {}Heq. - intros h; depelim h. apply nleq_optZ in H as [z [-> hlt]]. - firstorder; subst. - * left; split => //. rewrite Heq0 //=. lia_f_equal. - * left; split => //. rewrite Heq0 //=. lia_f_equal. -Qed. - -Definition min_model_clause cl m := - LevelExprSet.fold (fun '(l, k) acc => add_max l (Some k) acc) (premise cl) - (add_max (concl cl) None m). - -Definition min_model_map (m : model) cls : model := - Clauses.fold min_model_clause cls m. - -Lemma In_add_max l l' k acc : - LevelMap.In l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). -Proof. - rewrite /LevelMap.In. - rw add_max_spec. firstorder subst. - eexists; left; eauto. - destruct (eq_dec l l'); subst; eexists; eauto. -Qed. - -Definition is_max k' k l acc := - match LevelMap.find l acc with - | Some k'' => k' = Nat.max k k'' - | _ => k' = k - end. - -Lemma max_opt_of_spec {x y k'} : max_opt_of Z.max x y = k' -> - (x ≤ y /\ k' = y) \/ (y ≤ x /\ k' = x). -Proof. - destruct x, y; cbn; firstorder subst. - - destruct (Z.max_spec z z0) as [[]|[]]; - [left|right]; split; try constructor; lia_f_equal. - - right. split; constructor. - - left. split; constructor. - - left; split; constructor. -Qed. - -Definition max_of_premises l kl n := - (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ kl). - -Definition is_expr l (e : LevelExpr.t) := - let '(concl, k) := e in concl = l. - -Definition max_of_clause l kl cl := - max_of_premises l kl (premise cl). - -Definition max_of_map l kl m := - (forall kl', LevelMap.MapsTo l kl' m -> kl' ≤ kl). - -Definition is_max_of_clause_and_map l cl m k := - max_of_premises l k (premise cl) /\ max_of_map l k m. - -Definition is_in_premise l k (u : LevelExprSet.t) := - (exists kl, LevelExprSet.In (l, kl) u /\ k = Some kl). - -Definition is_in_clause l k (cl : clause) := - is_in_premise l k (premise cl) \/ (l = (clause_conclusion cl) /\ k = None). - -Definition is_max_of_clause_model l cl m k := - is_max_of_clause_and_map l cl m k /\ - (is_in_clause l k cl \/ LevelMap.MapsTo l k m). - -Definition is_higher l k m := exists k', LevelMap.MapsTo l k' m /\ k ≤ k'. - -Definition is_max_of_clause_map (map : model) l cl (m : model) : Prop := - (forall k, LevelMap.MapsTo l k map -> is_max_of_clause_model l cl m k) - /\ (forall l k, LevelMap.MapsTo l k m \/ is_in_clause l k cl -> is_higher l k map). - - -Lemma max_opt_of_le_l z z' : z ≤ max_opt_of Z.max z z'. -Proof. - destruct z, z'; cbn; constructor; lia. -Qed. - -Lemma max_opt_of_le_r z z' : z' ≤ max_opt_of Z.max z z'. -Proof. - destruct z, z'; cbn; constructor; lia. -Qed. - -Lemma is_higher_le l k l' k' m : is_higher l k m -> is_higher l k (add_max l' k' m). -Proof. - rewrite /is_higher. - rw add_max_spec. - intros [k'0 [hm hle]]. - destruct (eq_dec l l'). - - subst. eexists. split; eauto. rewrite (level_value_MapsTo hm). - transitivity k'0 => //. apply max_opt_of_le_r. - - exists k'0. split; eauto. -Qed. - -Lemma is_higher_add l k m : is_higher l k (add_max l k m). -Proof. - rewrite /is_higher. - rw add_max_spec. eexists. split; eauto. - apply max_opt_of_le_l. -Qed. - -Lemma is_higher_mon l k k' m : is_higher l k' m -> k ≤ k' -> is_higher l k m. -Proof. - intros [? []] le. exists x. split => //. now transitivity k'. -Qed. - -Lemma MapsTo_fold_add_max l n a : - let map := LevelExprSet.fold (fun '(l, k0) acc => add_max l (Some k0) acc) n a in - (forall k, LevelMap.MapsTo l k map -> - ((exists kl, - [/\ LevelExprSet.In (l, kl) n, k = Some kl, - (forall kl', LevelExprSet.In (l, kl') n -> kl' <= kl) & - (forall kl', LevelMap.MapsTo l kl' a -> kl' ≤ Some kl)]) \/ - (LevelMap.MapsTo l k a /\ (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ k)))) - /\ (forall l k, LevelMap.MapsTo l k a \/ is_in_premise l k n -> is_higher l k map) /\ - a ⩽ map. - (* ~ LevelMap.In l map -> ~ (exists k, LevelExprSet.In (l, k) n) /\ ~ (LevelMap.In l a)). *) -Proof. - eapply LevelExprSetProp.fold_rec. - - intros s' he. cbn. - rewrite /is_in_premise /is_higher. - setoid_rewrite (LevelExprSetProp.empty_is_empty_1 he). - intuition auto. right. split; eauto. - intros kl. now move/LevelExprSet.empty_spec. - exists k; split => //. reflexivity. - destruct H0 as [x [hin ->]]. now apply LevelExprSet.empty_spec in hin. - reflexivity. - - cbn; intros. - destruct x as [xl k']. split. - 2:{ split. - { intros l0 hnin. destruct H2 as [hm [H2 _]]. specialize (H2 l0). - intros [ina|ins'']. - { specialize (H2 hnin (or_introl ina)). eapply is_higher_le; tea. } - { destruct ins'' as [x [ins'' ->]]. - apply H1 in ins'' as [[=]|ins']. - * subst. apply is_higher_add. - * apply is_higher_le, H2. right. eexists; eauto. } } - { destruct H2 as [_ [_ H2]]. - intros l' hin. move/H2 => [k'0 [hm hle]]. - rw add_max_spec. destruct (eq_dec l' xl). - - eexists; split. left; eauto. subst l'. - rewrite (level_value_MapsTo hm). transitivity (k'0) => //. - apply max_opt_of_le_r. - - eexists; split; eauto. } } - intros. - rewrite add_max_spec in H3; destruct H3 as [[<- hk]|[hdiff hm]]. - * destruct H2 as [hin hnin]. symmetry in hk. - have [[leacc eqms]|[len eqms]] := max_opt_of_spec hk. - { depelim leacc. specialize (hin _ (level_value_MapsTo' H3)) as [[kl [inkl [= <-] les' lea]]|]. - { left. exists y. split => //. apply H1; now right. congruence. intros. - apply H1 in H4 as [[=]|ins']. 2:now apply les'. subst kl'. lia. } - { destruct H4. right. split. now rewrite -H3 -eqms in H4. intros. - apply H1 in H6 as [[=]|ins']; subst; trea. rewrite H3; cbn; constructor; lia_f_equal. - rewrite H3; cbn; constructor. apply H5 in ins'. depelim ins'. lia. } } - { left. exists k'. split => //. - * apply H1. now left. - * move=> kl' /H1 [[=]|ins']. lia. depelim len. transitivity x; tea. specialize (hin _ (level_value_MapsTo' H3)) as - [[kl [inkl [= <-] les' lea]]|[]]. - { now eapply les'. } - { specialize (H5 _ ins'). depelim H5. lia. } - { move: H2 hk. rewrite /level_value. destruct (find_spec l a0). - * intros ->. apply hin in H2 as [[kl []]|[hm hkl']] => //. apply hkl' in ins'. depelim ins'. - * intros _; cbn; intros <-. - destruct hnin as [hnin _]. - specialize (hnin l (Some kl')); forward hnin. right. - red. exists kl'. split => //. - destruct hnin as [ka [hma hge]]. elim H2. now exists ka. } - * subst k. intros kl' mt. move: len. case: level_valueP => [k ma0 le|]. - specialize (hin _ ma0) as [[kl []]|[hm hkl']] => //. - + subst k. eapply H5 in mt. now depelim le; depelim mt; constructor; lia. - + transitivity k => //. eapply LevelMapFact.F.MapsTo_fun in mt; tea. subst. reflexivity. - + intros hnin' _. destruct hnin as [hnin _]. specialize (hnin l kl'). - forward hnin. now left. destruct hnin as [? [hm ?]]. elim hnin'. now exists x. } - * destruct H2. eapply H2 in hm as [[kl []]|[hm hkl']] => //. - { left. exists kl. split => //. apply H1. now right. intros kl' h. subst k. - apply H6. apply H1 in h. destruct h as [[=]|?] => //. subst. congruence. } - { right. split => //. intros kl' hin. apply H1 in hin as [[=]|?] => //; subst; try congruence. eauto. } -Qed. - -Lemma min_model_clause_spec l cl a : - let map := min_model_clause cl a in - is_max_of_clause_map map l cl a. -Proof. - intros m. rewrite /is_max_of_clause_map /is_max_of_clause_model. - have h := MapsTo_fold_add_max l (premise cl) (add_max (concl cl) None a). - change (LevelExprSet.fold (fun '(l, k0) (acc : model) => add_max l (Some k0) acc) (premise cl) - (add_max (concl cl) None a)) with (min_model_clause cl a) in h. - cbn in h. destruct h. split. - - intros k hm. specialize (H k hm) as [[kl []]|[hm' hle]]. - * split => //. subst k. red. split. intros kl' hin. constructor. now apply H2. - move=> kl' hm''. specialize (H3 kl'). - rewrite add_max_spec in H3. forward H3. - destruct (eq_dec l (concl cl)). - { subst l. left. split => //. rewrite max_opt_of_r. apply level_value_MapsTo in hm''. now rewrite hm''. } - { right. split => //. } - exact H3. left. - red. left. red. subst k. eauto. - * rewrite add_max_spec in hm'. - rewrite max_opt_of_r in hm'. destruct hm' as [[]|[]]; try subst l. - { repeat split => //. - { intros l hin'. subst k. rewrite (level_value_MapsTo hin'). reflexivity. } - { destruct k. right. symmetry in H1. now apply level_value_MapsTo' in H1. - left. red. right. split => //. } } - { split => //. split => //. - { intros l' hin'. eapply LevelMapFact.F.MapsTo_fun in H1; tea. subst. reflexivity. } - firstorder. } - - intros l' k. destruct H0 as [H0 hext]. specialize (H0 l' k). - intros [hm|hinc]. - { forward H0. left. rewrite add_max_spec. - destruct (eq_dec l' (concl cl)); eauto. - { left. split => //. rewrite max_opt_of_r. - now rewrite (level_value_MapsTo hm). } - destruct H0 as [? [hinm hle]]. - eapply is_higher_mon; tea. exists x. split; eauto. reflexivity. } - { red in hinc. destruct hinc. apply H0. now right. - destruct H1 as [-> ->]. - destruct (eq_dec l (concl cl)). - red. - destruct (LevelMap.find (concl cl) a) eqn:hl. - * apply LevelMap.find_2 in hl. - specialize (hext (concl cl) o). - forward hext. rewrite add_max_spec. left. split => //. - rewrite max_opt_of_r. now rewrite (level_value_MapsTo hl). - destruct hext as [k' []]. exists k'. split => //. constructor. - * specialize (hext (concl cl) None). - forward hext. rewrite add_max_spec. left. split => //. - now rewrite /level_value hl. - destruct cl; unfold clause_conclusion in *. exact hext. - * specialize (hext (concl cl) (level_value a (concl cl))). - forward hext. rewrite add_max_spec. left. split => //. - destruct hext as [l' []]; exists l'; split => //. constructor. } -Qed. - -Lemma min_model_map_acc l cls m : - let map := min_model_map m cls in - (forall k, LevelMap.MapsTo l k map -> max_of_map l k m) /\ - m ⩽ map. -Proof. - cbn. rewrite /min_model_map. - eapply ClausesProp.fold_rec. - 2:{ intros. destruct H2 as [hf hin]. - have [hm hnin] := min_model_clause_spec l x a. - split. - intros k. - move/hm. rewrite /is_max_of_clause_model. intros [[ism' ism] hasm]. - destruct hasm; eauto. intros kl'. move/hin => [k' [hmk' lek']]. - red in ism. specialize (ism _ hmk'). now transitivity k'. - transitivity a => //. - intros l' k ha. specialize (hnin l' k (or_introl ha)). - exact hnin. } - split; [|reflexivity]. - intros k hin k' hin'. - eapply LevelMapFact.F.MapsTo_fun in hin; tea. subst; reflexivity. -Qed. - -Lemma max_of_map_ext l k m m' : m ⩽ m' -> max_of_map l k m' -> max_of_map l k m. -Proof. - intros hext hm l'; move/hext => [k' [hm' le]]. - apply hm in hm'. now transitivity k'. -Qed. - -Lemma mapsto_max_of_map l k m : LevelMap.MapsTo l k m -> max_of_map l k m. -Proof. - intros hm l' k'. eapply LevelMapFact.F.MapsTo_fun in hm; tea. - subst; reflexivity. -Qed. - -Lemma min_model_map_spec l cls m : - let map := min_model_map m cls in - (forall k, LevelMap.MapsTo l k map -> - [/\ (exists cl, Clauses.In cl cls /\ is_in_clause l k cl) \/ LevelMap.MapsTo l k m, - (forall cl, Clauses.In cl cls -> max_of_premises l k (premise cl)) & max_of_map l k m]) /\ - (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l map) /\ - m ⩽ map. -Proof. - cbn. - rewrite /min_model_map. - have hgen : forall cls m, (forall k, LevelMap.MapsTo l k (Clauses.fold min_model_clause cls m) -> - [/\ (exists cl : Clauses.elt, Clauses.In cl cls /\ is_in_clause l k cl) \/ - LevelMap.MapsTo l k m, - forall cl : Clauses.elt, Clauses.In cl cls -> max_of_premises l k (premise cl) - & max_of_map l k (Clauses.fold min_model_clause cls m)]) /\ - (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l (Clauses.fold min_model_clause cls m)) /\ - m ⩽ Clauses.fold min_model_clause cls m. - 2:{ specialize (hgen cls m). destruct hgen as [hgen [hcls H]]; split; eauto. - intros k hm. specialize (hgen k hm) as [] => //. - split => //. eapply max_of_map_ext; tea. } - clear. - intros cls m. - eapply ClausesProp.fold_rec. - - intros s' he. split; [ | split; [|reflexivity]]. - * intros k hin. split => //. now right. - intros cl hin'. clsets. now apply mapsto_max_of_map. - * intros cl ins'; clsets. - - intros x a s' s'' hin hnin hadd [ih [ihcls hext]]. split; [|split]; revgoals. - { transitivity a => //. intros l' hin' hm. - have := min_model_clause_spec l' x a. cbn. - intros [_ hm']. specialize (hm' l' hin'). - now forward hm' by eauto. } - { intros cl ins'' l' inlev. - apply hadd in ins'' as [<-|]. - * have := min_model_clause_spec l' x a. cbn. - intros [_ hm']. eapply clause_levels_spec in inlev as []. - + eapply levelexprset_levels_spec in H as [k' incl]. - specialize (hm' l' (Some k')). forward hm'. right. left. rewrite /is_in_premise. exists k'; eauto. - destruct hm' as [? []]; now eexists. - + subst l'. specialize (hm' (concl x) None). forward hm'. - right. right. split => //. - destruct hm' as [? []]; now eexists. - * specialize (ihcls _ H _ inlev) as [k' ina]. - have := min_model_clause_spec l' x a. cbn. - move=> [] _ /(_ l' k' (or_introl ina)). - clear. firstorder. } - intros k. - have := min_model_clause_spec l x a. cbn. - intros [hm hm'] hmk. destruct (hm _ hmk). - split => //. - { destruct H0; eauto. - { left; exists x. split => //. apply hadd. now left. } - { specialize (ih _ H0) as []. destruct H1; eauto. left. - move: H1 => [] w []; exists w; split; eauto. apply hadd. now right. } } - { move=> cl /hadd => [] [<-|hin']. - { now move: H => []. } - { specialize (hm' l k). forward hm' by (destruct H0; eauto). - intros k' h. - specialize (ihcls _ hin' l). - forward ihcls. - { eapply clause_levels_spec. left. eapply levelexprset_levels_spec. now exists k'. } - destruct ihcls as [ka ihcls]. - specialize (ih _ ihcls) as [ihm ihcls' maxm]. - specialize (ihcls' _ hin' _ h). - transitivity ka => //. - destruct H as [mp mmap]. - now apply mmap. } } - { intros kl inma. eapply LevelMapFact.F.MapsTo_fun in hmk; tea. subst. reflexivity. } -Qed. - Equations? infer_extension {V W init cls} (m : valid_model V W init cls) (hincl : only_model_of V init) (hs : clauses_levels cls ⊂_lset V) @@ -1843,27 +345,6 @@ Proof. forward ho by now exists v. now right. Qed. -Lemma only_model_of_min_model_map cls V m : - clauses_levels cls ⊂_lset V -> - only_model_of V m -> only_model_of V (min_model_map m cls). -Proof. - intros incl om l. - split. - - move=> /om => [] [k inm]. - have [hmap [hcls hext]] := min_model_map_spec l cls m. - specialize (hext l k inm). firstorder. - - have [hmap [hcls hext]] := min_model_map_spec l cls m. - move=> [] x /hmap => [] [excl allcl maxm]. - red in maxm. - destruct excl as [[cl [incls incl']]|inm]. - * apply incl. apply clauses_levels_spec. exists cl. split => //. - red in incl'. - apply clause_levels_spec. - clear -incl'. firstorder. subst. left. apply levelexprset_levels_spec. - firstorder. - * rewrite (om l). now exists x. -Qed. - Module CorrectModel. Record t {V cls} := { the_model : model; diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 295696415..6bcf8bdbb 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -345,6 +345,14 @@ Module Clauses (LS : LevelSets). Lemma clauses_empty_eq {s} : Clauses.Empty s -> Clauses.Equal s Clauses.empty. Proof. clsets. Qed. + Lemma clauses_ne_exist cls : ~ Clauses.Empty cls -> exists cl, Clauses.In cl cls. + Proof. + intros ne. + destruct (Clauses.choose cls) eqn:hc. + - exists e. now apply Clauses.choose_spec1 in hc. + - now apply Clauses.choose_spec2 in hc. + Qed. + Lemma clauses_for_all_neg {p s}: ~~ Clauses.for_all p s <-> ~ Clauses.For_all p s. Proof. @@ -762,6 +770,17 @@ Module Clauses (LS : LevelSets). apply (@add_expr_inj n (l, k)) in eq. now noconf eq. Qed. + Lemma inj_add_prems_sub {n u u'} : add_prems n u ⊂_leset add_prems n u' -> u ⊂_leset u'. + Proof. + rewrite /add_prems. + intros hm [l k]. specialize (hm (l, k + n)). + rewrite !map_spec in hm. + intros hin. + forward hm. exists (l, k); split => //. + destruct hm as [[] [hin' eq]]. + apply (@add_expr_inj n (l, k)) in eq. now noconf eq. + Qed. + Lemma add_prems_add_prems n n' lk : add_prems n (add_prems n' lk) = add_prems (n + n') lk. Proof. destruct lk; unfold add_prems. rewrite map_map. apply eq_univ_equal. @@ -880,6 +899,99 @@ Module Clauses (LS : LevelSets). - exists (l, k'); split => //. now rewrite Z.add_0_r. Qed. + Lemma add_clause_singleton n le concl k : add_clause n (singleton le, (concl, k)) = (singleton (add_expr n le), (concl, k + n)). + Proof. + rewrite /add_clause //=. f_equal. + apply eq_univ_equal. intros le'. rewrite In_add_prems. + rewrite_strat (topdown LevelExprSet.singleton_spec). + unfold LevelExprSet.E.eq. firstorder. subst. reflexivity. + Qed. + + Lemma add_prems_singleton n cl : add_prems n (singleton cl) = singleton (add_expr n cl). + Proof. + apply eq_univ_equal => [] [l k]. + rewrite In_add_prems LevelExprSet.singleton_spec. + firstorder. + - destruct x; noconf H0. + eapply LevelExprSet.singleton_spec in H. + now red in H; noconf H. + - destruct cl. exists (t, z). split => //. + red in H; noconf H. now apply LevelExprSet.singleton_spec. + Qed. + + Lemma max_premise_of_spec_aux s l k : + max_premise_of l s = k -> + (forall k', LevelExprSet.In (l, k') s -> (Some k' ≤ k)) /\ + ((exists k', LevelExprSet.In (l, k') s /\ k = Some k') \/ + ((~ exists k', LevelExprSet.In (l, k') s) /\ k = None)). + Proof. + unfold max_premise_of. + revert k. + eapply LevelExprSetProp.fold_rec. + - intros s' he k <-. cbn. split => //. + * now move=> k' /he. + * right; split => //. now move=> [] k' /he. + - intros [l' k'] a s' s'' hin hnin hadd ih k. + specialize (ih _ eq_refl) as [hle hex]. + intros hmax. + split. move=> k'0 /hadd => [] []. + { move=> [=] eq eq'. subst l' k'. rewrite eqb_refl in hmax. + destruct a; cbn in hmax; subst; constructor; lia. } + { move/hle. move: hmax. destruct (eqb_spec l l'); subst. + intros <-. intros h; depelim h; cbn. constructor; lia. + intros -> h; depelim h; constructor; lia. } + destruct hex as [[k'' [hin' heq]]|nex]. subst a. + { left. destruct (eqb_spec l l'). subst. exists (Z.max k' k''); split; trea. + 2:{ subst k. eexists; split => //. apply hadd. now right. } + eapply hadd. + destruct (Z.max_spec k' k'') as [[hlt ->]|[hle' ->]] => //. now right. now left. } + destruct nex as [nex ->]. + destruct (eqb_spec l l'). subst. left. exists k'. split => //. apply hadd; now left. + subst k. right. split => //. + intros [k'' hin']. apply hadd in hin' as []. noconf H0. congruence. + apply nex. now exists k''. + Qed. + + Lemma max_premise_of_prems_max {l prems k} : + max_premise_of l prems = Some k -> LevelExprSet.In (l, k) prems. + Proof. + destruct max_premise_of eqn:maxp => //. intros [= ->]. + apply max_premise_of_spec_aux in maxp as [hle hex]. + destruct hex as [[k' [hin [= ->]]]|hne] => //. + destruct hne; congruence. + Qed. + + Lemma max_premise_of_singleton l k : max_premise_of l (singleton (l, k)) = Some k. + Proof. + remember (max_premise_of l (singleton (l, k))) as mp. symmetry in Heqmp. + apply max_premise_of_spec_aux in Heqmp as [hle hex]. + destruct hex as [[k' [hin heq]]|hne] => //. + eapply LevelExprSet.singleton_spec in hin. now noconf hin. + destruct hne as [nein ->]. elim nein. + exists k. now eapply LevelExprSet.singleton_spec. + Qed. + + Lemma max_premise_of_spec2 l k (u : premises) : LevelExprSet.In (l, k) u -> + exists k', LevelExprSet.In (l, k') u /\ max_premise_of l u = Some k'. + Proof. + remember (max_premise_of l u) as mp. symmetry in Heqmp. + apply max_premise_of_spec_aux in Heqmp as [hle hex]. + intros hin. destruct hex. firstorder. + destruct H as [nein ->]. elim nein. now exists k. + Qed. + + Lemma max_premise_of_spec_in l (u : premises) : LevelSet.In l (levels u) -> + exists k, max_premise_of l u = Some k /\ LevelExprSet.In (l, k) u. + Proof. + intros hexi. + remember (max_premise_of l u) as mp. symmetry in Heqmp. + apply max_premise_of_spec_aux in Heqmp as [hle hex]. + destruct hex. destruct H as [l' [hin heq]]. subst mp. + - eexists; split => //. + - destruct H as [nein ->]. elim nein. + now eapply levelexprset_levels_spec in hexi. + Qed. + Variant in_pred_closure cls : clause -> Prop := | incls cl n : Clauses.In cl cls -> in_pred_closure cls (add_clause n cl) | predcl x k : in_pred_closure cls (singleton (x, k + 1), (x, k)). @@ -1006,14 +1118,32 @@ Module Clauses (LS : LevelSets). constructor. Qed. - Lemma add_clause_singleton n le concl k : add_clause n (singleton le, (concl, k)) = (singleton (add_expr n le), (concl, k + n)). + (* Unused now *) + Definition premises_of_level_set (l : LevelSet.t) := + LevelSet.fold (fun l acc => (l, 0) :: acc) l []. + + Lemma premises_of_level_set_spec l k V : LevelSet.In l V /\ k = 0 <-> In (l, k) (premises_of_level_set V). Proof. - rewrite /add_clause //=. f_equal. - apply eq_univ_equal. intros le'. rewrite In_add_prems. - rewrite_strat (topdown LevelExprSet.singleton_spec). - unfold LevelExprSet.E.eq. firstorder. subst. reflexivity. + rewrite /premises_of_level_set. + eapply LevelSetProp.fold_rec. + - intros s' he. firstorder. + - intros x a s' s'' hin hnin hadd ih. + red in hadd. rewrite {}hadd. + cbn. firstorder. subst. now left. noconf H1. now left. now noconf H1. Qed. + Lemma premises_of_level_set_empty : premises_of_level_set LevelSet.empty = []. + Proof. + now rewrite /premises_of_level_set LevelSetProp.fold_empty. + Qed. + + Lemma in_succ_add_premises {V u x k} : LevelExprSet.In (x, Z.of_nat (k + 1)) (add_list (premises_of_level_set V) u) -> LevelExprSet.In (x, Z.of_nat (k + 1)) u. + Proof. + rewrite add_list_spec. intros [hn|hn] => //. + eapply premises_of_level_set_spec in hn as []. lia. + Qed. + + Lemma entails_shift {cls cl} n : entails cls cl -> entails cls (add_clause n cl). Proof. induction 1. @@ -1361,4 +1491,66 @@ Module Clauses (LS : LevelSets). now constructor. Qed. + Lemma succ_clauses_equiv cls prems concl : + succ_clauses cls ⊢ succ_prems prems → succ_expr concl -> + cls ⊢ prems → concl. + Proof. + intros ha; depind ha. + - constructor. + move: H. + rewrite In_add_prems => [] [le [hin heq]]. + move/add_expr_inj: heq. now intros ->. + - depelim H. + + destruct cl as [prems concl]. noconf H0. + eapply in_add_clauses in H as [[prems' concl'] [hin heq]]. + noconf heq. + eapply (clause_cut _ (add_prems n prems') (add_expr n concl')). 2:eapply IHha. + 2:{ f_equal. rewrite !add_expr_add_expr. now rewrite add_prems_add add_expr_add_expr Z.add_comm. } + exact: (incls cls (prems', concl') n hin). + rewrite add_prems_add_prems in H1. rewrite Z.add_comm in H1. + rewrite -(add_prems_add_prems 1 n prems') in H1. + now move/inj_add_prems_sub: H1. + + specialize (H0 (x, k + 1)). forward H0. now apply LevelExprSet.singleton_spec. + eapply In_add_prems in H0 as [[l' k'] [hin heq]]. noconf heq. + have eq: k' = k by lia. subst k'. clear H. + eapply clause_cut. 2:eapply IHha. eapply (predcl _ x (k - 1)). + 2:{ intros x'. move/LevelExprSet.singleton_spec => ->. now have -> : k - 1 + 1 = k by lia. } + f_equal. rewrite add_prems_add. f_equal. + rewrite /succ_expr //=. lia_f_equal. + Qed. + + Lemma entails_weak_list {cls prem concl concl'} : + cls ⊢ prem → concl -> + cls ⊢ add_list concl' prem → concl. + Proof. + intros hcl. + induction concl' in prem, hcl |- *. + - exact hcl. + - cbn. eapply IHconcl'. now eapply entails_weak. + Qed. + + Lemma entails_all_weak_list {cls prem concl concl'} : + entails_all cls prem concl -> + entails_all cls (add_list concl' prem) concl. + Proof. + intros hcl x hin. + specialize (hcl _ hin). cbn in hcl. + now eapply entails_weak_list. + Qed. + + Lemma entails_all_succ_clauses cls prems concl : + succ_clauses cls ⊢a succ_prems prems → succ_prems concl -> + cls ⊢a prems → concl. + Proof. + intros ha l hin. specialize (ha (succ_expr l)). forward ha. + eapply In_add_prems. exists l. split => //. cbn in ha. + now eapply succ_clauses_equiv in ha. + Qed. + + Definition entails_equiv cls u u' := + cls ⊢a u → u' /\ cls ⊢a u' → u. + + Notation "cls '⊢a' u ↔ u'" := (entails_equiv cls u u') (at level 90). + + End Clauses. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index dc0bf3d7e..6067c3049 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -14,6 +14,8 @@ Module Model (LS : LevelSets). Definition model := LevelMap.t (option Z). Definition equal_model (m m' : model) := LevelMap.Equal m m'. + Definition defined_map (m : LevelMap.t (option Z)) := + exists l k, LevelMap.MapsTo l (Some k) m. Local Open Scope Z_scope. @@ -37,6 +39,21 @@ Module Model (LS : LevelSets). eapply LevelMap.find_2 in hfind. now intros [= ->]. Qed. + Equations check_atom_value (z : option Z) (l : option Z) : bool := + | Some _, None => false + | Some z, Some v => z <=? v + | None, _ => true. + + Lemma check_atom_value_spec z l : reflectProp (z ≤ l) (check_atom_value z l). + Proof. + funelim (check_atom_value z l). + - destruct (Z.leb_spec z v); constructor. + * now constructor. + * intros h; depelim h. lia. + - constructor. intros h; depelim h. + - constructor. constructor. + Qed. + Inductive findSpec l m : option (option Z) -> Prop := | inm k : LevelMap.MapsTo l k m -> findSpec l m (Some k) | ninm : ~ LevelMap.In l m -> findSpec l m None. @@ -160,6 +177,9 @@ Module Model (LS : LevelSets). strictly_updates cls ls' m' m'' -> strictly_updates cls (LevelSet.union ls ls') m m''. + Definition is_update_of cls upd minit m := + if LevelSet.is_empty upd then minit =m m + else strictly_updates cls upd minit m. #[export] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. Proof. @@ -339,6 +359,30 @@ Module Model (LS : LevelSets). destruct Z.leb => //. Qed. + Lemma valid_clause_elim {m prems concl k} : valid_clause m (prems, (concl, k)) -> + forall z, min_premise m prems = Some z -> + Some (z + k) ≤ level_value m concl. + Proof. + rewrite /valid_clause => hcl z eqmin. + rewrite eqmin in hcl. cbn in *. + move: hcl. rewrite /level_value_above. destruct level_value eqn:hl => //. + move/Z.leb_le. constructor. lia. + Qed. + + Lemma valid_clause_intro {m prems concl k} : + (forall z, + min_premise m prems = Some z -> + Some (z + k) ≤ level_value m concl) -> + valid_clause m (prems, (concl, k)). + Proof. + rewrite /valid_clause //=. + destruct min_premise => //. + intros hz. + specialize (hz _ eq_refl). depelim hz. + rewrite /level_value_above H0. + apply Z.leb_le. lia. + Qed. + Lemma check_clause_model_spec {cl w m w' m'} : check_clause_model cl (w, m) = (w', m') -> (w = w' -> m = m' /\ valid_clause m cl) /\ @@ -492,6 +536,42 @@ Module Model (LS : LevelSets). - lsets. Qed. + Lemma is_update_of_non_empty {cls V m m'} : ~ LevelMap.Empty m -> + is_update_of cls V m m' -> + ~ LevelMap.Empty m'. + Proof. + rewrite /is_update_of. destruct LevelSet.is_empty. + - now intros he <-. + - intros he su. now eapply strictly_updates_non_empty_map in su. + Qed. + + Instance defined_map_proper : Proper (LevelMap.Equal ==> iff) defined_map. + Proof. + intros x y eq; rewrite /defined_map. + now setoid_rewrite eq. + Qed. + + Lemma strictly_updates_defined_map {cls W m m'} : + strictly_updates cls W m m' -> defined_map m'. + Proof. + induction 1. + - exists (clause_conclusion cl). + destruct cl as [prems [concl k]]. + destruct H0 as [? [? ? heq]]. cbn. + setoid_rewrite heq. exists (k + x)%Z; cbn. + rewrite LevelMapFact.F.add_mapsto_iff. firstorder. + - assumption. + Qed. + + Lemma is_update_of_defined_map {cls V m m'} : defined_map m -> + is_update_of cls V m m' -> + defined_map m'. + Proof. + rewrite /is_update_of. destruct LevelSet.is_empty. + - now intros he <-. + - intros he su. now eapply strictly_updates_defined_map in su. + Qed. + Lemma check_model_subset {cls v} : forall w' v', check_model cls v = Some (w', v') -> ~ LevelSet.Empty w'. Proof. @@ -624,6 +704,14 @@ Module Model (LS : LevelSets). unfold level_value_above; destruct level_value => // hlt; constructor. lia. Qed. + Lemma level_value_above_leq {m l k} : + Some k ≤ level_value m l -> + level_value_above m l k. + Proof. + intros h; rewrite /level_value_above. + depelim h. rewrite H0. apply Z.leb_le. lia. + Qed. + Lemma strict_update_ext m cl m' : strict_update m cl m' -> m ⩽ m'. Proof. destruct cl as [prems [concl k]]. @@ -747,6 +835,171 @@ Module Model (LS : LevelSets). now rewrite eqs. Qed. + + Lemma min_premise_add_infers m prems le lev : + level_value m le.1 = Some lev -> + forall z, min_premise m prems = Some z -> + exists z', min_premise m (add le prems) = Some z' /\ + ((z' = lev - le.2 /\ z' <= z) \/ z' = z). + Proof. + intros hlev z hmin. + have [hle [min' [hin hm]]] := min_premise_spec m (add le prems). + have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. + move/LevelExprSet.add_spec: hin => [heq|hin]. + - noconf heq. destruct le as [le k]. + rewrite /min_atom_value hlev in hm. + eexists; split => //; trea. left. + specialize (hle min''). forward hle. + { rewrite LevelExprSet.add_spec. now right. } + rewrite hm -hm' hmin in hle. now depelim hle. + - exists z. split => //. 2:right; reflexivity. rewrite hm -hmin hm'. + move: (hle' _ hin). rewrite hmin. intros h; depelim h. + rewrite H0 in hm. + specialize (hle min''). forward hle. eapply LevelExprSet.add_spec. now right. + rewrite hm in hle. rewrite -hm' hmin in hle. depelim hle. + rewrite H0 -hm' hmin. f_equal. lia. + Qed. + + Lemma min_premise_add {m le prems} : min_premise m (add le prems) = + option_map2 Z.min (min_atom_value m le) (min_premise m prems). + Proof. + rewrite {1}/min_premise. + have hs' := to_nonempty_list_spec (add le prems). + destruct to_nonempty_list. + have eqf : (fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (min_atom_value m p)) = + (option_map2 Z.min (min_atom_value m le) (min_premise m prems)). + 2:{ now rewrite eqf. } + rewrite -(to_nonempty_list_spec' (add le prems)) in hs'. noconf hs'. + rewrite fold_left_map. rewrite fold_left_comm_f. intros [] []; cbn; auto. lia_f_equal. unfold flip. + have l := fold_left_impl_eq (min_atom_value m (to_nonempty_list (add le prems)).1) (min_atom_value m le) + (List.map (min_atom_value m) (to_nonempty_list (add le prems)).2) (List.map (min_atom_value m) (LevelExprSet.elements prems)). + rewrite l. + intros x. + { rewrite -!map_cons to_nonempty_list_spec' !in_map_iff. + split. + - move=> [] lk [] <-. + rewrite -InA_In_eq. + move/LevelExprSet.elements_spec1. + rewrite LevelExprSet.add_spec. + intros [->|inp]. + * exists le. split => //. now left. + * exists lk. split => //. right. now apply InA_In_eq, LevelExprSet.elements_spec1. + - intros [x' [<- hin]]. + exists x'. split => //. rewrite -InA_In_eq. + eapply LevelExprSet.elements_spec1. rewrite LevelExprSet.add_spec. + apply InA_In_eq in hin. depelim hin. now left. + eapply LevelExprSet.elements_spec1 in hin. now right. } + rewrite option_map2_comm. + rewrite /min_premise. + destruct (to_nonempty_list prems) eqn:he. + rewrite fold_left_map. + rewrite (fold_left_comm_f _ _ (List.map _ l0)). intros. apply option_map2_comm. + rewrite -(fold_left_comm (option_map2 Z.min)). + { intros. now rewrite -option_map2_assoc (option_map2_comm x y) option_map2_assoc. } + rewrite -(to_nonempty_list_spec' prems) he; cbn. + now rewrite option_map2_comm. + Qed. + + Lemma min_premise_elim m (P : premises -> option Z -> Prop): + (forall le, P (singleton le) (min_atom_value m le)) -> + (forall prems acc le, P prems acc -> ~ LevelExprSet.In le prems -> P (add le prems) (option_map2 Z.min (min_atom_value m le) acc)) -> + forall prems, P prems (min_premise m prems). + Proof. + intros hs hadd. + eapply premises_elim. + - intros le. rewrite /min_premise. + rewrite singleton_to_nonempty_list. cbn. apply hs. + - intros le prems hp. now rewrite min_premise_add. + Qed. + + Lemma min_premise_add_down {m} {prems : premises} {l k} : + LevelExprSet.In (l, k + 1) prems -> + forall z, min_premise m prems = Some z -> + min_premise m (add (l, k) prems) = Some z. + Proof. + intros ine z hmin. + have [hle [min' [hin hm]]] := min_premise_spec m (add (l, k) prems). + have [hle' [min'' [hin' hm']]] := min_premise_spec m prems. + move/LevelExprSet.add_spec: hin => [heq|hin]. + - noconf heq. + specialize (hle (l, k + 1)). + forward hle. eapply LevelExprSet.add_spec. now right. + rewrite hm in hle. + depelim hle. destruct level_value eqn:hl. noconf H0; noconf H1. lia. congruence. + destruct level_value eqn:hl' => //. + specialize (hle' _ ine). rewrite hmin in hle'; depelim hle'. + now rewrite hl' in H1. + - rewrite hm. specialize (hle' min' hin). rewrite hmin in hle'. + depelim hle'. rewrite H0. f_equal. rewrite H0 in hm. + specialize (hle min''). forward hle. eapply LevelExprSet.add_spec. now right. + rewrite hm in hle. rewrite -hm' hmin in hle. depelim hle. lia. + Qed. + + + Lemma min_premise_singleton m u : min_premise m (singleton u) = min_atom_value m u. + Proof. + now rewrite /min_premise singleton_to_nonempty_list; cbn. + Qed. + + Lemma min_atom_value_add m e x n : + min_atom_value m e = Some x -> + min_atom_value m (add_expr n e) = Some (x - n)%Z. + Proof. + rewrite /min_atom_value. destruct e. cbn. + destruct level_value => //. intros [= <-]. + f_equal. lia. + Qed. + + + Lemma min_atom_value_add_inv m e x n : + min_atom_value m (add_expr n e) = Some x -> + min_atom_value m e = Some (x + n)%Z. + Proof. + rewrite /min_atom_value. destruct e. cbn. + destruct level_value => //. intros [= <-]. + f_equal. lia. + Qed. + + Lemma min_premise_add_prems {m n prems z} : min_premise m prems = Some z -> min_premise m (add_prems n prems) = Some (z - n)%Z. + Proof. + revert z. + eapply min_premise_elim. + - intros le hm. + destruct le as [concl k]. + rewrite add_prems_singleton min_premise_singleton. + apply min_atom_value_add. + - intros prems' acc le ih nle z hm. + destruct acc; cbn in hm. 2:{ destruct (min_atom_value m le); cbn in hm; congruence. } + specialize (ih _ eq_refl). + rewrite add_prems_add min_premise_add. + destruct (min_atom_value m le) eqn:hm'; cbn in hm => //. noconf hm. + apply (min_atom_value_add _ _ _ n) in hm'. + rewrite ih hm'. cbn. f_equal. lia. + Qed. + + Lemma min_premise_add_prems_inv {m n prems z} : min_premise m (add_prems n prems) = Some z -> + min_premise m prems = Some (z + n)%Z. + Proof. + revert z. + pattern prems. + set (P := (fun n0 hm => + forall z : Z, + min_premise m (add_prems n n0) = Some z -> hm = Some (z + n)%Z)). + apply (@min_premise_elim _ P); subst P; cbn. + - intros le z hm. + destruct le as [concl k]. + rewrite add_prems_singleton min_premise_singleton in hm. + now apply min_atom_value_add_inv. + - intros prems' acc le ih nle z. + rewrite add_prems_add min_premise_add. + destruct (min_premise m (add_prems n prems')) eqn:he => //=. + * destruct (min_atom_value m (add_expr n le)) eqn:ha => //=. + intros [= <-]. + eapply min_atom_value_add_inv in ha. rewrite ha. + specialize (ih _ eq_refl). subst acc. cbn. lia_f_equal. + * destruct (min_atom_value m (add_expr n le)) eqn:ha => //=. + Qed. + Lemma premise_min_spec_aux s k : premise_min s = k -> (forall x, LevelExprSet.In x s -> (k <= x.2)%Z) /\ @@ -1175,10 +1428,6 @@ Module Model (LS : LevelSets). eapply update_trans; eapply strictly_updates_weaken; tea; clsets. Qed. - Definition is_update_of cls upd minit m := - if LevelSet.is_empty upd then minit =m m - else strictly_updates cls upd minit m. - Lemma check_model_is_update_of {cls cls' U W minit m m'} : is_update_of cls U minit m -> check_model cls' (U, m) = Some (W, m') -> @@ -2203,9 +2452,6 @@ Lemma is_update_of_empty cls m : now eapply model_rel_partial_trans. Qed. - Definition defined_map (m : LevelMap.t (option Z)) := - exists l k, LevelMap.MapsTo l (Some k) m. - #[program] Definition of_level_map (m : LevelMap.t (option Z)) (hne : defined_map m) : premises := {| t_set := LevelMap.fold (fun l k acc => @@ -2265,18 +2511,6 @@ Lemma is_update_of_empty cls m : - intros. rewrite H. firstorder. lesets. Qed. - Lemma strictly_updates_defined_map {cls W m m'} : - strictly_updates cls W m m' -> defined_map m'. - Proof. - induction 1. - - exists (clause_conclusion cl). - destruct cl as [prems [concl k]]. - destruct H0 as [? [? ? heq]]. cbn. - setoid_rewrite heq. exists (k + x)%Z; cbn. - rewrite LevelMapFact.F.add_mapsto_iff. firstorder. - - assumption. - Qed. - Lemma strictly_updates_non_empty_init_map {cls W m m'} : strictly_updates cls W m m' -> ~ LevelMap.Empty m. Proof. @@ -2335,6 +2569,162 @@ Lemma is_update_of_empty cls m : now eapply level_value_MapsTo'. Qed. + Lemma hyps_entails (hyps : premises) m cls : + hyps_map hyps m -> + forall prems conclk, Clauses.In (prems, conclk) cls -> + forall v, min_premise m prems = Some v -> + cls ⊢a hyps → add_prems v prems. + Proof. + intros H prems conclk H0 v H1. + have [minsleq mineq] := min_premise_spec m prems. + destruct mineq as [[minprem minpremk] [inprems eqminp]]. cbn. + have hmz' : forall l k, LevelExprSet.In (l, k) prems -> exists z, Some z ≤ level_value m l. + { intros l k hin. specialize (minsleq _ hin). rewrite H1 in minsleq. cbn in minsleq. destruct level_value => //. + depelim minsleq. exists (v + k)%Z. constructor. lia. depelim minsleq. } + move: eqminp. rewrite /min_atom_value. + destruct level_value eqn:hl. intros hminp. + 2:{ now rewrite H1. } + rewrite H1 in hminp. noconf hminp. + have entails_prems : cls ⊢a hyps → premise_values prems m. + by eapply model_hyps_entails with conclk; auto. + eapply entails_all_trans; tea. + eapply entails_succ. + intros l k. rewrite In_add_prems. + intros [[prem premk] [inprem [= -> ->]]]. + rw premise_values_spec. eexists. + split. exists premk. split => //. + have hmz'' := hmz' prem _ inprem. + depelim hmz''. depelim H2. rewrite H3 //=. + specialize (minsleq _ inprem). cbn in minsleq. rewrite H3 in minsleq. + rewrite H1 in minsleq. depelim minsleq. lia. + Qed. + + Lemma strictly_updates_entails {cls V mzero m} (hne : defined_map mzero) (hne' : defined_map m) : + strictly_updates cls V mzero m -> + entails_all cls (of_level_map mzero hne) (of_level_map m hne'). + Proof. + intros su; induction su. + - destruct cl as [prems [concl k]]. + destruct H0 as [minp [hmin nabove eqm']]. + have [minsleq mineq] := min_premise_spec m prems. + destruct mineq as [minprem [inprems eqminp]]. cbn. + move: eqminp. rewrite /min_atom_value. + move/negbTE/level_value_not_above_spec: nabove => nabove. + destruct minprem as [minprem mink]. + destruct (level_value m minprem) eqn:hminprem; rewrite hmin //; intros [= ->]. + intros [l k'] hin. + eapply of_level_map_spec in hin. rewrite eqm' in hin. + rewrite LevelMapFact.F.add_mapsto_iff in hin. + destruct hin as [[eq heq]|[neq hm]]. noconf heq. + have hypss := of_level_map_spec m hne. + set (hyps := of_level_map m hne) in *. clearbody hyps. + have entailscl : entails cls (prems, (concl, k)) by exact: entails_in H. + move/(entails_shift (z - mink)): entailscl. cbn. move => entailscl. + eapply (entails_all_one (concl := add_prems (z - mink) prems)) => //. + eapply level_value_MapsTo' in hminprem. + rewrite -hypss in hminprem. + eapply hyps_entails; tea. red in eq; subst. exact entailscl. + constructor. now rewrite of_level_map_spec. + - have hnemid : defined_map m'. by exact: strictly_updates_defined_map su1. + specialize (IHsu1 hne hnemid). + specialize (IHsu2 hnemid hne'). + eapply entails_all_trans; tea. + Qed. + + Lemma is_update_of_entails {cls V m m' hne hne'} : is_update_of cls V m m' -> + cls ⊢a of_level_map m hne → of_level_map m' hne'. + Proof. + rewrite /is_update_of. + destruct LevelSet.is_empty. + - intros heq []. + rewrite !of_level_map_spec. rewrite -heq. + constructor. now apply of_level_map_spec. + - eapply strictly_updates_entails. + Qed. + + Local Open Scope Z_scope. + + Lemma infers_atom_of_level_map {cls m hne l k} : + infers_atom m l k -> + cls ⊢ of_level_map m hne → (l, k). + Proof. + rewrite /infers_atom. intros hle. depelim hle. + have [y' eq] : exists y', y = (k + y'). exists (y - k). lia. + eapply (entails_trans (concl := (l, k + y'))). + - constructor. rewrite of_level_map_spec. + eapply level_value_MapsTo'. rewrite H0. f_equal. lia. + - eapply (entails_pred_closure_n (n := Z.to_nat y')). + constructor. eapply LevelExprSet.singleton_spec. + rewrite Z2Nat.id. lia. reflexivity. + Qed. + + (* The criterion for loops: + when a set of updates manages to strictly update all the levels it started with, + then we can deduce a looping constraint `x, ..., z -> x + 1, ... z + 1`. + *) + + Lemma entails_any_one V cls m nem m' nem' : + model_of V m -> + cls ⊢a of_level_map m nem → of_level_map m' nem' -> + model_rel_partial Z.lt V m m' -> + forall l k, LevelSet.In l V -> + LevelMap.MapsTo l (Some k) m -> cls ⊢ of_level_map m nem → (l, k + 1). + Proof. + intros tot cla mp l k hin hm. + eapply entails_all_one; tea. + move: (proj1 (mp l) hin). + move: (tot _ hin) => [x hm']. + move/(_ _ hm) => [k'' [hm'' lt]]. + apply infers_atom_of_level_map. red. rewrite (level_value_MapsTo hm''). + depelim lt. constructor. lia. + Qed. + + Lemma entails_any V cls m nem m' nem' : + only_model_of V m -> + cls ⊢a of_level_map m nem → of_level_map m' nem' -> + model_rel_partial Z.lt V m m' -> + cls ⊢a of_level_map m nem → succ_prems (of_level_map m nem). + Proof. + intros tot cla mp [l k]. + rewrite In_add_prems => [] [[l' k']] [] /of_level_map_spec hm [= ] -> ->. + eapply entails_any_one; tea. exact tot. apply tot. now exists (Some k'). + Qed. + + Lemma strictly_updates_entails_on_V cls V mzero hne m : + only_model_of V mzero -> + strictly_updates cls V mzero m -> + entails_all (cls ↓ V) (of_level_map mzero hne) (succ_prems (of_level_map mzero hne)). + Proof. + move=> tot su. + have mp := strictly_updates_model_lt su tot. + have nem := strictly_updates_defined_map su. + eapply strictly_updates_strenghten in su. + eapply (strictly_updates_entails hne nem) in su; tea. + eapply entails_any in su; tea. + Qed. + + Lemma check_model_defined_init_map {cls V U minit m W m'} : + [/\ clauses_levels cls ⊂_lset V, only_model_of V minit & is_update_of cls U minit m] -> + check_model cls (U, m) = Some (W, m') -> + defined_map minit. + Proof. + intros [_ _ isupd] check. + eapply check_model_is_update_of in check as [su incl]; tea. + rewrite union_idem in su. + now eapply strictly_updates_defined_init_map in su. + Qed. + + Lemma check_model_defined_map {cls U m W m'} : + check_model cls (U, m) = Some (W, m') -> + defined_map m'. + Proof. + intros check. + eapply check_model_spec in check as [W' [su incl]]; tea. + now eapply strictly_updates_defined_map in su. + Qed. + + + Section ModelMaps. Definition premises_model_map (m : model) cls : model := let levels := clauses_premises_levels cls in @@ -2374,6 +2764,37 @@ Lemma is_update_of_empty cls m : rewrite LevelMapFact.F.add_mapsto_iff. right; split => //. Qed. + Lemma zero_model_spec {l ls n} : LevelMap.MapsTo l n (zero_model ls) <-> LevelSet.In l ls /\ n = None. + Proof. + unfold zero_model. + eapply LevelSetProp.fold_rec. + - intros s' he. rewrite LevelMapFact.F.empty_mapsto_iff. firstorder. + - intros x a s s' hin hnin hadd eq. + rewrite LevelMapFact.F.add_mapsto_iff. firstorder. + destruct (Level.eq_dec x l). + * subst. now left. + * right. split => //. apply hadd in H1. destruct H1; try congruence. now apply H0. + Qed. + + + Lemma premises_model_map_min_premise {levels cls prems z} : + min_premise (premises_model_map (zero_model levels) cls) prems = Some z -> + (exists minp mink, LevelExprSet.In (minp, mink) prems /\ + exists maxp, max_clause_premise_of minp cls = Some maxp /\ + z = maxp - mink) \/ + (exists minp mink, LevelExprSet.In (minp, mink) prems /\ z + mink <= 0)%Z. + Proof. + set (m := premises_model_map _ _). + have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m prems. + rewrite mineq. rewrite /min_atom_value. + destruct level_value eqn:hl => //. intros [= <-]. + eapply level_value_MapsTo' in hl. + eapply premises_model_map_spec in hl as [[inpcls [hm _]]|[ninpcls h']]. left. + 2:{ apply zero_model_spec in h' as [h' [= ->]]. } + exists minp, mink. split => //. noconf hm. rewrite -hm. + eexists; split => //. + Qed. + Lemma premises_model_map_in m cls l : LevelMap.In l (premises_model_map m cls) <-> (LevelSet.In l (clauses_premises_levels cls) \/ LevelMap.In l m). Proof. @@ -2385,16 +2806,36 @@ Lemma is_update_of_empty cls m : firstorder. Qed. - Lemma zero_model_spec {l ls n} : LevelMap.MapsTo l n (zero_model ls) <-> LevelSet.In l ls /\ n = None. + Lemma premises_model_map_min_premise_inv {levels cls} : + forall cl, Clauses.In cl cls -> + exists z, min_premise (premises_model_map (zero_model levels) cls) (premise cl) = Some z /\ (0 <= z)%Z. Proof. - unfold zero_model. - eapply LevelSetProp.fold_rec. - - intros s' he. rewrite LevelMapFact.F.empty_mapsto_iff. firstorder. - - intros x a s s' hin hnin hadd eq. - rewrite LevelMapFact.F.add_mapsto_iff. firstorder. - destruct (Level.eq_dec x l). - * subst. now left. - * right. split => //. apply hadd in H1. destruct H1; try congruence. now apply H0. + set (m := premises_model_map _ _). + move=> cl hin. + have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m (premise cl). + rewrite mineq. rewrite /min_atom_value. + destruct level_value eqn:hl => //. + - eexists. split; trea. + have ps := proj1 (premises_model_map_spec _ cls minp (Some z)) (level_value_MapsTo' hl). + destruct ps as [[minpsl [eq _]]|]. + * symmetry in eq. + have sp := (max_clause_premise_of_spec _ _ _ _ hin inminp). + depelim sp. rewrite eq in H0. noconf H0. lia. + * destruct H. elim H. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. + - unfold level_value in hl. + destruct LevelMap.find eqn:hl'. subst o. + 2:{ move/LevelMapFact.F.not_find_in_iff: hl'. elim. + rewrite premises_model_map_in. left. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. } + eapply LevelMap.find_2 in hl'. + move/premises_model_map_spec: hl' => [[]|[nin hm]] => //. + * now intros hnminp [_ hn]. + * move: nin; elim. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. Qed. Lemma in_premises_model V cl : @@ -2416,6 +2857,417 @@ Lemma is_update_of_empty cls m : apply LevelSet.union_spec. left. apply clause_levels_spec. now right. Qed. + Lemma of_level_map_premises_model_map cls cl V ne : + cls ⊢a premise cl → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. + Proof. + intros [l k]. + rewrite of_level_map_spec. move/premises_model_map_spec; cbn. + intros [[hin' [[= heq] _]]|[hnin hm]]. + 2:{ now apply zero_model_spec in hm as []. } + move: hin'; cbn; rewrite LevelSet.union_spec. intros []; [|lsets]. + eapply max_premise_of_spec_in in H as [maxp' [eq hin']]. + rewrite eq in heq; noconf heq. + now constructor. + Qed. + + Lemma entails_all_satisfies {cls prems m hne l k} : + cls ⊢a prems → of_level_map m hne -> + infers_atom m l k -> + cls ⊢ prems → (l, k). + Proof. + intros hl hi. + eapply entails_all_one; tea. now apply infers_atom_of_level_map. + Qed. + + Lemma premises_model_map_ne V cls : + ~ LevelMap.Empty V -> + ~ LevelMap.Empty (premises_model_map V cls). + Proof. + intros ne he. apply ne. + have ne' := premises_model_map_in V cls. + intros l k hin. + specialize (ne' l). destruct ne'. forward H0. right. now exists k. + destruct H0 as [k' hin']. + now move/he: hin'. + Qed. + + Lemma premises_model_map_defined V cls : + ~ Clauses.Empty cls -> + defined_map (premises_model_map V cls). + Proof. + move/clauses_ne_exist => [cl hin]. + destruct cl as [prems concl]. + pose proof (to_nonempty_list_spec' prems). + set (l := (to_nonempty_list prems).1) in *. + have hs := max_clause_premise_of_spec l l.2 cls (prems, concl) hin. + forward hs. cbn. eapply LevelExprSet.elements_spec1; rewrite -H. + constructor. destruct l; reflexivity. depelim hs. + exists l, y. apply premises_model_map_spec. left. + split => //. + eapply clauses_premises_levels_spec. eexists; split; tea => //. + rewrite //= levelexprset_levels_spec. exists l.2. + setoid_rewrite <- LevelExprSet.elements_spec1. rewrite -H //=. + constructor. destruct l; reflexivity. + Qed. + + (* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by + setting a minimal value for the new atoms in [clauses_levels cls \ V] + such that the new clauses [cls] do not hold vacuously. + *) + + Equations add_max (l : Level.t) (k : option Z) (m : model) : model := + add_max l k m with level_value m l := + { | Some k' with check_atom_value k (Some k') := + { | true => m + | false => LevelMap.add l k m } + | None => LevelMap.add l k m }. + + Lemma add_max_spec l l' k k' (m : model) : + LevelMap.MapsTo l k (add_max l' k' m) <-> + (l = l' /\ k = max_opt_of Z.max k' (level_value m l)) \/ + (l <> l' /\ LevelMap.MapsTo l k m). + Proof. + funelim (add_max l' k' m). + - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. firstorder; subst. + left. split => //. rewrite Heq. now rewrite max_opt_of_l. + left. firstorder. now rewrite Heq max_opt_of_l. + - clear Heqcall. + destruct (Level.eq_dec l0 l). + * subst l0. rewrite Heq0. + move/check_atom_value_spec: Heq. + rewrite (maps_to_update (level_value_MapsTo' Heq0)). + firstorder; subst; try left; try split; auto; depelim Heq; cbn; lia_f_equal. + * firstorder. + - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. + have := check_atom_value_spec k (Some k'). rewrite {}Heq. + intros h; depelim h. apply nleq_optZ in H as [z [-> hlt]]. + firstorder; subst. + * left; split => //. rewrite Heq0 //=. lia_f_equal. + * left; split => //. rewrite Heq0 //=. lia_f_equal. + Qed. + + Definition min_model_clause cl m := + LevelExprSet.fold (fun '(l, k) acc => add_max l (Some k) acc) (premise cl) + (add_max (concl cl) None m). + + Definition min_model_map (m : model) cls : model := + Clauses.fold min_model_clause cls m. + + Lemma In_add_max l l' k acc : + LevelMap.In l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). + Proof. + rewrite /LevelMap.In. + rw add_max_spec. firstorder subst. + eexists; left; eauto. + destruct (Level.eq_dec l l'); subst; eexists; eauto. + Qed. + + Definition max_of_premises l kl n := + (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ kl). + + Definition is_expr l (e : LevelExpr.t) := + let '(concl, k) := e in concl = l. + + Definition max_of_clause l kl cl := + max_of_premises l kl (premise cl). + + Definition max_of_map l kl m := + (forall kl', LevelMap.MapsTo l kl' m -> kl' ≤ kl). + + Definition is_max_of_clause_and_map l cl m k := + max_of_premises l k (premise cl) /\ max_of_map l k m. + + Definition is_in_premise l k (u : LevelExprSet.t) := + (exists kl, LevelExprSet.In (l, kl) u /\ k = Some kl). + + Definition is_in_clause l k (cl : clause) := + is_in_premise l k (premise cl) \/ (l = (clause_conclusion cl) /\ k = None). + + Definition is_max_of_clause_model l cl m k := + is_max_of_clause_and_map l cl m k /\ + (is_in_clause l k cl \/ LevelMap.MapsTo l k m). + + Definition is_higher l k m := exists k', LevelMap.MapsTo l k' m /\ k ≤ k'. + + Definition is_max_of_clause_map (map : model) l cl (m : model) : Prop := + (forall k, LevelMap.MapsTo l k map -> is_max_of_clause_model l cl m k) + /\ (forall l k, LevelMap.MapsTo l k m \/ is_in_clause l k cl -> is_higher l k map). + + Lemma is_higher_le l k l' k' m : is_higher l k m -> is_higher l k (add_max l' k' m). + Proof. + rewrite /is_higher. + rw add_max_spec. + intros [k'0 [hm hle]]. + destruct (Level.eq_dec l l'). + - subst. eexists. split; eauto. rewrite (level_value_MapsTo hm). + transitivity k'0 => //. apply max_opt_of_le_r. + - exists k'0. split; eauto. + Qed. + + Lemma is_higher_add l k m : is_higher l k (add_max l k m). + Proof. + rewrite /is_higher. + rw add_max_spec. eexists. split; eauto. + apply max_opt_of_le_l. + Qed. + + Lemma is_higher_mon l k k' m : is_higher l k' m -> k ≤ k' -> is_higher l k m. + Proof. + intros [? []] le. exists x. split => //. now transitivity k'. + Qed. + + Lemma MapsTo_fold_add_max l n a : + let map := LevelExprSet.fold (fun '(l, k0) acc => add_max l (Some k0) acc) n a in + (forall k, LevelMap.MapsTo l k map -> + ((exists kl, + [/\ LevelExprSet.In (l, kl) n, k = Some kl, + (forall kl', LevelExprSet.In (l, kl') n -> kl' <= kl) & + (forall kl', LevelMap.MapsTo l kl' a -> kl' ≤ Some kl)]) \/ + (LevelMap.MapsTo l k a /\ (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ k)))) + /\ (forall l k, LevelMap.MapsTo l k a \/ is_in_premise l k n -> is_higher l k map) /\ + a ⩽ map. + (* ~ LevelMap.In l map -> ~ (exists k, LevelExprSet.In (l, k) n) /\ ~ (LevelMap.In l a)). *) + Proof. + eapply LevelExprSetProp.fold_rec. + - intros s' he. cbn. + rewrite /is_in_premise /is_higher. + setoid_rewrite (LevelExprSetProp.empty_is_empty_1 he). + intuition auto. right. split; eauto. + intros kl. now move/LevelExprSet.empty_spec. + exists k; split => //. reflexivity. + destruct H0 as [x [hin ->]]. now apply LevelExprSet.empty_spec in hin. + reflexivity. + - cbn; intros. + destruct x as [xl k']. split. + 2:{ split. + { intros l0 hnin. destruct H2 as [hm [H2 _]]. specialize (H2 l0). + intros [ina|ins'']. + { specialize (H2 hnin (or_introl ina)). eapply is_higher_le; tea. } + { destruct ins'' as [x [ins'' ->]]. + apply H1 in ins'' as [[= ]|ins']. + * subst. apply is_higher_add. + * apply is_higher_le, H2. right. eexists; eauto. } } + { destruct H2 as [_ [_ H2]]. + intros l' hin. move/H2 => [k'0 [hm hle]]. + rw add_max_spec. destruct (Level.eq_dec l' xl). + - eexists; split. left; eauto. subst l'. + rewrite (level_value_MapsTo hm). transitivity (k'0) => //. + apply max_opt_of_le_r. + - eexists; split; eauto. } } + intros. + rewrite add_max_spec in H3; destruct H3 as [[<- hk]|[hdiff hm]]. + * destruct H2 as [hin hnin]. symmetry in hk. + have [[leacc eqms]|[len eqms]] := max_opt_of_spec hk. + { depelim leacc. specialize (hin _ (level_value_MapsTo' H3)) as [[kl [inkl [= <-] les' lea]]|]. + { left. exists y. split => //. apply H1; now right. congruence. intros. + apply H1 in H4 as [[= ]|ins']. 2:now apply les'. subst kl'. lia. } + { destruct H4. right. split. now rewrite -H3 -eqms in H4. intros. + apply H1 in H6 as [[= ]|ins']; subst; trea. rewrite H3; cbn; constructor; lia_f_equal. + rewrite H3; cbn; constructor. apply H5 in ins'. depelim ins'. lia. } } + { left. exists k'. split => //. + * apply H1. now left. + * move=> kl' /H1 [[= ]|ins']. lia. depelim len. transitivity x; tea. specialize (hin _ (level_value_MapsTo' H3)) as + [[kl [inkl [= <-] les' lea]]|[]]. + { now eapply les'. } + { specialize (H5 _ ins'). depelim H5. lia. } + { move: H2 hk. rewrite /level_value. destruct (find_spec l a0). + * intros ->. apply hin in H2 as [[kl []]|[hm hkl']] => //. apply hkl' in ins'. depelim ins'. + * intros _; cbn; intros <-. + destruct hnin as [hnin _]. + specialize (hnin l (Some kl')); forward hnin. right. + red. exists kl'. split => //. + destruct hnin as [ka [hma hge]]. elim H2. now exists ka. } + * subst k. intros kl' mt. move: len. case: level_valueP => [k ma0 le|]. + specialize (hin _ ma0) as [[kl []]|[hm hkl']] => //. + + subst k. eapply H5 in mt. now depelim le; depelim mt; constructor; lia. + + transitivity k => //. eapply LevelMapFact.F.MapsTo_fun in mt; tea. subst. reflexivity. + + intros hnin' _. destruct hnin as [hnin _]. specialize (hnin l kl'). + forward hnin. now left. destruct hnin as [? [hm ?]]. elim hnin'. now exists x. } + * destruct H2. eapply H2 in hm as [[kl []]|[hm hkl']] => //. + { left. exists kl. split => //. apply H1. now right. intros kl' h. subst k. + apply H6. apply H1 in h. destruct h as [[= ]|?] => //. subst. congruence. } + { right. split => //. intros kl' hin. apply H1 in hin as [[= ]|?] => //; subst; try congruence. eauto. } + Qed. + + Lemma min_model_clause_spec l cl a : + let map := min_model_clause cl a in + is_max_of_clause_map map l cl a. + Proof. + intros m. rewrite /is_max_of_clause_map /is_max_of_clause_model. + have h := MapsTo_fold_add_max l (premise cl) (add_max (concl cl) None a). + change (LevelExprSet.fold (fun '(l, k0) (acc : model) => add_max l (Some k0) acc) (premise cl) + (add_max (concl cl) None a)) with (min_model_clause cl a) in h. + cbn in h. destruct h. split. + - intros k hm. specialize (H k hm) as [[kl []]|[hm' hle]]. + * split => //. subst k. red. split. intros kl' hin. constructor. now apply H2. + move=> kl' hm''. specialize (H3 kl'). + rewrite add_max_spec in H3. forward H3. + destruct (Level.eq_dec l (concl cl)). + { subst l. left. split => //. rewrite max_opt_of_r. apply level_value_MapsTo in hm''. now rewrite hm''. } + { right. split => //. } + exact H3. left. + red. left. red. subst k. eauto. + * rewrite add_max_spec in hm'. + rewrite max_opt_of_r in hm'. destruct hm' as [[]|[]]; try subst l. + { repeat split => //. + { intros l hin'. subst k. rewrite (level_value_MapsTo hin'). reflexivity. } + { destruct k. right. symmetry in H1. now apply level_value_MapsTo' in H1. + left. red. right. split => //. } } + { split => //. split => //. + { intros l' hin'. eapply LevelMapFact.F.MapsTo_fun in H1; tea. subst. reflexivity. } + firstorder. } + - intros l' k. destruct H0 as [H0 hext]. specialize (H0 l' k). + intros [hm|hinc]. + { forward H0. left. rewrite add_max_spec. + destruct (Level.eq_dec l' (concl cl)); eauto. + { left. split => //. rewrite max_opt_of_r. + now rewrite (level_value_MapsTo hm). } + destruct H0 as [? [hinm hle]]. + eapply is_higher_mon; tea. exists x. split; eauto. reflexivity. } + { red in hinc. destruct hinc. apply H0. now right. + destruct H1 as [-> ->]. + destruct (Level.eq_dec l (concl cl)). + red. + destruct (LevelMap.find (concl cl) a) eqn:hl. + * apply LevelMap.find_2 in hl. + specialize (hext (concl cl) o). + forward hext. rewrite add_max_spec. left. split => //. + rewrite max_opt_of_r. now rewrite (level_value_MapsTo hl). + destruct hext as [k' []]. exists k'. split => //. constructor. + * specialize (hext (concl cl) None). + forward hext. rewrite add_max_spec. left. split => //. + now rewrite /level_value hl. + destruct cl; unfold clause_conclusion in *. exact hext. + * specialize (hext (concl cl) (level_value a (concl cl))). + forward hext. rewrite add_max_spec. left. split => //. + destruct hext as [l' []]; exists l'; split => //. constructor. } + Qed. + + Lemma min_model_map_acc l cls m : + let map := min_model_map m cls in + (forall k, LevelMap.MapsTo l k map -> max_of_map l k m) /\ + m ⩽ map. + Proof. + cbn. rewrite /min_model_map. + eapply ClausesProp.fold_rec. + 2:{ intros. destruct H2 as [hf hin]. + have [hm hnin] := min_model_clause_spec l x a. + split. + intros k. + move/hm. rewrite /is_max_of_clause_model. intros [[ism' ism] hasm]. + destruct hasm; eauto. intros kl'. move/hin => [k' [hmk' lek']]. + red in ism. specialize (ism _ hmk'). now transitivity k'. + transitivity a => //. + intros l' k ha. specialize (hnin l' k (or_introl ha)). + exact hnin. } + split; [|reflexivity]. + intros k hin k' hin'. + eapply LevelMapFact.F.MapsTo_fun in hin; tea. subst; reflexivity. + Qed. + + Lemma max_of_map_ext l k m m' : m ⩽ m' -> max_of_map l k m' -> max_of_map l k m. + Proof. + intros hext hm l'; move/hext => [k' [hm' le]]. + apply hm in hm'. now transitivity k'. + Qed. + + Lemma mapsto_max_of_map l k m : LevelMap.MapsTo l k m -> max_of_map l k m. + Proof. + intros hm l' k'. eapply LevelMapFact.F.MapsTo_fun in hm; tea. + subst; reflexivity. + Qed. + + Lemma min_model_map_spec l cls m : + let map := min_model_map m cls in + (forall k, LevelMap.MapsTo l k map -> + [/\ (exists cl, Clauses.In cl cls /\ is_in_clause l k cl) \/ LevelMap.MapsTo l k m, + (forall cl, Clauses.In cl cls -> max_of_premises l k (premise cl)) & max_of_map l k m]) /\ + (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l map) /\ + m ⩽ map. + Proof. + cbn. + rewrite /min_model_map. + have hgen : forall cls m, (forall k, LevelMap.MapsTo l k (Clauses.fold min_model_clause cls m) -> + [/\ (exists cl : Clauses.elt, Clauses.In cl cls /\ is_in_clause l k cl) \/ + LevelMap.MapsTo l k m, + forall cl : Clauses.elt, Clauses.In cl cls -> max_of_premises l k (premise cl) + & max_of_map l k (Clauses.fold min_model_clause cls m)]) /\ + (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l (Clauses.fold min_model_clause cls m)) /\ + m ⩽ Clauses.fold min_model_clause cls m. + 2:{ specialize (hgen cls m). destruct hgen as [hgen [hcls H]]; split; eauto. + intros k hm. specialize (hgen k hm) as [] => //. + split => //. eapply max_of_map_ext; tea. } + clear. + intros cls m. + eapply ClausesProp.fold_rec. + - intros s' he. split; [ | split; [|reflexivity]]. + * intros k hin. split => //. now right. + intros cl hin'. clsets. now apply mapsto_max_of_map. + * intros cl ins'; clsets. + - intros x a s' s'' hin hnin hadd [ih [ihcls hext]]. split; [|split]; revgoals. + { transitivity a => //. intros l' hin' hm. + have := min_model_clause_spec l' x a. cbn. + intros [_ hm']. specialize (hm' l' hin'). + now forward hm' by eauto. } + { intros cl ins'' l' inlev. + apply hadd in ins'' as [<-|]. + * have := min_model_clause_spec l' x a. cbn. + intros [_ hm']. eapply clause_levels_spec in inlev as []. + + eapply levelexprset_levels_spec in H as [k' incl]. + specialize (hm' l' (Some k')). forward hm'. right. left. rewrite /is_in_premise. exists k'; eauto. + destruct hm' as [? []]; now eexists. + + subst l'. specialize (hm' (concl x) None). forward hm'. + right. right. split => //. + destruct hm' as [? []]; now eexists. + * specialize (ihcls _ H _ inlev) as [k' ina]. + have := min_model_clause_spec l' x a. cbn. + move=> [] _ /(_ l' k' (or_introl ina)). + clear. firstorder. } + intros k. + have := min_model_clause_spec l x a. cbn. + intros [hm hm'] hmk. destruct (hm _ hmk). + split => //. + { destruct H0; eauto. + { left; exists x. split => //. apply hadd. now left. } + { specialize (ih _ H0) as []. destruct H1; eauto. left. + move: H1 => [] w []; exists w; split; eauto. apply hadd. now right. } } + { move=> cl /hadd => [] [<-|hin']. + { now move: H => []. } + { specialize (hm' l k). forward hm' by (destruct H0; eauto). + intros k' h. + specialize (ihcls _ hin' l). + forward ihcls. + { eapply clause_levels_spec. left. eapply levelexprset_levels_spec. now exists k'. } + destruct ihcls as [ka ihcls]. + specialize (ih _ ihcls) as [ihm ihcls' maxm]. + specialize (ihcls' _ hin' _ h). + transitivity ka => //. + destruct H as [mp mmap]. + now apply mmap. } } + { intros kl inma. eapply LevelMapFact.F.MapsTo_fun in hmk; tea. subst. reflexivity. } + Qed. + + Lemma only_model_of_min_model_map cls V m : + clauses_levels cls ⊂_lset V -> + only_model_of V m -> only_model_of V (min_model_map m cls). + Proof. + intros incl om l. + split. + - move=> /om => [] [k inm]. + have [hmap [hcls hext]] := min_model_map_spec l cls m. + specialize (hext l k inm). firstorder. + - have [hmap [hcls hext]] := min_model_map_spec l cls m. + move=> [] x /hmap => [] [excl allcl maxm]. + red in maxm. + destruct excl as [[cl [incls incl']]|inm]. + * apply incl. apply clauses_levels_spec. exists cl. split => //. + red in incl'. + apply clause_levels_spec. + clear -incl'. firstorder. subst. left. apply levelexprset_levels_spec. + firstorder. + * rewrite (om l). now exists x. + Qed. + End ModelMaps. @@ -2450,7 +3302,354 @@ Lemma is_update_of_empty cls m : (* Any valuation making all clauses valid in the natural numbers also satisfies the clause cl *) Definition entails_sem (cls : clauses) (cl : clause) := forall V, clauses_sem V cls -> clause_sem V cl. + + Lemma interp_add_expr V n e : interp_expr V (add_expr n e) = n + interp_expr V e. + Proof. + destruct e as [l k]; cbn. lia. + Qed. + + Lemma interp_prems_singleton V e : + interp_prems V (singleton e) = interp_expr V e. + Proof. + rewrite /interp_prems. + now rewrite singleton_to_nonempty_list /=. + Qed. + End Semantics. + Definition enabled_clause (m : model) (cl : clause) := + exists z, min_premise m (premise cl) = Some z. + + Definition enabled_clauses (m : model) (cls : clauses) := + Clauses.For_all (enabled_clause m) cls. + + Definition correct_model (cls : clauses) (m : model) := + enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. + + Lemma enabled_clause_ext {m m' cl} : + m ⩽ m' -> enabled_clause m cl -> enabled_clause m' cl. + Proof. + intros hext; rewrite /enabled_clause. + destruct cl as [prems [concl k]]; cbn; move=> [z hm]. + have pr := min_premise_pres prems hext. + rewrite hm in pr. depelim pr. now exists y. + Qed. + + + Lemma enabled_clauses_ext m m' cls : m ⩽ m' -> enabled_clauses m cls -> enabled_clauses m' cls. + Proof. + intros hext. + rewrite /enabled_clauses. + intros ha cl; move/ha. + now apply enabled_clause_ext. + Qed. + + Lemma interp_prems_ge v (prems : premises) : + forall prem, LevelExprSet.In prem prems -> + interp_expr v prem <= interp_prems v prems. + Proof. + intros. + unfold interp_prems. + have he := to_nonempty_list_spec prems. + destruct to_nonempty_list. + pose proof to_nonempty_list_spec'. + rewrite In_elements in H. rewrite -he in H. clear H0 he. clear -H. + destruct H. subst p. + - induction l. cbn. auto. + cbn. lia. cbn. lia. + - induction l in H |- *. + now cbn in H. + cbn in H. destruct H; subst; cbn. + * cbn. lia. + * specialize (IHl H). lia. + Qed. + + Lemma interp_prems_elements V u : + interp_prems V u = fold_right Z.max (interp_expr V (to_nonempty_list u).1) (List.map (interp_expr V) (to_nonempty_list u).2). + Proof. + rewrite /interp_prems. + have he := to_nonempty_list_spec u. + destruct to_nonempty_list. + now rewrite Universes.fold_right_map. + Qed. + + Lemma fold_right_interp {V x l x' l'} : + equivlistA eq (x :: l) (x' :: l') -> + fold_right Z.max (interp_expr V x) (List.map (interp_expr V) l) = fold_right Z.max (interp_expr V x') (List.map (interp_expr V) l'). + Proof. + intros eq. apply fold_right_equivlist_all. + intros a. rewrite !InA_In_eq. + rewrite !(in_map_iff (interp_expr V) (_ :: _)). + setoid_rewrite <-InA_In_eq. + split. + - move=> [b [<- ]]. + eexists; split; trea. now apply eq in b0. + - move=> [b [<- ]]. + eexists; split; trea. now apply eq in b0. + Qed. + + Lemma equivlistA_add le u : let l := to_nonempty_list (add le u) in + equivlistA eq (l.1 :: l.2) (le :: LevelExprSet.elements u). + Proof. + have he := to_nonempty_list_spec (add le u). + destruct to_nonempty_list. cbn. + intros x. rewrite he. + rewrite !LevelExprSet.elements_spec1. + split. + - move/LevelExprSet.add_spec => [->|hin]. + now constructor. constructor 2. now apply LevelExprSet.elements_spec1. + - intros h; depelim h; subst. now apply LevelExprSet.add_spec; left. + apply LevelExprSet.add_spec. now apply LevelExprSet.elements_spec1 in h. + Qed. + + Lemma interp_prems_add V le (u : premises) : + interp_prems V (add le u) = Z.max (interp_expr V le) (interp_prems V u). + Proof. + rewrite 2!interp_prems_elements. + erewrite fold_right_interp. 2:apply equivlistA_add. + rewrite fold_right_comm. + { apply map_nil, elements_not_empty. } + f_equal. eapply fold_right_equivlist_all. + have he := to_nonempty_list_spec u. + destruct to_nonempty_list. rewrite -he //=. + Qed. + + Lemma interp_prems_elim (P : premises -> Z -> Prop) V : + (forall le, P (singleton le) (interp_expr V le)) -> + (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (add le u) (Z.max (interp_expr V le) k)) -> + forall u, P u (interp_prems V u). + Proof. + intros hs hadd. + eapply premises_elim. + - intros le. rewrite interp_prems_singleton. apply hs. + - intros le prems ih hnin. + rewrite interp_prems_add. now apply hadd. + Qed. + + Local Open Scope Z_scope. + Lemma interp_add_prems V n e : interp_prems V (add_prems n e) = n + interp_prems V e. + Proof. + revert e. + refine (interp_prems_elim (fun u z => interp_prems V (add_prems n u) = n + z) _ _ _). + - intros le. + rewrite add_prems_singleton interp_prems_singleton //=. + destruct le; cbn. lia. + - intros le u k heq hnin. + rewrite add_prems_add. + rewrite interp_prems_add heq interp_add_expr. lia. + Qed. + + Lemma in_pred_closure_entails cls cl : + in_pred_closure cls cl -> + (forall V, clauses_sem V cls -> clause_sem V cl). + Proof. + induction 1. + - intros V. rewrite /clauses_sem. intros ha. + apply ha in H. + move: H; rewrite /clause_sem. + destruct cl as [prems concl]. + cbn. rewrite interp_add_prems. + destruct concl as [concl conclk]. + rewrite /add_expr; cbn. lia. + - intros V clsm. cbn. + rewrite interp_prems_singleton. + cbn. lia. + Qed. + + Lemma interp_prems_in {V le} {u : premises} : LevelExprSet.In le u -> interp_prems V u >= interp_expr V le. + Proof. + revert u. + refine (interp_prems_elim (fun u z => LevelExprSet.In le u -> z >= interp_expr V le) V _ _). + - intros le' u'. + apply LevelExprSet.singleton_spec in u'. red in u'; subst. lia. + - move=> le' u z hz hnin /LevelExprSet.add_spec [->|hin]. lia. + specialize (hz hin). lia. + Qed. + + Lemma clauses_sem_subset {u u' : premises} : u ⊂_leset u' -> + forall V, interp_prems V u' >= interp_prems V u. + Proof. + intros hsub V. + revert u u' hsub. + refine (interp_prems_elim (fun u z => forall u' : premises, u ⊂_leset u' -> interp_prems V u' >= z) V _ _). + - intros le u' hsing. + specialize (hsing le). forward hsing by now apply LevelExprSet.singleton_spec. + now apply interp_prems_in. + - intros le u k ih hin u' sub. + have hle := sub le. + specialize (ih u'). + forward ih. intros x hin'. apply sub. now apply LevelExprSet.add_spec; right. + forward hle by now apply LevelExprSet.add_spec; left. + have hi := interp_prems_in (V := V) hle. lia. + Qed. + + (** Enabled and valid clauses are satisfied by valuation *) + Lemma valid_clause_model model cl : + enabled_clause model cl -> + valid_clause model cl -> + clause_sem (valuation_of_model model) cl. + Proof. + unfold enabled_clause, valid_clause. + destruct min_premise eqn:hmin => //= => //. + 2:{ intros [k' eq]. congruence. } + intros [k' eq]. noconf eq. + destruct cl as [prems [concl k]]; cbn. + unfold level_value_above. + destruct level_value eqn:hl => //. + unfold interp_level. unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. + move/Z.leb_le => hrel. + eapply LevelMap.find_2 in hfind. + have conclm := valuation_of_model_spec _ _ _ hfind. + set (v := (model_max _ - _)) in *. + cbn in conclm. + eapply LevelMap.find_1 in conclm. rewrite conclm. + subst v. + pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. + rewrite hmin in premeq. + eapply Z.le_ge. + eapply Z.le_trans. 2:{ eapply interp_prems_ge; tea. } + unfold interp_expr. destruct prem as [prem k']. + symmetry in premeq. + move: premeq. unfold min_atom_value. + unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. + destruct o => //. + intros [= <-]. + eapply LevelMap.find_2 in findp. + have premm := valuation_of_model_spec _ _ _ findp. + unfold interp_level. + eapply LevelMap.find_1 in premm. rewrite premm. + assert (z1 - k' <= z0 - k). lia. + have hm : z0 <= model_max model. + { eapply model_max_spec in hfind; tea. now depelim hfind. } + have hm' : z1 <= model_max model. + { eapply model_max_spec in findp; tea. now depelim findp. } + have hmi : model_min model <= z0. + { eapply model_min_spec; tea. } + have hmi' : model_min model <= z1. + { eapply model_min_spec; tea. } + assert (0 <= model_max model)%Z by apply model_max_spec2. + assert (model_min model <= 0)%Z by apply model_min_spec2. + lia. + Qed. + + Lemma init_model_enabled cls : enabled_clauses (max_clause_premises cls) cls. + Proof. + unfold enabled_clauses. + intros x hin. unfold enabled_clause. + pose proof (@min_premise_spec (max_clause_premises cls) (premise x)) as [premmin [prem [premin premeq]]]. + have inV : LevelSet.In prem (clauses_levels cls). + { rewrite clauses_levels_spec. exists x; split => //. rewrite /clause_levels. + eapply LevelSet.union_spec; left. rewrite levelexprset_levels_spec. exists prem.2. + destruct prem. exact premin. } + rewrite premeq. unfold min_atom_value. + destruct prem as [l k]. + have hm := max_clause_premises_spec_inv cls l inV. + rewrite (level_value_MapsTo hm). + have hs := max_clause_premise_of_spec l k _ _ hin premin. + depelim hs. rewrite H0. + eexists => //. + Qed. + + Definition valid_entailment cls cl := forall V, clauses_sem V cls -> clause_sem V cl. + Definition invalid_entailment cls cl := + forall V, clauses_sem V cls -> clause_sem V cl -> False. + + Lemma clauses_sem_entails {cls cl} : + entails cls cl -> + valid_entailment cls cl. + Proof. + induction 1. + - intros v clls. red. + destruct concl0 as [concl k]. + have hge := interp_prems_ge v prems _ H. + by lia. + - move=> V Hcls. + move: {IHentails} (IHentails _ Hcls). + unfold clause_sem. unfold ge => hyp. + etransitivity; tea. rewrite interp_prems_add. + rewrite interp_prems_add in hyp. + eapply in_pred_closure_entails in H; tea. + move: H; rewrite /clause_sem. unfold ge. + have ssub := clauses_sem_subset H1 V. lia. + Qed. + + Lemma clauses_sem_entails_all {cls prems concl} : + cls ⊢a prems → concl -> + (forall V, clauses_sem V cls -> interp_prems V prems >= interp_prems V concl). + Proof. + intros ha V hcls. + red in ha. + move: ha. + revert concl. + refine (@interp_prems_elim (fun concl z => _ -> interp_prems V prems >= z) V _ _). + - move=> le //=. move/(_ le). + intros h; forward h by now apply LevelExprSet.singleton_spec. + now have ent := (clauses_sem_entails h _ hcls). + - intros le u k ih hnin. + intros hf. + forward ih. intros x hin; apply (hf x). + rewrite LevelExprSet.add_spec; now right. + specialize (hf le). + forward hf by now apply LevelExprSet.add_spec; left. + cbn in hf. + have ent := (clauses_sem_entails hf _ hcls). cbn in ent. + lia. + Qed. + + Lemma valid_clause_shift m n cl : + valid_clause m cl -> valid_clause m (add_clause n cl). + Proof. + destruct cl as [prems [concl k]]. + move/valid_clause_elim => hv. + apply valid_clause_intro => z eqmin. + eapply min_premise_add_prems_inv in eqmin. + specialize (hv _ eqmin). + etransitivity; tea. constructor; lia. + Qed. + + Lemma entails_model_valid cls cl : entails cls cl -> + forall m, is_model cls m -> valid_clause m cl. + Proof. + induction 1. + - intros m ism. + destruct concl0 as [concl k]. + apply valid_clause_intro => z hmin. + eapply min_premise_spec_aux in hmin as [hle [x [hin heq]]]. + specialize (hle _ H). depelim hle. + destruct level_value eqn:hl => //. noconf H1. + constructor. lia. + - intros. + specialize (IHentails m H2). + depelim H. + * destruct cl as [premsc conclc]. + noconf H0. + eapply Clauses.for_all_spec in H3. + eapply H3 in H. 2:tc. + destruct concl0 as [concl k]. + eapply valid_clause_intro => z eqmin. + have mins := min_premise_subset m (add_prems n premsc) prems H2. + rewrite eqmin in mins; depelim mins. + destruct conclc as [conclc k']. + have vshift : valid_clause m (add_prems n premsc, add_expr n (conclc, k')). + { now eapply (valid_clause_shift _ n) in H. } + have hv := valid_clause_elim vshift _ H4. + depelim hv. rename y0 into vmconclc. + eapply (min_premise_add_infers _ _ (add_expr n (conclc, k'))) in eqmin as [minadd [eqminadd disj]]; tea. + move/valid_clause_elim: IHentails => //=. + move/(_ _ eqminadd). + destruct disj as [[eq le']| ->]. + + move=> h. cbn in le'. cbn in eq. subst minadd. + depelim h. rewrite H8. constructor. lia. + + intros h; depelim h. rewrite H8; constructor; lia. + * destruct concl0 as [concl0 k']. + apply valid_clause_intro => z hmin. + have mins := min_premise_subset m _ _ H1. + rewrite min_premise_singleton in mins. + specialize (H1 (x, k+1)); forward H1 by now apply LevelExprSet.singleton_spec. + have hadd := min_premise_add_down H1 _ hmin. + exact: valid_clause_elim IHentails _ hadd. + Qed. + + End Model. \ No newline at end of file diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index 7836ded67..7e08a32d5 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -591,147 +591,6 @@ Opaque lexprod_rel_wf. Local Open Scope Z_scope. -Lemma hyps_entails (hyps : premises) m cls : - hyps_map hyps m -> - forall prems conclk, Clauses.In (prems, conclk) cls -> - forall v, min_premise m prems = Some v -> - cls ⊢a hyps → add_prems v prems. -Proof. - intros H prems conclk H0 v H1. - have [minsleq mineq] := min_premise_spec m prems. - destruct mineq as [[minprem minpremk] [inprems eqminp]]. cbn. - have hmz' : forall l k, LevelExprSet.In (l, k) prems -> exists z, Some z ≤ level_value m l. - { intros l k hin. specialize (minsleq _ hin). rewrite H1 in minsleq. cbn in minsleq. destruct level_value => //. - depelim minsleq. exists (v + k). constructor. lia. depelim minsleq. } - move: eqminp. rewrite /min_atom_value. - destruct level_value eqn:hl. intros hminp. - 2:{ now rewrite H1. } - rewrite H1 in hminp. noconf hminp. - have entails_prems : cls ⊢a hyps → premise_values prems m. - by eapply model_hyps_entails with conclk; auto. - eapply entails_all_trans; tea. - eapply entails_succ. - intros l k. rewrite In_add_prems. - intros [[prem premk] [inprem [= -> ->]]]. - rw premise_values_spec. eexists. - split. exists premk. split => //. - have hmz'' := hmz' prem _ inprem. - depelim hmz''. depelim H2. rewrite H3 //=. - specialize (minsleq _ inprem). cbn in minsleq. rewrite H3 in minsleq. - rewrite H1 in minsleq. depelim minsleq. lia. -Qed. - -Lemma strictly_updates_entails {cls V mzero m} (hne : defined_map mzero) (hne' : defined_map m) : - strictly_updates cls V mzero m -> - entails_all cls (of_level_map mzero hne) (of_level_map m hne'). -Proof. - intros su; induction su. - - destruct cl as [prems [concl k]]. - destruct H0 as [minp [hmin nabove eqm']]. - have [minsleq mineq] := min_premise_spec m prems. - destruct mineq as [minprem [inprems eqminp]]. cbn. - move: eqminp. rewrite /min_atom_value. - move/negbTE/level_value_not_above_spec: nabove => nabove. - destruct minprem as [minprem mink]. - destruct (level_value m minprem) eqn:hminprem; rewrite hmin //; intros [= ->]. - intros [l k'] hin. - eapply of_level_map_spec in hin. rewrite eqm' in hin. - rewrite LevelMapFact.F.add_mapsto_iff in hin. - destruct hin as [[eq heq]|[neq hm]]. noconf heq. - have hypss := of_level_map_spec m hne. - set (hyps := of_level_map m hne) in *. clearbody hyps. - have entailscl : entails cls (prems, (concl, k)) by exact: entails_in H. - move/(entails_shift (z - mink)): entailscl. cbn. move => entailscl. - eapply (entails_all_one (concl := add_prems (z - mink) prems)) => //. - eapply level_value_MapsTo' in hminprem. - rewrite -hypss in hminprem. - eapply hyps_entails; tea. red in eq; subst. exact entailscl. - constructor. now rewrite of_level_map_spec. - - have hnemid : defined_map m'. by exact: strictly_updates_defined_map su1. - specialize (IHsu1 hne hnemid). - specialize (IHsu2 hnemid hne'). - eapply entails_all_trans; tea. -Qed. - -Lemma infers_atom_of_level_map {cls m hne l k} : - infers_atom m l k -> - cls ⊢ of_level_map m hne → (l, k). -Proof. - rewrite /infers_atom. intros hle. depelim hle. - have [y' eq] : exists y', y = (k + y'). exists (y - k). lia. - eapply (entails_trans (concl := (l, k + y'))). - - constructor. rewrite of_level_map_spec. - eapply level_value_MapsTo'. rewrite H0. f_equal. lia. - - eapply (entails_pred_closure_n (n := Z.to_nat y')). - constructor. eapply LevelExprSet.singleton_spec. - rewrite Z2Nat.id. lia. reflexivity. -Qed. - -(* The criterion for loops: - when a set of updates manages to strictly update all the levels it started with, - then we can deduce a looping constraint `x, ..., z -> x + 1, ... z + 1`. - *) - -Lemma entails_any_one V cls m nem m' nem' : - model_of V m -> - cls ⊢a of_level_map m nem → of_level_map m' nem' -> - model_rel_partial Z.lt V m m' -> - forall l k, LevelSet.In l V -> - LevelMap.MapsTo l (Some k) m -> cls ⊢ of_level_map m nem → (l, k + 1). -Proof. - intros tot cla mp l k hin hm. - eapply entails_all_one; tea. - move: (proj1 (mp l) hin). - move: (tot _ hin) => [x hm']. - move/(_ _ hm) => [k'' [hm'' lt]]. - apply infers_atom_of_level_map. red. rewrite (level_value_MapsTo hm''). - depelim lt. constructor. lia. -Qed. - -Lemma entails_any V cls m nem m' nem' : - only_model_of V m -> - cls ⊢a of_level_map m nem → of_level_map m' nem' -> - model_rel_partial Z.lt V m m' -> - cls ⊢a of_level_map m nem → succ_prems (of_level_map m nem). -Proof. - intros tot cla mp [l k]. - rewrite In_add_prems => [] [[l' k']] [] /of_level_map_spec hm [=] -> ->. - eapply entails_any_one; tea. exact tot. apply tot. now exists (Some k'). -Qed. - -Lemma strictly_updates_entails_on_V cls V mzero hne m : - only_model_of V mzero -> - strictly_updates cls V mzero m -> - entails_all (cls ↓ V) (of_level_map mzero hne) (succ_prems (of_level_map mzero hne)). -Proof. - move=> tot su. - have mp := strictly_updates_model_lt su tot. - have nem := strictly_updates_defined_map su. - eapply strictly_updates_strenghten in su. - eapply (strictly_updates_entails hne nem) in su; tea. - eapply entails_any in su; tea. -Qed. - -Lemma check_model_defined_init_map {cls V U minit m W m'} : - [/\ clauses_levels cls ⊂_lset V, only_model_of V minit & is_update_of cls U minit m] -> - check_model cls (U, m) = Some (W, m') -> - defined_map minit. -Proof. - intros [_ _ isupd] check. - eapply check_model_is_update_of in check as [su incl]; tea. - rewrite union_idem in su. - now eapply strictly_updates_defined_init_map in su. -Qed. - -Lemma check_model_defined_map {cls U m W m'} : - check_model cls (U, m) = Some (W, m') -> - defined_map m'. -Proof. - intros check. - eapply check_model_spec in check as [W' [su incl]]; tea. - now eapply strictly_updates_defined_map in su. -Qed. - #[tactic="idtac"] Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : model) (prf : [/\ clauses_levels cls ⊂_lset V, only_model_of V minit & is_update_of cls U minit m]) : result V U cls minit From 1e72657e1e568ac19457570148e42b5c5e33f7b8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 11 Sep 2025 11:08:07 +0200 Subject: [PATCH 041/164] Fix notation issues --- common/theories/LoopChecking/HornClauses.v | 11 ++--- common/theories/LoopChecking/Interfaces.v | 56 +++++++++++----------- common/theories/LoopChecking/Model.v | 16 +++---- 3 files changed, 42 insertions(+), 41 deletions(-) diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 6bcf8bdbb..8d578cf1b 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -1012,6 +1012,11 @@ Module Clauses (LS : LevelSets). Notation " cls ⊢ prems → concl " := (entails cls (prems, concl)) (at level 20). Notation " cls ⊢a prems → concl " := (entails_all cls prems concl) (at level 20). + Definition entails_equiv cls u u' := + cls ⊢a u → u' /\ cls ⊢a u' → u. + + Notation "cls '⊢a' u ↔ u'" := (entails_equiv cls u u') (at level 20). + Lemma in_pred_closure_equal cls (prems prems' : premises) concl : LevelExprSet.Equal prems prems' -> in_pred_closure cls (prems, concl) -> in_pred_closure cls (prems', concl). @@ -1547,10 +1552,4 @@ Module Clauses (LS : LevelSets). now eapply succ_clauses_equiv in ha. Qed. - Definition entails_equiv cls u u' := - cls ⊢a u → u' /\ cls ⊢a u' → u. - - Notation "cls '⊢a' u ↔ u'" := (entails_equiv cls u u') (at level 90). - - End Clauses. diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 3e669c654..9b160cba9 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -75,38 +75,44 @@ End LevelExprSet_fun. Module Type LevelSets. (* Signature of levels: decidable, ordered type *) - Declare Module Import Level : LevelOrderedType. - Declare Module Import LevelSet : LevelSet_fun Level. - Declare Module Import LevelExpr : LevelExprItf Level. - Declare Module Import LevelExprSet : LevelExprSet_fun Level LevelExpr. - Declare Module Import LevelMap : FMapOTInterface Level. + Declare Module Level : LevelOrderedType. + Declare Module LevelSet : LevelSet_fun Level. + Declare Module LevelExpr : LevelExprItf Level. + Declare Module LevelExprSet : LevelExprSet_fun Level LevelExpr. + Declare Module LevelMap : FMapOTInterface Level. End LevelSets. Module FromLevelSets (LS : LevelSets). - Export LS. +Export LS. - Definition level (e : LevelExpr.t) : Level.t := fst e. - Coercion level : LevelExpr.t >-> Level.t. - Extraction Inline level. +Definition level (e : LevelExpr.t) : Level.t := fst e. +Coercion level : LevelExpr.t >-> Level.t. +Extraction Inline level. - Definition levels (e : LevelExprSet.t) := - LevelExprSet.fold (fun le => LevelSet.add (level le)) e LevelSet.empty. - Export LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). +Definition levels (e : LevelExprSet.t) := +LevelExprSet.fold (fun le => LevelSet.add (level le)) e LevelSet.empty. +Export LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). - Existing Instance Level.reflect_eq. +Existing Instance Level.reflect_eq. - Module LevelSetFact := WFactsOn Level LevelSet. - Module LevelSetProp := WPropertiesOn Level LevelSet. - Module LevelSetDecide := LevelSetProp.Dec. - Module LevelMapFact := FMapFacts.WProperties_fun LevelMap.OT LevelMap. +Module LevelSetFact := WFactsOn Level LevelSet. +Module LevelSetProp := WPropertiesOn Level LevelSet. +Module LevelSetDecide := LevelSetProp.Dec. +Module LevelMapFact := FMapFacts.WProperties_fun LevelMap.OT LevelMap. - Ltac lsets := LevelSetDecide.fsetdec. - Notation "(=_lset)" := LevelSet.Equal (at level 0). - Infix "=_lset" := LevelSet.Equal (at level 30). - Infix "⊂_lset" := LevelSet.Subset (at level 70). - Infix "∪" := LevelSet.union (at level 70). +Declare Scope levels_scope. +Ltac lsets := LevelSetDecide.fsetdec. +Notation "(=_lset)" := LevelSet.Equal (at level 0) : levels_scope. +Infix "=_lset" := LevelSet.Equal (at level 30) : levels_scope. +Infix "⊂_lset" := LevelSet.Subset (at level 70) : levels_scope. +Infix "⊂_leset" := LevelExprSet.Subset (at level 70) : levels_scope. +Infix "∪" := LevelSet.union (at level 70) : levels_scope. +Infix "=m" := LevelMap.Equal (at level 50) : levels_scope. +Notation "#| V |" := (LevelSet.cardinal V) : levels_scope. + +Open Scope levels_scope. Definition print_level_nat_map (m : LevelMap.t nat) := let list := LevelMap.elements m in @@ -151,7 +157,6 @@ Qed. Coercion t_set : nonEmptyLevelExprSet >-> LevelExprSet.t. Module LevelExprSetDecide := WDecide (LevelExprSet). Ltac lesets := LevelExprSetDecide.fsetdec. -Infix "⊂_leset" := LevelExprSet.Subset (at level 70). Lemma levelset_not_Empty_is_empty s : LevelSet.is_empty s = false <-> ~ LevelSet.Empty s. @@ -173,8 +178,6 @@ Proof. rewrite LevelSet.union_spec. firstorder. Qed. -Infix "=m" := LevelMap.Equal (at level 50). - Lemma levelmap_add_spec {A} (m m' : LevelMap.t A) {k v}: LevelMapFact.Add k v m m' -> m' =m LevelMap.add k v m. @@ -652,8 +655,6 @@ Proof. apply H0. lsets. Qed. -Notation "#| V |" := (LevelSet.cardinal V). - Lemma diff_cardinal_inter V W : #|LevelSet.diff V W| = #|V| - #|LevelSet.inter V W|. Proof. pose proof (LevelSetProp.diff_inter_cardinal V W). lia. @@ -664,4 +665,5 @@ Proof. intros hsub. rewrite diff_cardinal_inter LevelSetProp.inter_sym LevelSetProp.inter_subset_equal //. Qed. + End FromLevelSets. \ No newline at end of file diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 6067c3049..f78f3a1a9 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -1082,7 +1082,7 @@ Module Model (LS : LevelSets). lia. Qed. - Import LevelExprSet. + Import -(notations) LevelExprSet. Import NonEmptySetFacts. Definition max_premise_value (m : model) (l : premises) : option Z := @@ -2686,7 +2686,7 @@ Lemma is_update_of_empty cls m : cls ⊢a of_level_map m nem → succ_prems (of_level_map m nem). Proof. intros tot cla mp [l k]. - rewrite In_add_prems => [] [[l' k']] [] /of_level_map_spec hm [= ] -> ->. + rewrite In_add_prems => [] [[l' k']] [] /of_level_map_spec hm [=] -> ->. eapply entails_any_one; tea. exact tot. apply tot. now exists (Some k'). Qed. @@ -3044,7 +3044,7 @@ Lemma is_update_of_empty cls m : intros [ina|ins'']. { specialize (H2 hnin (or_introl ina)). eapply is_higher_le; tea. } { destruct ins'' as [x [ins'' ->]]. - apply H1 in ins'' as [[= ]|ins']. + apply H1 in ins'' as [[=]|ins']. * subst. apply is_higher_add. * apply is_higher_le, H2. right. eexists; eauto. } } { destruct H2 as [_ [_ H2]]. @@ -3060,13 +3060,13 @@ Lemma is_update_of_empty cls m : have [[leacc eqms]|[len eqms]] := max_opt_of_spec hk. { depelim leacc. specialize (hin _ (level_value_MapsTo' H3)) as [[kl [inkl [= <-] les' lea]]|]. { left. exists y. split => //. apply H1; now right. congruence. intros. - apply H1 in H4 as [[= ]|ins']. 2:now apply les'. subst kl'. lia. } + apply H1 in H4 as [[=]|ins']. 2:now apply les'. subst kl'. lia. } { destruct H4. right. split. now rewrite -H3 -eqms in H4. intros. - apply H1 in H6 as [[= ]|ins']; subst; trea. rewrite H3; cbn; constructor; lia_f_equal. + apply H1 in H6 as [[=]|ins']; subst; trea. rewrite H3; cbn; constructor; lia_f_equal. rewrite H3; cbn; constructor. apply H5 in ins'. depelim ins'. lia. } } { left. exists k'. split => //. * apply H1. now left. - * move=> kl' /H1 [[= ]|ins']. lia. depelim len. transitivity x; tea. specialize (hin _ (level_value_MapsTo' H3)) as + * move=> kl' /H1 [[=]|ins']. lia. depelim len. transitivity x; tea. specialize (hin _ (level_value_MapsTo' H3)) as [[kl [inkl [= <-] les' lea]]|[]]. { now eapply les'. } { specialize (H5 _ ins'). depelim H5. lia. } @@ -3085,8 +3085,8 @@ Lemma is_update_of_empty cls m : forward hnin. now left. destruct hnin as [? [hm ?]]. elim hnin'. now exists x. } * destruct H2. eapply H2 in hm as [[kl []]|[hm hkl']] => //. { left. exists kl. split => //. apply H1. now right. intros kl' h. subst k. - apply H6. apply H1 in h. destruct h as [[= ]|?] => //. subst. congruence. } - { right. split => //. intros kl' hin. apply H1 in hin as [[= ]|?] => //; subst; try congruence. eauto. } + apply H6. apply H1 in h. destruct h as [[=]|?] => //. subst. congruence. } + { right. split => //. intros kl' hin. apply H1 in hin as [[=]|?] => //; subst; try congruence. eauto. } Qed. Lemma min_model_clause_spec l cl a : From 237097a1139b563e1bd910f0867595db18a9e852 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 11 Sep 2025 11:28:40 +0200 Subject: [PATCH 042/164] Move model instances out of Model.v --- common/_RocqProject.in | 1 + common/theories/LoopChecking/Deciders.v | 3 +- common/theories/LoopChecking/Model.v | 552 +---------------- common/theories/LoopChecking/Models.v | 562 ++++++++++++++++++ .../LoopChecking/PartialLoopChecking.v | 9 +- 5 files changed, 571 insertions(+), 556 deletions(-) create mode 100644 common/theories/LoopChecking/Models.v diff --git a/common/_RocqProject.in b/common/_RocqProject.in index 05ae0e787..dcd1ed6e2 100644 --- a/common/_RocqProject.in +++ b/common/_RocqProject.in @@ -19,5 +19,6 @@ theories/LoopChecking/Common.v theories/LoopChecking/Interfaces.v theories/LoopChecking/HornClauses.v theories/LoopChecking/Model.v +theories/LoopChecking/Models.v theories/LoopChecking/PartialLoopChecking.v theories/LoopChecking/Deciders.v \ No newline at end of file diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 4dcb09c05..e2dd67aa2 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -7,7 +7,7 @@ From MetaRocq.Utils Require Import utils. From MetaRocq.Common Require Universes. From Equations Require Import Equations. -From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model PartialLoopChecking. +From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model Models PartialLoopChecking. Set Equations Transparent. @@ -52,7 +52,6 @@ Module Deciders (LS : LevelSets). Module Import I := LoopCheckingImpl LS. Import LS. - Local Open Scope Z_scope. Definition init_model cls := max_clause_premises cls. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index f78f3a1a9..13e1838f3 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -2723,554 +2723,6 @@ Lemma is_update_of_empty cls m : now eapply strictly_updates_defined_map in su. Qed. - - - Section ModelMaps. - Definition premises_model_map (m : model) cls : model := - let levels := clauses_premises_levels cls in - LevelSet.fold (fun l acc => - LevelMap.add l (max_clause_premise_of l cls) acc) levels m. - - Definition zero_model levels : model := - LevelSet.fold (fun l acc => LevelMap.add l None acc) levels (LevelMap.empty _). - - Definition premises_model V cl : LevelSet.t * model := - let levels := LevelSet.union (clause_levels cl) V in - (levels, premises_model_map (zero_model levels) (Clauses.singleton cl)). - - Lemma premises_model_map_spec m cls : - forall l k, - LevelMap.MapsTo l k (premises_model_map m cls) <-> - ((LevelSet.In l (clauses_premises_levels cls) /\ k = max_clause_premise_of l cls /\ isSome k) \/ - (~ LevelSet.In l (clauses_premises_levels cls) /\ LevelMap.MapsTo l k m)). - Proof. - intros l k; rewrite /premises_model_map. - eapply LevelSetProp.fold_rec. - - intros s' he. split. intros hm. right. split => //. - firstorder. - - intros x a s' s'' hin hnin hadd ih. - split. - * rewrite LevelMapFact.F.add_mapsto_iff. - firstorder. subst k. red in H; subst. firstorder. - left; firstorder. - apply clauses_premises_levels_spec in hin as [cl [incl inlev]]. - apply levelexprset_levels_spec in inlev as [k inprem]. - have hs := max_clause_premise_of_spec l k cls cl incl inprem. - depelim hs. now rewrite H3. - * intros [[hin' [-> iss]]|]. - rewrite LevelMapFact.F.add_mapsto_iff. - destruct (Level.eq_dec x l); subst; firstorder. - destruct (Level.eq_dec x l); subst; firstorder. - rewrite LevelMapFact.F.add_mapsto_iff. right; split => //. - Qed. - - Lemma zero_model_spec {l ls n} : LevelMap.MapsTo l n (zero_model ls) <-> LevelSet.In l ls /\ n = None. - Proof. - unfold zero_model. - eapply LevelSetProp.fold_rec. - - intros s' he. rewrite LevelMapFact.F.empty_mapsto_iff. firstorder. - - intros x a s s' hin hnin hadd eq. - rewrite LevelMapFact.F.add_mapsto_iff. firstorder. - destruct (Level.eq_dec x l). - * subst. now left. - * right. split => //. apply hadd in H1. destruct H1; try congruence. now apply H0. - Qed. - - - Lemma premises_model_map_min_premise {levels cls prems z} : - min_premise (premises_model_map (zero_model levels) cls) prems = Some z -> - (exists minp mink, LevelExprSet.In (minp, mink) prems /\ - exists maxp, max_clause_premise_of minp cls = Some maxp /\ - z = maxp - mink) \/ - (exists minp mink, LevelExprSet.In (minp, mink) prems /\ z + mink <= 0)%Z. - Proof. - set (m := premises_model_map _ _). - have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m prems. - rewrite mineq. rewrite /min_atom_value. - destruct level_value eqn:hl => //. intros [= <-]. - eapply level_value_MapsTo' in hl. - eapply premises_model_map_spec in hl as [[inpcls [hm _]]|[ninpcls h']]. left. - 2:{ apply zero_model_spec in h' as [h' [= ->]]. } - exists minp, mink. split => //. noconf hm. rewrite -hm. - eexists; split => //. - Qed. - - Lemma premises_model_map_in m cls l : - LevelMap.In l (premises_model_map m cls) <-> (LevelSet.In l (clauses_premises_levels cls) \/ LevelMap.In l m). - Proof. - rewrite /premises_model_map. - eapply LevelSetProp.fold_rec. - - intros s' he. firstorder. - - intros x a s' s'' hin hnin hadd ih. - rewrite LevelMapFact.F.add_in_iff. - firstorder. - Qed. - - Lemma premises_model_map_min_premise_inv {levels cls} : - forall cl, Clauses.In cl cls -> - exists z, min_premise (premises_model_map (zero_model levels) cls) (premise cl) = Some z /\ (0 <= z)%Z. - Proof. - set (m := premises_model_map _ _). - move=> cl hin. - have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m (premise cl). - rewrite mineq. rewrite /min_atom_value. - destruct level_value eqn:hl => //. - - eexists. split; trea. - have ps := proj1 (premises_model_map_spec _ cls minp (Some z)) (level_value_MapsTo' hl). - destruct ps as [[minpsl [eq _]]|]. - * symmetry in eq. - have sp := (max_clause_premise_of_spec _ _ _ _ hin inminp). - depelim sp. rewrite eq in H0. noconf H0. lia. - * destruct H. elim H. - eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. - - unfold level_value in hl. - destruct LevelMap.find eqn:hl'. subst o. - 2:{ move/LevelMapFact.F.not_find_in_iff: hl'. elim. - rewrite premises_model_map_in. left. - eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. } - eapply LevelMap.find_2 in hl'. - move/premises_model_map_spec: hl' => [[]|[nin hm]] => //. - * now intros hnminp [_ hn]. - * move: nin; elim. - eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. - Qed. - - Lemma in_premises_model V cl : - forall l, - LevelMap.In l (premises_model V cl).2 <-> - LevelSet.In l V \/ LevelSet.In l (clause_levels cl). - Proof. - intros l. rewrite premises_model_map_in. - rewrite clauses_premises_levels_spec. - firstorder. - - right. apply Clauses.singleton_spec in H. - apply clause_levels_spec. left. now subst. - - apply zero_model_spec in H as [hin ->]. - apply LevelSet.union_spec in hin. firstorder. - - right. exists None. apply zero_model_spec. split => //; lsets. - - eapply clause_levels_spec in H as [H|H]. - * left. exists cl. split => //. now apply Clauses.singleton_spec. - * subst. right. exists None. apply zero_model_spec. split => //. - apply LevelSet.union_spec. left. apply clause_levels_spec. now right. - Qed. - - Lemma of_level_map_premises_model_map cls cl V ne : - cls ⊢a premise cl → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. - Proof. - intros [l k]. - rewrite of_level_map_spec. move/premises_model_map_spec; cbn. - intros [[hin' [[= heq] _]]|[hnin hm]]. - 2:{ now apply zero_model_spec in hm as []. } - move: hin'; cbn; rewrite LevelSet.union_spec. intros []; [|lsets]. - eapply max_premise_of_spec_in in H as [maxp' [eq hin']]. - rewrite eq in heq; noconf heq. - now constructor. - Qed. - - Lemma entails_all_satisfies {cls prems m hne l k} : - cls ⊢a prems → of_level_map m hne -> - infers_atom m l k -> - cls ⊢ prems → (l, k). - Proof. - intros hl hi. - eapply entails_all_one; tea. now apply infers_atom_of_level_map. - Qed. - - Lemma premises_model_map_ne V cls : - ~ LevelMap.Empty V -> - ~ LevelMap.Empty (premises_model_map V cls). - Proof. - intros ne he. apply ne. - have ne' := premises_model_map_in V cls. - intros l k hin. - specialize (ne' l). destruct ne'. forward H0. right. now exists k. - destruct H0 as [k' hin']. - now move/he: hin'. - Qed. - - Lemma premises_model_map_defined V cls : - ~ Clauses.Empty cls -> - defined_map (premises_model_map V cls). - Proof. - move/clauses_ne_exist => [cl hin]. - destruct cl as [prems concl]. - pose proof (to_nonempty_list_spec' prems). - set (l := (to_nonempty_list prems).1) in *. - have hs := max_clause_premise_of_spec l l.2 cls (prems, concl) hin. - forward hs. cbn. eapply LevelExprSet.elements_spec1; rewrite -H. - constructor. destruct l; reflexivity. depelim hs. - exists l, y. apply premises_model_map_spec. left. - split => //. - eapply clauses_premises_levels_spec. eexists; split; tea => //. - rewrite //= levelexprset_levels_spec. exists l.2. - setoid_rewrite <- LevelExprSet.elements_spec1. rewrite -H //=. - constructor. destruct l; reflexivity. - Qed. - - (* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by - setting a minimal value for the new atoms in [clauses_levels cls \ V] - such that the new clauses [cls] do not hold vacuously. - *) - - Equations add_max (l : Level.t) (k : option Z) (m : model) : model := - add_max l k m with level_value m l := - { | Some k' with check_atom_value k (Some k') := - { | true => m - | false => LevelMap.add l k m } - | None => LevelMap.add l k m }. - - Lemma add_max_spec l l' k k' (m : model) : - LevelMap.MapsTo l k (add_max l' k' m) <-> - (l = l' /\ k = max_opt_of Z.max k' (level_value m l)) \/ - (l <> l' /\ LevelMap.MapsTo l k m). - Proof. - funelim (add_max l' k' m). - - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. firstorder; subst. - left. split => //. rewrite Heq. now rewrite max_opt_of_l. - left. firstorder. now rewrite Heq max_opt_of_l. - - clear Heqcall. - destruct (Level.eq_dec l0 l). - * subst l0. rewrite Heq0. - move/check_atom_value_spec: Heq. - rewrite (maps_to_update (level_value_MapsTo' Heq0)). - firstorder; subst; try left; try split; auto; depelim Heq; cbn; lia_f_equal. - * firstorder. - - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. - have := check_atom_value_spec k (Some k'). rewrite {}Heq. - intros h; depelim h. apply nleq_optZ in H as [z [-> hlt]]. - firstorder; subst. - * left; split => //. rewrite Heq0 //=. lia_f_equal. - * left; split => //. rewrite Heq0 //=. lia_f_equal. - Qed. - - Definition min_model_clause cl m := - LevelExprSet.fold (fun '(l, k) acc => add_max l (Some k) acc) (premise cl) - (add_max (concl cl) None m). - - Definition min_model_map (m : model) cls : model := - Clauses.fold min_model_clause cls m. - - Lemma In_add_max l l' k acc : - LevelMap.In l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). - Proof. - rewrite /LevelMap.In. - rw add_max_spec. firstorder subst. - eexists; left; eauto. - destruct (Level.eq_dec l l'); subst; eexists; eauto. - Qed. - - Definition max_of_premises l kl n := - (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ kl). - - Definition is_expr l (e : LevelExpr.t) := - let '(concl, k) := e in concl = l. - - Definition max_of_clause l kl cl := - max_of_premises l kl (premise cl). - - Definition max_of_map l kl m := - (forall kl', LevelMap.MapsTo l kl' m -> kl' ≤ kl). - - Definition is_max_of_clause_and_map l cl m k := - max_of_premises l k (premise cl) /\ max_of_map l k m. - - Definition is_in_premise l k (u : LevelExprSet.t) := - (exists kl, LevelExprSet.In (l, kl) u /\ k = Some kl). - - Definition is_in_clause l k (cl : clause) := - is_in_premise l k (premise cl) \/ (l = (clause_conclusion cl) /\ k = None). - - Definition is_max_of_clause_model l cl m k := - is_max_of_clause_and_map l cl m k /\ - (is_in_clause l k cl \/ LevelMap.MapsTo l k m). - - Definition is_higher l k m := exists k', LevelMap.MapsTo l k' m /\ k ≤ k'. - - Definition is_max_of_clause_map (map : model) l cl (m : model) : Prop := - (forall k, LevelMap.MapsTo l k map -> is_max_of_clause_model l cl m k) - /\ (forall l k, LevelMap.MapsTo l k m \/ is_in_clause l k cl -> is_higher l k map). - - Lemma is_higher_le l k l' k' m : is_higher l k m -> is_higher l k (add_max l' k' m). - Proof. - rewrite /is_higher. - rw add_max_spec. - intros [k'0 [hm hle]]. - destruct (Level.eq_dec l l'). - - subst. eexists. split; eauto. rewrite (level_value_MapsTo hm). - transitivity k'0 => //. apply max_opt_of_le_r. - - exists k'0. split; eauto. - Qed. - - Lemma is_higher_add l k m : is_higher l k (add_max l k m). - Proof. - rewrite /is_higher. - rw add_max_spec. eexists. split; eauto. - apply max_opt_of_le_l. - Qed. - - Lemma is_higher_mon l k k' m : is_higher l k' m -> k ≤ k' -> is_higher l k m. - Proof. - intros [? []] le. exists x. split => //. now transitivity k'. - Qed. - - Lemma MapsTo_fold_add_max l n a : - let map := LevelExprSet.fold (fun '(l, k0) acc => add_max l (Some k0) acc) n a in - (forall k, LevelMap.MapsTo l k map -> - ((exists kl, - [/\ LevelExprSet.In (l, kl) n, k = Some kl, - (forall kl', LevelExprSet.In (l, kl') n -> kl' <= kl) & - (forall kl', LevelMap.MapsTo l kl' a -> kl' ≤ Some kl)]) \/ - (LevelMap.MapsTo l k a /\ (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ k)))) - /\ (forall l k, LevelMap.MapsTo l k a \/ is_in_premise l k n -> is_higher l k map) /\ - a ⩽ map. - (* ~ LevelMap.In l map -> ~ (exists k, LevelExprSet.In (l, k) n) /\ ~ (LevelMap.In l a)). *) - Proof. - eapply LevelExprSetProp.fold_rec. - - intros s' he. cbn. - rewrite /is_in_premise /is_higher. - setoid_rewrite (LevelExprSetProp.empty_is_empty_1 he). - intuition auto. right. split; eauto. - intros kl. now move/LevelExprSet.empty_spec. - exists k; split => //. reflexivity. - destruct H0 as [x [hin ->]]. now apply LevelExprSet.empty_spec in hin. - reflexivity. - - cbn; intros. - destruct x as [xl k']. split. - 2:{ split. - { intros l0 hnin. destruct H2 as [hm [H2 _]]. specialize (H2 l0). - intros [ina|ins'']. - { specialize (H2 hnin (or_introl ina)). eapply is_higher_le; tea. } - { destruct ins'' as [x [ins'' ->]]. - apply H1 in ins'' as [[=]|ins']. - * subst. apply is_higher_add. - * apply is_higher_le, H2. right. eexists; eauto. } } - { destruct H2 as [_ [_ H2]]. - intros l' hin. move/H2 => [k'0 [hm hle]]. - rw add_max_spec. destruct (Level.eq_dec l' xl). - - eexists; split. left; eauto. subst l'. - rewrite (level_value_MapsTo hm). transitivity (k'0) => //. - apply max_opt_of_le_r. - - eexists; split; eauto. } } - intros. - rewrite add_max_spec in H3; destruct H3 as [[<- hk]|[hdiff hm]]. - * destruct H2 as [hin hnin]. symmetry in hk. - have [[leacc eqms]|[len eqms]] := max_opt_of_spec hk. - { depelim leacc. specialize (hin _ (level_value_MapsTo' H3)) as [[kl [inkl [= <-] les' lea]]|]. - { left. exists y. split => //. apply H1; now right. congruence. intros. - apply H1 in H4 as [[=]|ins']. 2:now apply les'. subst kl'. lia. } - { destruct H4. right. split. now rewrite -H3 -eqms in H4. intros. - apply H1 in H6 as [[=]|ins']; subst; trea. rewrite H3; cbn; constructor; lia_f_equal. - rewrite H3; cbn; constructor. apply H5 in ins'. depelim ins'. lia. } } - { left. exists k'. split => //. - * apply H1. now left. - * move=> kl' /H1 [[=]|ins']. lia. depelim len. transitivity x; tea. specialize (hin _ (level_value_MapsTo' H3)) as - [[kl [inkl [= <-] les' lea]]|[]]. - { now eapply les'. } - { specialize (H5 _ ins'). depelim H5. lia. } - { move: H2 hk. rewrite /level_value. destruct (find_spec l a0). - * intros ->. apply hin in H2 as [[kl []]|[hm hkl']] => //. apply hkl' in ins'. depelim ins'. - * intros _; cbn; intros <-. - destruct hnin as [hnin _]. - specialize (hnin l (Some kl')); forward hnin. right. - red. exists kl'. split => //. - destruct hnin as [ka [hma hge]]. elim H2. now exists ka. } - * subst k. intros kl' mt. move: len. case: level_valueP => [k ma0 le|]. - specialize (hin _ ma0) as [[kl []]|[hm hkl']] => //. - + subst k. eapply H5 in mt. now depelim le; depelim mt; constructor; lia. - + transitivity k => //. eapply LevelMapFact.F.MapsTo_fun in mt; tea. subst. reflexivity. - + intros hnin' _. destruct hnin as [hnin _]. specialize (hnin l kl'). - forward hnin. now left. destruct hnin as [? [hm ?]]. elim hnin'. now exists x. } - * destruct H2. eapply H2 in hm as [[kl []]|[hm hkl']] => //. - { left. exists kl. split => //. apply H1. now right. intros kl' h. subst k. - apply H6. apply H1 in h. destruct h as [[=]|?] => //. subst. congruence. } - { right. split => //. intros kl' hin. apply H1 in hin as [[=]|?] => //; subst; try congruence. eauto. } - Qed. - - Lemma min_model_clause_spec l cl a : - let map := min_model_clause cl a in - is_max_of_clause_map map l cl a. - Proof. - intros m. rewrite /is_max_of_clause_map /is_max_of_clause_model. - have h := MapsTo_fold_add_max l (premise cl) (add_max (concl cl) None a). - change (LevelExprSet.fold (fun '(l, k0) (acc : model) => add_max l (Some k0) acc) (premise cl) - (add_max (concl cl) None a)) with (min_model_clause cl a) in h. - cbn in h. destruct h. split. - - intros k hm. specialize (H k hm) as [[kl []]|[hm' hle]]. - * split => //. subst k. red. split. intros kl' hin. constructor. now apply H2. - move=> kl' hm''. specialize (H3 kl'). - rewrite add_max_spec in H3. forward H3. - destruct (Level.eq_dec l (concl cl)). - { subst l. left. split => //. rewrite max_opt_of_r. apply level_value_MapsTo in hm''. now rewrite hm''. } - { right. split => //. } - exact H3. left. - red. left. red. subst k. eauto. - * rewrite add_max_spec in hm'. - rewrite max_opt_of_r in hm'. destruct hm' as [[]|[]]; try subst l. - { repeat split => //. - { intros l hin'. subst k. rewrite (level_value_MapsTo hin'). reflexivity. } - { destruct k. right. symmetry in H1. now apply level_value_MapsTo' in H1. - left. red. right. split => //. } } - { split => //. split => //. - { intros l' hin'. eapply LevelMapFact.F.MapsTo_fun in H1; tea. subst. reflexivity. } - firstorder. } - - intros l' k. destruct H0 as [H0 hext]. specialize (H0 l' k). - intros [hm|hinc]. - { forward H0. left. rewrite add_max_spec. - destruct (Level.eq_dec l' (concl cl)); eauto. - { left. split => //. rewrite max_opt_of_r. - now rewrite (level_value_MapsTo hm). } - destruct H0 as [? [hinm hle]]. - eapply is_higher_mon; tea. exists x. split; eauto. reflexivity. } - { red in hinc. destruct hinc. apply H0. now right. - destruct H1 as [-> ->]. - destruct (Level.eq_dec l (concl cl)). - red. - destruct (LevelMap.find (concl cl) a) eqn:hl. - * apply LevelMap.find_2 in hl. - specialize (hext (concl cl) o). - forward hext. rewrite add_max_spec. left. split => //. - rewrite max_opt_of_r. now rewrite (level_value_MapsTo hl). - destruct hext as [k' []]. exists k'. split => //. constructor. - * specialize (hext (concl cl) None). - forward hext. rewrite add_max_spec. left. split => //. - now rewrite /level_value hl. - destruct cl; unfold clause_conclusion in *. exact hext. - * specialize (hext (concl cl) (level_value a (concl cl))). - forward hext. rewrite add_max_spec. left. split => //. - destruct hext as [l' []]; exists l'; split => //. constructor. } - Qed. - - Lemma min_model_map_acc l cls m : - let map := min_model_map m cls in - (forall k, LevelMap.MapsTo l k map -> max_of_map l k m) /\ - m ⩽ map. - Proof. - cbn. rewrite /min_model_map. - eapply ClausesProp.fold_rec. - 2:{ intros. destruct H2 as [hf hin]. - have [hm hnin] := min_model_clause_spec l x a. - split. - intros k. - move/hm. rewrite /is_max_of_clause_model. intros [[ism' ism] hasm]. - destruct hasm; eauto. intros kl'. move/hin => [k' [hmk' lek']]. - red in ism. specialize (ism _ hmk'). now transitivity k'. - transitivity a => //. - intros l' k ha. specialize (hnin l' k (or_introl ha)). - exact hnin. } - split; [|reflexivity]. - intros k hin k' hin'. - eapply LevelMapFact.F.MapsTo_fun in hin; tea. subst; reflexivity. - Qed. - - Lemma max_of_map_ext l k m m' : m ⩽ m' -> max_of_map l k m' -> max_of_map l k m. - Proof. - intros hext hm l'; move/hext => [k' [hm' le]]. - apply hm in hm'. now transitivity k'. - Qed. - - Lemma mapsto_max_of_map l k m : LevelMap.MapsTo l k m -> max_of_map l k m. - Proof. - intros hm l' k'. eapply LevelMapFact.F.MapsTo_fun in hm; tea. - subst; reflexivity. - Qed. - - Lemma min_model_map_spec l cls m : - let map := min_model_map m cls in - (forall k, LevelMap.MapsTo l k map -> - [/\ (exists cl, Clauses.In cl cls /\ is_in_clause l k cl) \/ LevelMap.MapsTo l k m, - (forall cl, Clauses.In cl cls -> max_of_premises l k (premise cl)) & max_of_map l k m]) /\ - (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l map) /\ - m ⩽ map. - Proof. - cbn. - rewrite /min_model_map. - have hgen : forall cls m, (forall k, LevelMap.MapsTo l k (Clauses.fold min_model_clause cls m) -> - [/\ (exists cl : Clauses.elt, Clauses.In cl cls /\ is_in_clause l k cl) \/ - LevelMap.MapsTo l k m, - forall cl : Clauses.elt, Clauses.In cl cls -> max_of_premises l k (premise cl) - & max_of_map l k (Clauses.fold min_model_clause cls m)]) /\ - (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l (Clauses.fold min_model_clause cls m)) /\ - m ⩽ Clauses.fold min_model_clause cls m. - 2:{ specialize (hgen cls m). destruct hgen as [hgen [hcls H]]; split; eauto. - intros k hm. specialize (hgen k hm) as [] => //. - split => //. eapply max_of_map_ext; tea. } - clear. - intros cls m. - eapply ClausesProp.fold_rec. - - intros s' he. split; [ | split; [|reflexivity]]. - * intros k hin. split => //. now right. - intros cl hin'. clsets. now apply mapsto_max_of_map. - * intros cl ins'; clsets. - - intros x a s' s'' hin hnin hadd [ih [ihcls hext]]. split; [|split]; revgoals. - { transitivity a => //. intros l' hin' hm. - have := min_model_clause_spec l' x a. cbn. - intros [_ hm']. specialize (hm' l' hin'). - now forward hm' by eauto. } - { intros cl ins'' l' inlev. - apply hadd in ins'' as [<-|]. - * have := min_model_clause_spec l' x a. cbn. - intros [_ hm']. eapply clause_levels_spec in inlev as []. - + eapply levelexprset_levels_spec in H as [k' incl]. - specialize (hm' l' (Some k')). forward hm'. right. left. rewrite /is_in_premise. exists k'; eauto. - destruct hm' as [? []]; now eexists. - + subst l'. specialize (hm' (concl x) None). forward hm'. - right. right. split => //. - destruct hm' as [? []]; now eexists. - * specialize (ihcls _ H _ inlev) as [k' ina]. - have := min_model_clause_spec l' x a. cbn. - move=> [] _ /(_ l' k' (or_introl ina)). - clear. firstorder. } - intros k. - have := min_model_clause_spec l x a. cbn. - intros [hm hm'] hmk. destruct (hm _ hmk). - split => //. - { destruct H0; eauto. - { left; exists x. split => //. apply hadd. now left. } - { specialize (ih _ H0) as []. destruct H1; eauto. left. - move: H1 => [] w []; exists w; split; eauto. apply hadd. now right. } } - { move=> cl /hadd => [] [<-|hin']. - { now move: H => []. } - { specialize (hm' l k). forward hm' by (destruct H0; eauto). - intros k' h. - specialize (ihcls _ hin' l). - forward ihcls. - { eapply clause_levels_spec. left. eapply levelexprset_levels_spec. now exists k'. } - destruct ihcls as [ka ihcls]. - specialize (ih _ ihcls) as [ihm ihcls' maxm]. - specialize (ihcls' _ hin' _ h). - transitivity ka => //. - destruct H as [mp mmap]. - now apply mmap. } } - { intros kl inma. eapply LevelMapFact.F.MapsTo_fun in hmk; tea. subst. reflexivity. } - Qed. - - Lemma only_model_of_min_model_map cls V m : - clauses_levels cls ⊂_lset V -> - only_model_of V m -> only_model_of V (min_model_map m cls). - Proof. - intros incl om l. - split. - - move=> /om => [] [k inm]. - have [hmap [hcls hext]] := min_model_map_spec l cls m. - specialize (hext l k inm). firstorder. - - have [hmap [hcls hext]] := min_model_map_spec l cls m. - move=> [] x /hmap => [] [excl allcl maxm]. - red in maxm. - destruct excl as [[cl [incls incl']]|inm]. - * apply incl. apply clauses_levels_spec. exists cl. split => //. - red in incl'. - apply clause_levels_spec. - clear -incl'. firstorder. subst. left. apply levelexprset_levels_spec. - firstorder. - * rewrite (om l). now exists x. - Qed. - - End ModelMaps. - - Section Semantics. Section Interpretation. @@ -3389,7 +2841,7 @@ Lemma is_update_of_empty cls m : Qed. Lemma equivlistA_add le u : let l := to_nonempty_list (add le u) in - equivlistA eq (l.1 :: l.2) (le :: LevelExprSet.elements u). + equivlistA eq (l.1 :: l.2) (le :: LevelExprSet.elements u). Proof. have he := to_nonempty_list_spec (add le u). destruct to_nonempty_list. cbn. @@ -3650,6 +3102,4 @@ Lemma is_update_of_empty cls m : exact: valid_clause_elim IHentails _ hadd. Qed. - - End Model. \ No newline at end of file diff --git a/common/theories/LoopChecking/Models.v b/common/theories/LoopChecking/Models.v new file mode 100644 index 000000000..a15b514f4 --- /dev/null +++ b/common/theories/LoopChecking/Models.v @@ -0,0 +1,562 @@ +(* Distributed under the terms of the MIT license. *) +(* This module defines a handful of initial models that are used + for defining satisfiability and validity checking. +*) + +From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils. + +From MetaRocq.Common Require Universes. +From MetaRocq.Common Require Import Common Interfaces HornClauses Model. +From Equations Require Import Equations. +Set Equations Transparent. + +Module Models (LS : LevelSets). + Module Export Model := Model(LS). + Local Open Scope Z_scope. + + Definition premises_model_map (m : model) cls : model := + let levels := clauses_premises_levels cls in + LevelSet.fold (fun l acc => + LevelMap.add l (max_clause_premise_of l cls) acc) levels m. + + Definition zero_model levels : model := + LevelSet.fold (fun l acc => LevelMap.add l None acc) levels (LevelMap.empty _). + + Definition premises_model V cl : LevelSet.t * model := + let levels := LevelSet.union (clause_levels cl) V in + (levels, premises_model_map (zero_model levels) (Clauses.singleton cl)). + + Lemma premises_model_map_spec m cls : + forall l k, + LevelMap.MapsTo l k (premises_model_map m cls) <-> + ((LevelSet.In l (clauses_premises_levels cls) /\ k = max_clause_premise_of l cls /\ isSome k) \/ + (~ LevelSet.In l (clauses_premises_levels cls) /\ LevelMap.MapsTo l k m)). + Proof. + intros l k; rewrite /premises_model_map. + eapply LevelSetProp.fold_rec. + - intros s' he. split. intros hm. right. split => //. + firstorder. + - intros x a s' s'' hin hnin hadd ih. + split. + * rewrite LevelMapFact.F.add_mapsto_iff. + firstorder. subst k. red in H; subst. firstorder. + left; firstorder. + apply clauses_premises_levels_spec in hin as [cl [incl inlev]]. + apply levelexprset_levels_spec in inlev as [k inprem]. + have hs := max_clause_premise_of_spec l k cls cl incl inprem. + depelim hs. now rewrite H3. + * intros [[hin' [-> iss]]|]. + rewrite LevelMapFact.F.add_mapsto_iff. + destruct (Level.eq_dec x l); subst; firstorder. + destruct (Level.eq_dec x l); subst; firstorder. + rewrite LevelMapFact.F.add_mapsto_iff. right; split => //. + Qed. + + Lemma zero_model_spec {l ls n} : LevelMap.MapsTo l n (zero_model ls) <-> LevelSet.In l ls /\ n = None. + Proof. + unfold zero_model. + eapply LevelSetProp.fold_rec. + - intros s' he. rewrite LevelMapFact.F.empty_mapsto_iff. firstorder. + - intros x a s s' hin hnin hadd eq. + rewrite LevelMapFact.F.add_mapsto_iff. firstorder. + destruct (Level.eq_dec x l). + * subst. now left. + * right. split => //. apply hadd in H1. destruct H1; try congruence. now apply H0. + Qed. + + + Lemma premises_model_map_min_premise {levels cls prems z} : + min_premise (premises_model_map (zero_model levels) cls) prems = Some z -> + (exists minp mink, LevelExprSet.In (minp, mink) prems /\ + exists maxp, max_clause_premise_of minp cls = Some maxp /\ + z = maxp - mink) \/ + (exists minp mink, LevelExprSet.In (minp, mink) prems /\ z + mink <= 0)%Z. + Proof. + set (m := premises_model_map _ _). + have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m prems. + rewrite mineq. rewrite /min_atom_value. + destruct level_value eqn:hl => //. intros [= <-]. + eapply level_value_MapsTo' in hl. + eapply premises_model_map_spec in hl as [[inpcls [hm _]]|[ninpcls h']]. left. + 2:{ apply zero_model_spec in h' as [h' [= ->]]. } + exists minp, mink. split => //. noconf hm. rewrite -hm. + eexists; split => //. + Qed. + + Lemma premises_model_map_in m cls l : + LevelMap.In l (premises_model_map m cls) <-> (LevelSet.In l (clauses_premises_levels cls) \/ LevelMap.In l m). + Proof. + rewrite /premises_model_map. + eapply LevelSetProp.fold_rec. + - intros s' he. firstorder. + - intros x a s' s'' hin hnin hadd ih. + rewrite LevelMapFact.F.add_in_iff. + firstorder. + Qed. + + Lemma premises_model_map_min_premise_inv {levels cls} : + forall cl, Clauses.In cl cls -> + exists z, min_premise (premises_model_map (zero_model levels) cls) (premise cl) = Some z /\ (0 <= z)%Z. + Proof. + set (m := premises_model_map _ _). + move=> cl hin. + have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m (premise cl). + rewrite mineq. rewrite /min_atom_value. + destruct level_value eqn:hl => //. + - eexists. split; trea. + have ps := proj1 (premises_model_map_spec _ cls minp (Some z)) (level_value_MapsTo' hl). + destruct ps as [[minpsl [eq _]]|]. + * symmetry in eq. + have sp := (max_clause_premise_of_spec _ _ _ _ hin inminp). + depelim sp. rewrite eq in H0. noconf H0. lia. + * destruct H. elim H. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. + - unfold level_value in hl. + destruct LevelMap.find eqn:hl'. subst o. + 2:{ move/LevelMapFact.F.not_find_in_iff: hl'. elim. + rewrite premises_model_map_in. left. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. } + eapply LevelMap.find_2 in hl'. + move/premises_model_map_spec: hl' => [[]|[nin hm]] => //. + * now intros hnminp [_ hn]. + * move: nin; elim. + eapply clauses_premises_levels_spec. exists cl. split => //. + eapply levelexprset_levels_spec. now exists mink. + Qed. + + Lemma in_premises_model V cl : + forall l, + LevelMap.In l (premises_model V cl).2 <-> + LevelSet.In l V \/ LevelSet.In l (clause_levels cl). + Proof. + intros l. rewrite premises_model_map_in. + rewrite clauses_premises_levels_spec. + firstorder. + - right. apply Clauses.singleton_spec in H. + apply clause_levels_spec. left. now subst. + - apply zero_model_spec in H as [hin ->]. + apply LevelSet.union_spec in hin. firstorder. + - right. exists None. apply zero_model_spec. split => //; lsets. + - eapply clause_levels_spec in H as [H|H]. + * left. exists cl. split => //. now apply Clauses.singleton_spec. + * subst. right. exists None. apply zero_model_spec. split => //. + apply LevelSet.union_spec. left. apply clause_levels_spec. now right. + Qed. + + Lemma of_level_map_premises_model_map cls cl V ne : + cls ⊢a premise cl → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. + Proof. + intros [l k]. + rewrite of_level_map_spec. move/premises_model_map_spec; cbn. + intros [[hin' [[= heq] _]]|[hnin hm]]. + 2:{ now apply zero_model_spec in hm as []. } + move: hin'; cbn; rewrite LevelSet.union_spec. intros []; [|lsets]. + eapply max_premise_of_spec_in in H as [maxp' [eq hin']]. + rewrite eq in heq; noconf heq. + now constructor. + Qed. + + Lemma entails_all_satisfies {cls prems m hne l k} : + cls ⊢a prems → of_level_map m hne -> + infers_atom m l k -> + cls ⊢ prems → (l, k). + Proof. + intros hl hi. + eapply entails_all_one; tea. now apply infers_atom_of_level_map. + Qed. + + Lemma premises_model_map_ne V cls : + ~ LevelMap.Empty V -> + ~ LevelMap.Empty (premises_model_map V cls). + Proof. + intros ne he. apply ne. + have ne' := premises_model_map_in V cls. + intros l k hin. + specialize (ne' l). destruct ne'. forward H0. right. now exists k. + destruct H0 as [k' hin']. + now move/he: hin'. + Qed. + + Lemma premises_model_map_defined V cls : + ~ Clauses.Empty cls -> + defined_map (premises_model_map V cls). + Proof. + move/clauses_ne_exist => [cl hin]. + destruct cl as [prems concl]. + pose proof (to_nonempty_list_spec' prems). + set (l := (to_nonempty_list prems).1) in *. + have hs := max_clause_premise_of_spec l l.2 cls (prems, concl) hin. + forward hs. cbn. eapply LevelExprSet.elements_spec1; rewrite -H. + constructor. destruct l; reflexivity. depelim hs. + exists l, y. apply premises_model_map_spec. left. + split => //. + eapply clauses_premises_levels_spec. eexists; split; tea => //. + rewrite //= levelexprset_levels_spec. exists l.2. + setoid_rewrite <- LevelExprSet.elements_spec1. rewrite -H //=. + constructor. destruct l; reflexivity. + Qed. + + (* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by + setting a minimal value for the new atoms in [clauses_levels cls \ V] + such that the new clauses [cls] do not hold vacuously. + *) + + Equations add_max (l : Level.t) (k : option Z) (m : model) : model := + add_max l k m with level_value m l := + { | Some k' with check_atom_value k (Some k') := + { | true => m + | false => LevelMap.add l k m } + | None => LevelMap.add l k m }. + + Lemma add_max_spec l l' k k' (m : model) : + LevelMap.MapsTo l k (add_max l' k' m) <-> + (l = l' /\ k = max_opt_of Z.max k' (level_value m l)) \/ + (l <> l' /\ LevelMap.MapsTo l k m). + Proof. + funelim (add_max l' k' m). + - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. firstorder; subst. + left. split => //. rewrite Heq. now rewrite max_opt_of_l. + left. firstorder. now rewrite Heq max_opt_of_l. + - clear Heqcall. + destruct (Level.eq_dec l0 l). + * subst l0. rewrite Heq0. + move/check_atom_value_spec: Heq. + rewrite (maps_to_update (level_value_MapsTo' Heq0)). + firstorder; subst; try left; try split; auto; depelim Heq; cbn; lia_f_equal. + * firstorder. + - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. + have := check_atom_value_spec k (Some k'). rewrite {}Heq. + intros h; depelim h. apply nleq_optZ in H as [z [-> hlt]]. + firstorder; subst. + * left; split => //. rewrite Heq0 //=. lia_f_equal. + * left; split => //. rewrite Heq0 //=. lia_f_equal. + Qed. + + Definition min_model_clause cl m := + LevelExprSet.fold (fun '(l, k) acc => add_max l (Some k) acc) (premise cl) + (add_max (concl cl) None m). + + Definition min_model_map (m : model) cls : model := + Clauses.fold min_model_clause cls m. + + Lemma In_add_max l l' k acc : + LevelMap.In l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). + Proof. + rewrite /LevelMap.In. + rw add_max_spec. firstorder subst. + eexists; left; eauto. + destruct (Level.eq_dec l l'); subst; eexists; eauto. + Qed. + + Definition max_of_premises l kl n := + (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ kl). + + Definition is_expr l (e : LevelExpr.t) := + let '(concl, k) := e in concl = l. + + Definition max_of_clause l kl cl := + max_of_premises l kl (premise cl). + + Definition max_of_map l kl m := + (forall kl', LevelMap.MapsTo l kl' m -> kl' ≤ kl). + + Definition is_max_of_clause_and_map l cl m k := + max_of_premises l k (premise cl) /\ max_of_map l k m. + + Definition is_in_premise l k (u : LevelExprSet.t) := + (exists kl, LevelExprSet.In (l, kl) u /\ k = Some kl). + + Definition is_in_clause l k (cl : clause) := + is_in_premise l k (premise cl) \/ (l = (clause_conclusion cl) /\ k = None). + + Definition is_max_of_clause_model l cl m k := + is_max_of_clause_and_map l cl m k /\ + (is_in_clause l k cl \/ LevelMap.MapsTo l k m). + + Definition is_higher l k m := exists k', LevelMap.MapsTo l k' m /\ k ≤ k'. + + Definition is_max_of_clause_map (map : model) l cl (m : model) : Prop := + (forall k, LevelMap.MapsTo l k map -> is_max_of_clause_model l cl m k) + /\ (forall l k, LevelMap.MapsTo l k m \/ is_in_clause l k cl -> is_higher l k map). + + Lemma is_higher_le l k l' k' m : is_higher l k m -> is_higher l k (add_max l' k' m). + Proof. + rewrite /is_higher. + rw add_max_spec. + intros [k'0 [hm hle]]. + destruct (Level.eq_dec l l'). + - subst. eexists. split; eauto. rewrite (level_value_MapsTo hm). + transitivity k'0 => //. apply max_opt_of_le_r. + - exists k'0. split; eauto. + Qed. + + Lemma is_higher_add l k m : is_higher l k (add_max l k m). + Proof. + rewrite /is_higher. + rw add_max_spec. eexists. split; eauto. + apply max_opt_of_le_l. + Qed. + + Lemma is_higher_mon l k k' m : is_higher l k' m -> k ≤ k' -> is_higher l k m. + Proof. + intros [? []] le. exists x. split => //. now transitivity k'. + Qed. + + Lemma MapsTo_fold_add_max l n a : + let map := LevelExprSet.fold (fun '(l, k0) acc => add_max l (Some k0) acc) n a in + (forall k, LevelMap.MapsTo l k map -> + ((exists kl, + [/\ LevelExprSet.In (l, kl) n, k = Some kl, + (forall kl', LevelExprSet.In (l, kl') n -> kl' <= kl) & + (forall kl', LevelMap.MapsTo l kl' a -> kl' ≤ Some kl)]) \/ + (LevelMap.MapsTo l k a /\ (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ k)))) + /\ (forall l k, LevelMap.MapsTo l k a \/ is_in_premise l k n -> is_higher l k map) /\ + a ⩽ map. + (* ~ LevelMap.In l map -> ~ (exists k, LevelExprSet.In (l, k) n) /\ ~ (LevelMap.In l a)). *) + Proof. + eapply LevelExprSetProp.fold_rec. + - intros s' he. cbn. + rewrite /is_in_premise /is_higher. + setoid_rewrite (LevelExprSetProp.empty_is_empty_1 he). + intuition auto. right. split; eauto. + intros kl. now move/LevelExprSet.empty_spec. + exists k; split => //. reflexivity. + destruct H0 as [x [hin ->]]. now apply LevelExprSet.empty_spec in hin. + reflexivity. + - cbn; intros. + destruct x as [xl k']. split. + 2:{ split. + { intros l0 hnin. destruct H2 as [hm [H2 _]]. specialize (H2 l0). + intros [ina|ins'']. + { specialize (H2 hnin (or_introl ina)). eapply is_higher_le; tea. } + { destruct ins'' as [x [ins'' ->]]. + apply H1 in ins'' as [[=]|ins']. + * subst. apply is_higher_add. + * apply is_higher_le, H2. right. eexists; eauto. } } + { destruct H2 as [_ [_ H2]]. + intros l' hin. move/H2 => [k'0 [hm hle]]. + rw add_max_spec. destruct (Level.eq_dec l' xl). + - eexists; split. left; eauto. subst l'. + rewrite (level_value_MapsTo hm). transitivity (k'0) => //. + apply max_opt_of_le_r. + - eexists; split; eauto. } } + intros. + rewrite add_max_spec in H3; destruct H3 as [[<- hk]|[hdiff hm]]. + * destruct H2 as [hin hnin]. symmetry in hk. + have [[leacc eqms]|[len eqms]] := max_opt_of_spec hk. + { depelim leacc. specialize (hin _ (level_value_MapsTo' H3)) as [[kl [inkl [= <-] les' lea]]|]. + { left. exists y. split => //. apply H1; now right. congruence. intros. + apply H1 in H4 as [[=]|ins']. 2:now apply les'. subst kl'. lia. } + { destruct H4. right. split. now rewrite -H3 -eqms in H4. intros. + apply H1 in H6 as [[=]|ins']; subst; trea. rewrite H3; cbn; constructor; lia_f_equal. + rewrite H3; cbn; constructor. apply H5 in ins'. depelim ins'. lia. } } + { left. exists k'. split => //. + * apply H1. now left. + * move=> kl' /H1 [[=]|ins']. lia. depelim len. transitivity x; tea. specialize (hin _ (level_value_MapsTo' H3)) as + [[kl [inkl [= <-] les' lea]]|[]]. + { now eapply les'. } + { specialize (H5 _ ins'). depelim H5. lia. } + { move: H2 hk. rewrite /level_value. destruct (find_spec l a0). + * intros ->. apply hin in H2 as [[kl []]|[hm hkl']] => //. apply hkl' in ins'. depelim ins'. + * intros _; cbn; intros <-. + destruct hnin as [hnin _]. + specialize (hnin l (Some kl')); forward hnin. right. + red. exists kl'. split => //. + destruct hnin as [ka [hma hge]]. elim H2. now exists ka. } + * subst k. intros kl' mt. move: len. case: level_valueP => [k ma0 le|]. + specialize (hin _ ma0) as [[kl []]|[hm hkl']] => //. + + subst k. eapply H5 in mt. now depelim le; depelim mt; constructor; lia. + + transitivity k => //. eapply LevelMapFact.F.MapsTo_fun in mt; tea. subst. reflexivity. + + intros hnin' _. destruct hnin as [hnin _]. specialize (hnin l kl'). + forward hnin. now left. destruct hnin as [? [hm ?]]. elim hnin'. now exists x. } + * destruct H2. eapply H2 in hm as [[kl []]|[hm hkl']] => //. + { left. exists kl. split => //. apply H1. now right. intros kl' h. subst k. + apply H6. apply H1 in h. destruct h as [[=]|?] => //. subst. congruence. } + { right. split => //. intros kl' hin. apply H1 in hin as [[=]|?] => //; subst; try congruence. eauto. } + Qed. + + Lemma min_model_clause_spec l cl a : + let map := min_model_clause cl a in + is_max_of_clause_map map l cl a. + Proof. + intros m. rewrite /is_max_of_clause_map /is_max_of_clause_model. + have h := MapsTo_fold_add_max l (premise cl) (add_max (concl cl) None a). + change (LevelExprSet.fold (fun '(l, k0) (acc : model) => add_max l (Some k0) acc) (premise cl) + (add_max (concl cl) None a)) with (min_model_clause cl a) in h. + cbn in h. destruct h. split. + - intros k hm. specialize (H k hm) as [[kl []]|[hm' hle]]. + * split => //. subst k. red. split. intros kl' hin. constructor. now apply H2. + move=> kl' hm''. specialize (H3 kl'). + rewrite add_max_spec in H3. forward H3. + destruct (Level.eq_dec l (concl cl)). + { subst l. left. split => //. rewrite max_opt_of_r. apply level_value_MapsTo in hm''. now rewrite hm''. } + { right. split => //. } + exact H3. left. + red. left. red. subst k. eauto. + * rewrite add_max_spec in hm'. + rewrite max_opt_of_r in hm'. destruct hm' as [[]|[]]; try subst l. + { repeat split => //. + { intros l hin'. subst k. rewrite (level_value_MapsTo hin'). reflexivity. } + { destruct k. right. symmetry in H1. now apply level_value_MapsTo' in H1. + left. red. right. split => //. } } + { split => //. split => //. + { intros l' hin'. eapply LevelMapFact.F.MapsTo_fun in H1; tea. subst. reflexivity. } + firstorder. } + - intros l' k. destruct H0 as [H0 hext]. specialize (H0 l' k). + intros [hm|hinc]. + { forward H0. left. rewrite add_max_spec. + destruct (Level.eq_dec l' (concl cl)); eauto. + { left. split => //. rewrite max_opt_of_r. + now rewrite (level_value_MapsTo hm). } + destruct H0 as [? [hinm hle]]. + eapply is_higher_mon; tea. exists x. split; eauto. reflexivity. } + { red in hinc. destruct hinc. apply H0. now right. + destruct H1 as [-> ->]. + destruct (Level.eq_dec l (concl cl)). + red. + destruct (LevelMap.find (concl cl) a) eqn:hl. + * apply LevelMap.find_2 in hl. + specialize (hext (concl cl) o). + forward hext. rewrite add_max_spec. left. split => //. + rewrite max_opt_of_r. now rewrite (level_value_MapsTo hl). + destruct hext as [k' []]. exists k'. split => //. constructor. + * specialize (hext (concl cl) None). + forward hext. rewrite add_max_spec. left. split => //. + now rewrite /level_value hl. + destruct cl; unfold clause_conclusion in *. exact hext. + * specialize (hext (concl cl) (level_value a (concl cl))). + forward hext. rewrite add_max_spec. left. split => //. + destruct hext as [l' []]; exists l'; split => //. constructor. } + Qed. + + Lemma min_model_map_acc l cls m : + let map := min_model_map m cls in + (forall k, LevelMap.MapsTo l k map -> max_of_map l k m) /\ + m ⩽ map. + Proof. + cbn. rewrite /min_model_map. + eapply ClausesProp.fold_rec. + 2:{ intros. destruct H2 as [hf hin]. + have [hm hnin] := min_model_clause_spec l x a. + split. + intros k. + move/hm. rewrite /is_max_of_clause_model. intros [[ism' ism] hasm]. + destruct hasm; eauto. intros kl'. move/hin => [k' [hmk' lek']]. + red in ism. specialize (ism _ hmk'). now transitivity k'. + transitivity a => //. + intros l' k ha. specialize (hnin l' k (or_introl ha)). + exact hnin. } + split; [|reflexivity]. + intros k hin k' hin'. + eapply LevelMapFact.F.MapsTo_fun in hin; tea. subst; reflexivity. + Qed. + + Lemma max_of_map_ext l k m m' : m ⩽ m' -> max_of_map l k m' -> max_of_map l k m. + Proof. + intros hext hm l'; move/hext => [k' [hm' le]]. + apply hm in hm'. now transitivity k'. + Qed. + + Lemma mapsto_max_of_map l k m : LevelMap.MapsTo l k m -> max_of_map l k m. + Proof. + intros hm l' k'. eapply LevelMapFact.F.MapsTo_fun in hm; tea. + subst; reflexivity. + Qed. + + Lemma min_model_map_spec l cls m : + let map := min_model_map m cls in + (forall k, LevelMap.MapsTo l k map -> + [/\ (exists cl, Clauses.In cl cls /\ is_in_clause l k cl) \/ LevelMap.MapsTo l k m, + (forall cl, Clauses.In cl cls -> max_of_premises l k (premise cl)) & max_of_map l k m]) /\ + (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l map) /\ + m ⩽ map. + Proof. + cbn. + rewrite /min_model_map. + have hgen : forall cls m, (forall k, LevelMap.MapsTo l k (Clauses.fold min_model_clause cls m) -> + [/\ (exists cl : Clauses.elt, Clauses.In cl cls /\ is_in_clause l k cl) \/ + LevelMap.MapsTo l k m, + forall cl : Clauses.elt, Clauses.In cl cls -> max_of_premises l k (premise cl) + & max_of_map l k (Clauses.fold min_model_clause cls m)]) /\ + (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l (Clauses.fold min_model_clause cls m)) /\ + m ⩽ Clauses.fold min_model_clause cls m. + 2:{ specialize (hgen cls m). destruct hgen as [hgen [hcls H]]; split; eauto. + intros k hm. specialize (hgen k hm) as [] => //. + split => //. eapply max_of_map_ext; tea. } + clear. + intros cls m. + eapply ClausesProp.fold_rec. + - intros s' he. split; [ | split; [|reflexivity]]. + * intros k hin. split => //. now right. + intros cl hin'. clsets. now apply mapsto_max_of_map. + * intros cl ins'; clsets. + - intros x a s' s'' hin hnin hadd [ih [ihcls hext]]. split; [|split]; revgoals. + { transitivity a => //. intros l' hin' hm. + have := min_model_clause_spec l' x a. cbn. + intros [_ hm']. specialize (hm' l' hin'). + now forward hm' by eauto. } + { intros cl ins'' l' inlev. + apply hadd in ins'' as [<-|]. + * have := min_model_clause_spec l' x a. cbn. + intros [_ hm']. eapply clause_levels_spec in inlev as []. + + eapply levelexprset_levels_spec in H as [k' incl]. + specialize (hm' l' (Some k')). forward hm'. right. left. rewrite /is_in_premise. exists k'; eauto. + destruct hm' as [? []]; now eexists. + + subst l'. specialize (hm' (concl x) None). forward hm'. + right. right. split => //. + destruct hm' as [? []]; now eexists. + * specialize (ihcls _ H _ inlev) as [k' ina]. + have := min_model_clause_spec l' x a. cbn. + move=> [] _ /(_ l' k' (or_introl ina)). + clear. firstorder. } + intros k. + have := min_model_clause_spec l x a. cbn. + intros [hm hm'] hmk. destruct (hm _ hmk). + split => //. + { destruct H0; eauto. + { left; exists x. split => //. apply hadd. now left. } + { specialize (ih _ H0) as []. destruct H1; eauto. left. + move: H1 => [] w []; exists w; split; eauto. apply hadd. now right. } } + { move=> cl /hadd => [] [<-|hin']. + { now move: H => []. } + { specialize (hm' l k). forward hm' by (destruct H0; eauto). + intros k' h. + specialize (ihcls _ hin' l). + forward ihcls. + { eapply clause_levels_spec. left. eapply levelexprset_levels_spec. now exists k'. } + destruct ihcls as [ka ihcls]. + specialize (ih _ ihcls) as [ihm ihcls' maxm]. + specialize (ihcls' _ hin' _ h). + transitivity ka => //. + destruct H as [mp mmap]. + now apply mmap. } } + { intros kl inma. eapply LevelMapFact.F.MapsTo_fun in hmk; tea. subst. reflexivity. } + Qed. + + Lemma only_model_of_min_model_map cls V m : + clauses_levels cls ⊂_lset V -> + only_model_of V m -> only_model_of V (min_model_map m cls). + Proof. + intros incl om l. + split. + - move=> /om => [] [k inm]. + have [hmap [hcls hext]] := min_model_map_spec l cls m. + specialize (hext l k inm). firstorder. + - have [hmap [hcls hext]] := min_model_map_spec l cls m. + move=> [] x /hmap => [] [excl allcl maxm]. + red in maxm. + destruct excl as [[cl [incls incl']]|inm]. + * apply incl. apply clauses_levels_spec. exists cl. split => //. + red in incl'. + apply clause_levels_spec. + clear -incl'. firstorder. subst. left. apply levelexprset_levels_spec. + firstorder. + * rewrite (om l). now exists x. + Qed. + +End Models. diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index 7e08a32d5..346b4cf1e 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -7,14 +7,17 @@ From MetaRocq.Utils Require Import utils. From MetaRocq.Common Require Universes. From Equations Require Import Equations. -From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model. +From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model Models. Set Equations Transparent. Module LoopCheckingImpl (LS : LevelSets). - Module Export Model := Model(LS). +(* This module is actually independent of the Models, it only needs the + lemmas in Model.v, but we do this to share the LevelSets representation. *) +Module Export Model := Models(LS). + +Local Open Scope Z_scope. - Local Open Scope Z_scope. Definition v_minus_w_bound (W : LevelSet.t) (m : model) := LevelMap.fold (fun w v acc => Z.max (option_get 0 v) acc) (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0%Z. From 8f7ed0790bd7041afb5c7e4231ea27eaae725c20 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 11 Sep 2025 12:25:30 +0200 Subject: [PATCH 043/164] Comment in Model.v --- common/theories/LoopChecking/Model.v | 56 ++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 13e1838f3..b0e0d25dc 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -1,4 +1,60 @@ (* Distributed under the terms of the MIT license. *) +(* This module defines the notion of model as a partial function from levels to Z. + + [is_model cls m] states that all clauses [cls] are valid in [m]. + + An atom [l + k] is satisfied in a model [m] when the value of [l] in [m] is defined to [v : Z] and + [k ≤ v]. If the value is undefined the atom does not hold. + + A clause [prems -> concl + k] is valid in [m]: + - if the atom [concl + (k + kprem)] is satisfied where [kprem] is the minimal value of + its (non-empty) premises. + - otherwise, if the premises contain an undefined atom (the clause is not "enabled"), + its minimal value is undefined and the premise vacuously holds. + + We develops the theory of [check_model m cls], the function that checks a model [m] + w.r.t. a set of clauses [cls] and potentially updates some values to make the clauses hold. + The main invariant is that, if [check_model] modifies some values, then we have a sequence of + strict updates ([strictly_updates]) from the initial model to the modified one. If [check_model] does not modify any + value, then [m] is already a model of [cls]. Note that some clauses in [cls] might not be + activated/enabled by the model [m] (they hence hold vacuously). + + We also show the relation of a model to entailment: + - If an entailment [cls ⊢ prems → concl] holds then any valid model [m] of the clauses [cls] + satisfies [prems → concl], i.e [ is_model cls m -> valid_clause m (prems, concl) ]. + - Conversely, if we have a sequence of strict updates from model [m] to model [m'] under clauses + [cls] then we have an entailment: [ cls ⊢ of_model_map m → of_level_map m' ], where + [of_level_map] turns assignments [m -> Some v] to atoms [m + v] and [m -> None] are discarded. + - From any model we can build a valuation (in 𝐍) by shifting it upwards and inverting it + so that the "lowest" level is mapped to 0 ([valuation_of_model]) + - If a clause is valid and enabled (its premises are all defined), + the interpretation of the clause (in 𝐍) using the derived valuation is provable. + - If an entailment [cls ⊢ prems → concl] holds then any valuation [v] that satisfies the clauses + [cls] also satisfies [prems → concl], i.e [ forall v, ⟦ cls ⟧_v -> ⟦ prems ⟧_v >= ⟦ concl ⟧_v ] (in 𝐍). + + The algorithm in [PartialLoopChecking] will either build a model of the clauses by a sequence + of strict updates from which we can build a valuation that satisfies the clauses or it will detect + a loop, i.e. a situation where [cls ⊢ a → a + 1] for some (non-empty) set of atoms [a] (i.e. a contradiction when seen + through the valuations). + + Alltogether, by choosing appropriate initial models (defined in [Models.v]), this allows to decide + satisfiability and validity. + + For satisfiabiliy [cls, prems → concl + k|=] we try to find a model of [cls /\ prems → concl + k] + starting from an initial model m that enables the premises of all the clauses [cls] and [prems]: + atoms [l + k] are defined such that m[l] >= k, so that the minimal premise value of all + clauses is actually defined and [>= 0]. + + For validity [cls |= prems → concl + k] we try to find a model of [cls] starting + from an initial model m that enables *only* the premises [prems]: + atoms [l + k] in [prems] are defined such that m[l] >= k. We then check if, in + the (minimal) model that is inferred from the clauses [cls], the atom [concl + k] is satisfied. + If so, the clause is valid: any possible valid valuation [v] of the clauses implies that + [ ⟦ prems ⟧_v >= ⟦ concl ⟧_v ]. It implies that in any extension of the clauses [cls], the + clause will remain valid. + +*) + From Stdlib Require Import ssreflect ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From a70366bf4350678c51c2ab50716d492ec3aac665 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 11 Sep 2025 12:55:10 +0200 Subject: [PATCH 044/164] Comment in Horn Clauses --- common/theories/LoopChecking/HornClauses.v | 77 ++++++++++++++++++++++ common/theories/LoopChecking/Model.v | 5 ++ 2 files changed, 82 insertions(+) diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 8d578cf1b..4a1c5f89e 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -1,4 +1,81 @@ (* Distributed under the terms of the MIT license. *) +(** + + * Horn clause + + This module defines our Horn clauses (atoms -> atom), where atoms is non-empty. + An atom is a variable (in Level.t) + an increment (in 𝐙). + + We define a number of operations on non-empty sets of atoms, allowing to compute + their set operations like addition or union, based on an custom eliminator + for non-empty sets. + + We also define operations for finding the maximal or minimal increment of a set of atoms + and finding the (optional) maximal premise of a specific level [l] in a set of atoms. + + * Horn clauses + + We define the notion of "gain" of a clause and maximal gain of a set of clauses which are + used to prove termination of the algorithms in [PartialLoopChecking] as well. + + We also define set-theoretic operations on clauses that are restricted to have conclusions + or conclusions and premises in a particular set of levels, that is used in the algorithm. + The partitioning of a clause set into those with a particular conclusion is defined here. + + There is also a (now unused) operation to build a set of atoms out of a set of levels, + giving them all the same increment. This is only useful for the case of a model in 𝐍. + + * Entailment + + We also define the entailment relation for our Horn clauses. + This is a simple inductive definiton with two rules: + + - a ∈ prems -> cls ⊢ prems → a + + Axiom rule. + + - in_pred_closure cls (prems' → concl') cls ⊢ add concl' prems → concl prems' ⊂ prems + -------------------------------------------------------------------------------------- + cls ⊢ prems → concl + + This "cut" rule allows to add an inferred conclusion [concl'] to the set of premises. + + The auxilliary notion [in_pred_closure] has two (non-inductive) rules: + + (prems → concl) ∈ cls. z : 𝐙 + ------------------------------------------- + in_pred_closure cls (prems + z → concl + z) + + This rule closes the set of clauses under shifting upwards or downwards + (this models [max u >= max v <-> max u + z >= max v + z]). + + l : Level.t z : 𝐙 + ------------------------------- + in_pred_closure cls (l + 1 → l) + + This rule ensures that atom satisfiability is closed downwards: modeling (x + 1 >= x) + + Altogether, this models the injectivity of [+]. + + We define [cls ⊢a atoms → atoms'] as the conjunction of [cls ⊢ atoms → a] for all [a ∈ atoms']. + All the notions lift to entailment of a set of atoms rather than just one atom. + + * Entailment properties + + We show that entailment has various metatheoretical properties: + + - It is closed under shifting: [cls ⊢ prems → concl <-> cls + n ⊢ prems + n → concl + n]. + + - It validates weakening: [cls ⊢ prems → concl -> cls ⊢ prems', prems → concl]. + + - It is reflexive: [cls ⊢ u → u] + + - It is transitive: [cls ⊢a prems → concl -> cls ⊢a concl -> concl' -> cls ⊢a prems → concl'], + i.e. it validates a general cut rule. + +*) + + From Stdlib Require Import ssreflect ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index b0e0d25dc..1e3a99f36 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -25,10 +25,15 @@ - Conversely, if we have a sequence of strict updates from model [m] to model [m'] under clauses [cls] then we have an entailment: [ cls ⊢ of_model_map m → of_level_map m' ], where [of_level_map] turns assignments [m -> Some v] to atoms [m + v] and [m -> None] are discarded. + The maps must be defined for at least one level, which follows from the fact we have + a strict update. + - From any model we can build a valuation (in 𝐍) by shifting it upwards and inverting it so that the "lowest" level is mapped to 0 ([valuation_of_model]) + - If a clause is valid and enabled (its premises are all defined), the interpretation of the clause (in 𝐍) using the derived valuation is provable. + - If an entailment [cls ⊢ prems → concl] holds then any valuation [v] that satisfies the clauses [cls] also satisfies [prems → concl], i.e [ forall v, ⟦ cls ⟧_v -> ⟦ prems ⟧_v >= ⟦ concl ⟧_v ] (in 𝐍). From 4175ed97fc3516c7419c0a87caaf2b827614099b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 11 Sep 2025 15:56:58 +0200 Subject: [PATCH 045/164] Commented in PartialLoopChecking --- common/theories/LoopChecking/Model.v | 2 +- .../LoopChecking/PartialLoopChecking.v | 218 +++++++++++++++--- template-rocq/theories/PartialLoopChecking.v | 1 + 3 files changed, 186 insertions(+), 35 deletions(-) diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 1e3a99f36..a00fd2e87 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -1296,7 +1296,7 @@ Module Model (LS : LevelSets). Qed. Lemma min_atom_value_levelexpr_value m l a lv : min_atom_value m l = Some a -> levelexpr_value m l = Some lv -> - (a <= lv - l.2). + (a = lv - l.2). Proof. destruct l as [l k]; cbn. unfold levelexpr_value. cbn. destruct level_value => //. intros [= <-] [= <-]. lia. diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index 346b4cf1e..be6d834b6 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -1,4 +1,152 @@ (* Distributed under the terms of the MIT license. *) +(** + + This module defines the main loop-checking algorithm on a partial model in 𝐙. + This algorithm is based on two nested well-founded recursive functions with separate measures. + + The main arguments developed here concern the termination of the algorithms, defining + the two measures and showing the termination lemmas. It relies on the theory developped in + Model.v about the properties of the [check_model]. The functions are dependently-typed: + we know by construction that they return either a loop or a valid model. + This is necessary to avoid fuel, as the termination argument relies on semantic arguments + on the shapes of the model and clauses involved. + + To allow for incremental update of models, the notion of valid model of a set of clauses [cls] + returned by the algorithm is parameterized by an initial model [m]. + - The [V] parameter represents the levels in the model, defined or undefined. + - The clauses must have conclusions in [V]. + - The valid model ([model_model]) returned by the algorithm always results from a + (possibly empty) sequence of strict updates from the initial model. + - It is provably a model of the clauses ([model_ok]). + + The algorithm works by first checking if the model [m] validates all clauses, or + requires a sequence of updates to validate some of the clauses. We track the updated + values in a set [U], initially [U ⊂ V]. + + - If it is a model we return it. + - Otherwise we have a set [W] with [U ⊂ W] of levels that required updates to validate some of the clauses. + + + If [W = V], then actually all levels required a strict update from [m] to [m']: + as we have an entailment [cls ⊢ m → m'] and all atoms in [m'] are strictly greater than [m], + we can turn it into an entailment [cls ⊢ of_level_map m → of_level_map m + 1], resulting in a loop. + Note that [m] must have at least one defined element here, otherwise no strict update could have + happened (all clauses would be vacuously true). + + Otherwise, [#|W| < #|V|]. + We then launch the inner loop on the set of clauses [cls ↓ W] (i.e. clauses with conclusions in W only), + which will call loop-checking again on the smaller set [W]. + This returns either a loop which we return directly or a model of [cls ↓ W]. + In case we have a model of [cls ↓ W], we check if the new model validates the rest of the clauses + (i.e. [cls \ cls ↓ W]). As our [check_model] function can accumulate a sequence of updates, + we actually relaunch it on the whole set of clauses to gather more potential updates. + + + Again, if we have a model we return it, and need to check again for a loop. + + Otherwise some strict updates were necessary and the new working set [W'] is such that + [#|W'| < #|V|]. + At least one of those updates must be on a level [l] not in W, so we are entitled to do + a recursive call to loop checking, as the cardinal of the set [U ∪ {l}] increased strictly + without equating [V], so [#|V| - #|U ∪ {l}] < #|V| - #|U|]. + + The inner loop takes V, W, cls ↓ W and the current model [m]. + This model [m] is a defined model for all of W as their values were strictly updated. + It then works as follows: + - We start by partitionning the clauses (cls ↓ W) depending on the fact that all premises are in W or not. + We get a set (cls ⇂ W) of clauses restricted to W and the rest. + We launch the loop checking algorithm on the restricted clauses and the restriction of the + model to W: this satisfies the preconditions of the main loop as all the levels in the clauses + we give are in W and the model only gives potential values to levels in W. + It returns either a loop that we return or a model [m'] of (cls ⇂ W). + We then update the initial model [m] with [m'], returning to a model of all of V. + By invariant, we have that [m'] is an extension of [m] on W and does not have values for l ∉ W, + in which case we keep the values from [m]. + We now test if this new model [m ∪ m'] is a model of the rest of the clauses with conclusions in W. + If it is we return it. Otherwise, a sequence of strict updates was necessary on some set W' ⊂ W. + We are entitled to do a recursive call to the inner loop again. The justification here relies + on the fact that the levels in W can only be strictly updated a finite number of times by the clauses + in (cls ↓ W \ cls ⇂ W). Intuitively, this is because the levels in [V - W] stay unchanged during the + inner loop as we focus on [cls ↓ W]. We can hence give a bound on the maximal values the + levels in [W] can reach. The bound is the maximal value [max {v | l := v ∈ m, l ∉ W}] + the maximal + gain of the clauses in (cls ↓ W \ cls ⇂ W), which corresponds to the maximal amount by which a + conclusion (in W) can be increased by those clauses due to levels in V - W, seen as a natural number. + For a given level l ∈ W, we define the measure of l to be: [bound - m[l]] (remember m[l] + is necessarily defined). The measure of a level hence decreases strictly when the model + gets a strict update of l. If a clause in (cls ↓ W \ cls ⇂ W) is invalid, then + the measure of its conclusion is necessarily strictly positive. + + ** Gain + + The gain of a clause [prems -> concl + k] is defined as [Z.to_nat (k - min_premise prems)]. + For example, the gain of downward closure clauses like [l + 1 -> l] is [Z.to_nat (0 + -1) = 0]: + they cannot incur an update. + + The gain of clauses that might lift the value of a level upward like + [l + 1 -> l' + 2] is [Z.to_nat (2 - 1) = 1]: they can incur an update by 1. + + The gain of clauses with negative premises can also incur lifts, e.g: + [gain(l - 1 -> k) = Z.to_nat (0 - (-1)) = 1]: they also incur an update by 1. + + Crucially, the gain of clauses is invariant by shifting upwards *or downwards*, i.e. + gain (l + k -> l' + k') = gain (l + k + z -> l' + k' + z) (k, k', z ∈ Ƶ) + + If the bounds were ever reached for all levels in l, then the clauses would be valid, + contradicting the fact that [m ∪ m'] is not a model of (cls ↓ W \ cls ⇂ W) + (see lemma [measure_model], which is actually not necessary for the proof). + + The reasonning for invalid clauses to force a positive measure for their conclusion is really + subtle. It goes as follows: if the clause [prems = premsW, premsNW -> concl + k] (concl, premwW ∈ W, premsnW ∉ W) is invalid, + then its minimal premise min { m[l] - k) | (l, k) ∈ prems} must be equal to [Some z] and we must have that the + conclusion does not hold, so m[concl] < k + z (i). By definition of the maximal gain, + gain(premsNW -> concl + k) <= max_gain. Note that we focus on the premises not mentionning W here. + We can strenthen the inequality we need to show to: + + m[concl] < max { m[l] | l ∈ V / W } + (k - premise_min premsNW) (in 𝐙) + + by transitivity with (i) it suffices to show: + k + z <= max { m[l] | l ∈ V / W } + (k - premise_min premsNW) + + by cancellation we get to + + min {m[l] - k | (l, k) ∈ prems} <= max { m[l] | l ∈ V / W } - premise_min premsNW + + we can again strengthen to consider only premises not mentioning W. + + min {m[l] - k | (l, k) ∈ premsNW} <= max { m[l] | l ∈ V / W } - premise_min premsNW + + which is equivalent to + + min {m[l] - k | (l, k) ∈ premsNW} <= max { m[l] | l ∈ V / W } - min {k | (l, k) ∈ premsNW} + + We have the lemma that: + + min {m[l] - k | (l, k) ∈ premsNW} <= max {m[l] | (l, k) ∈ premsNW} - min {k | (l, k) ∈ premsNW} + + I.e. instead of looking at the minimal premise value, we take the maximum of the levels minus + the minimum of the increments. To see why this holds: + Assume (minl, mink) is such that min {m[l] - k | (l, k) ∈ premsNW} = m[minl] - mink. + We have both min {k | (l, k) ∈ premsNW} <= mink and m[minl] <= max {m[l] | (l, k) ∈ premsNW}, + so the inequality holds. + + We can hence strengthen again by looking at the maximal value of a level in the premises: + + max {m[l] | (l, k) ∈ premsNW} - min {k | (l, k) ∈ premsNW} <= max { m[l] | l ∈ V / W } - min {k | (l, k) ∈ premsNW} + + This simplifies now to + + max {m[l] | (l, k) ∈ premsNW} <= max { m[l] | l ∈ V / W } + + As the (l, k) range over atoms not mentionniong W, this is provable. + + Coming back to the inner_loop measure: the measure is defined by taking the sum of the bounds + of all levels in W. So at the recursive call, it suffices to show that for at least + one level in W, this sum strictly decreased. This is the case because we found an invalid + clause in (cls ↓ W \ cls ⇂ W) that required an update, and hence for its conclusion, the + term in the sum decreased, the other terms just need to be shown to decrease largely, which + easily follows from the fact that the new model [m ∪ m'] is an extension of the previous one hence + has greater or equal values. + + This completes the termination proofs. + +*) + From Stdlib Require Import ssreflect ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. @@ -18,6 +166,39 @@ Module Export Model := Models(LS). Local Open Scope Z_scope. +Record valid_model_def (V W : LevelSet.t) (m : model) (cls : clauses) := + { model_model : model; + model_of_V :> model_of V model_model; + model_updates : is_update_of cls W m model_model; + model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; + model_ok :> is_model cls model_model; + }. +Arguments model_model {V W m cls}. +Arguments model_of_V {V W m cls}. +Arguments model_updates {V W m cls}. +Arguments model_clauses_conclusions {V W m cls}. +Arguments model_ok {V W m cls}. +Extraction Inline model_model. + +Definition valid_model := valid_model_def. + +Definition loop_on_univ cls u := cls ⊢a u → succ_prems u. + +Lemma loop_on_subset {cls cls' u} : Clauses.Subset cls cls' -> loop_on_univ cls u -> loop_on_univ cls' u. +Proof. + intros sub; rewrite /loop_on_univ => hyp. + now eapply entails_all_clauses_subset. +Qed. + +Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := + | Loop (v : premises) (islooping : loop_on_univ cls v) + | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). +Arguments Loop {V U cls m}. +Arguments Model {V U cls m}. +Arguments lexprod {A B}. + + + Definition v_minus_w_bound (W : LevelSet.t) (m : model) := LevelMap.fold (fun w v acc => Z.max (option_get 0 v) acc) (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0%Z. @@ -144,11 +325,11 @@ Proof. { eapply premise_min_subset. eapply non_W_atoms_subset. } assert (y <= maxpreml - (premise_min preml))%Z. { rewrite eqpminpre. rewrite H2 in eqminpre; symmetry in eqminpre. - pose proof (min_atom_value_levelexpr_value m exmin). + pose proof (min_atom_value_levelexpr_value m exmin). rewrite /levelexpr_value in H4. specialize (amax _ inminpre) as amax'. rewrite eqmaxpre in amax'. destruct amax' as [vexmin [eqexmin ltexmin]]. assert (expmin.2 <= exmin.2). specialize (apmin _ inminpre). lia. - specialize (H4 _ _ eqminpre eqexmin). depelim ltexmin. etransitivity; tea. + specialize (H4 _ _ eqminpre eqexmin). rewrite H4. depelim ltexmin. rewrite -eqmaxpre in H6. noconf H6. lia. } transitivity (k + (maxpreml - (premise_min preml)))%Z. lia. @@ -165,37 +346,6 @@ Proof. destruct hlevels as [_ nw]. specialize (vm nw). depelim vm. lia. } Qed. -Record valid_model_def (V W : LevelSet.t) (m : model) (cls : clauses) := - { model_model : model; - model_of_V :> model_of V model_model; - model_updates : is_update_of cls W m model_model; - model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; - model_ok :> is_model cls model_model; - }. -Arguments model_model {V W m cls}. -Arguments model_of_V {V W m cls}. -Arguments model_updates {V W m cls}. -Arguments model_clauses_conclusions {V W m cls}. -Arguments model_ok {V W m cls}. -Extraction Inline model_model. - -Definition valid_model := valid_model_def. - -Definition loop_on_univ cls u := cls ⊢a u → succ_prems u. - -Lemma loop_on_subset {cls cls' u} : Clauses.Subset cls cls' -> loop_on_univ cls u -> loop_on_univ cls' u. -Proof. - intros sub; rewrite /loop_on_univ => hyp. - now eapply entails_all_clauses_subset. -Qed. - -Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := - | Loop (v : premises) (islooping : loop_on_univ cls v) - | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). -Arguments Loop {V U cls m}. -Arguments Model {V U cls m}. -Arguments lexprod {A B}. - Definition option_of_result {V U m cls} (r : result V U m cls) : option model := match r with | Model w m _ => Some m.(model_model) @@ -288,7 +438,7 @@ Section InnerLoop. specialize (amax _ inminpre). destruct amax as [k' [lk' hk']]. depelim hk'. pose proof (min_atom_value_levelexpr_value m exmin _ _ H2 lk'). - rewrite eqminpre H2. constructor. etransitivity; tea. + rewrite eqminpre H2. constructor. rewrite H3. rewrite eqmaxpre in eqmaxp. assert (expmin.2 <= exmin.2). specialize (apmin _ inminpre). lia. lia. } diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index 5a9ac3733..e093398e6 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -1,4 +1,5 @@ (* Distributed under the terms of the MIT license. *) + From Stdlib Require Import ssreflect ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From faf82d4cc3988ef623e93116240612fa1b7cce72 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 11 Sep 2025 16:39:42 +0200 Subject: [PATCH 046/164] Use /fwd tactic --- common/theories/LoopChecking/Common.v | 3 +- .../LoopChecking/PartialLoopChecking.v | 381 ++++++++---------- 2 files changed, 165 insertions(+), 219 deletions(-) diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v index 0cd5d096b..4ce95ed28 100644 --- a/common/theories/LoopChecking/Common.v +++ b/common/theories/LoopChecking/Common.v @@ -1,5 +1,5 @@ (* Distributed under the terms of the MIT license. *) -From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import ssreflect ssrfun ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils. @@ -11,6 +11,7 @@ Set Equations Transparent. Ltac rw l := rewrite_strat (topdown l). Ltac rw_in l H := rewrite_strat (topdown l) in H. +Notation fwd := (ltac:(move=> /(_ _)/Wrap[])). (* TODO move *) Arguments exist {A P}. diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index be6d834b6..a64d656f2 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -91,7 +91,7 @@ contradicting the fact that [m ∪ m'] is not a model of (cls ↓ W \ cls ⇂ W) (see lemma [measure_model], which is actually not necessary for the proof). - The reasonning for invalid clauses to force a positive measure for their conclusion is really + The reasonning for invalid clauses to force a positive measure for their conclusion is subtle. It goes as follows: if the clause [prems = premsW, premsNW -> concl + k] (concl, premwW ∈ W, premsnW ∉ W) is invalid, then its minimal premise min { m[l] - k) | (l, k) ∈ prems} must be equal to [Some z] and we must have that the conclusion does not hold, so m[concl] < k + z (i). By definition of the maximal gain, @@ -147,7 +147,7 @@ *) -From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import ssreflect ssrfun ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils. @@ -197,8 +197,6 @@ Arguments Loop {V U cls m}. Arguments Model {V U cls m}. Arguments lexprod {A B}. - - Definition v_minus_w_bound (W : LevelSet.t) (m : model) := LevelMap.fold (fun w v acc => Z.max (option_get 0 v) acc) (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0%Z. @@ -379,228 +377,175 @@ Proof. eapply model_of_ext; tea. Qed. -Section InnerLoop. - Definition sum_W W (f : LevelSet.elt -> nat) : nat := - LevelSet.fold (fun w acc => acc + f w)%nat W 0%nat. - - Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := - sum_W W (fun w => Z.to_nat (measure_w W cls m w)). - - Lemma measure_model W cls m : - defined_model_of W m -> - let clsdiff := cls_diff cls W in - measure W cls m = 0%nat -> is_model clsdiff m. - Proof using. - unfold measure, sum_W, measure_w, is_model. - set (clsdiff := Clauses.diff _ _). - intros hv hm. - assert (LevelSet.For_all (fun w => Some (v_minus_w_bound W m + Z.of_nat (max_gain clsdiff)) ≤ level_value m w) W). - { move: hm. - generalize (v_minus_w_bound W m) => vbound. - eapply LevelSetProp.fold_rec. - intros. intros x hin. firstorder eauto. - intros x a s' s'' inw nins' hadd ih heq. - forward ih by lia. - intros l hin. - specialize (hv _ inw) as [k lv]. rewrite /level_value_default (level_value_MapsTo lv) in heq. - apply hadd in hin as []. - * subst x. rewrite (level_value_MapsTo lv). - constructor. lia. - * now apply ih. } - clear hm. - eapply ClausesFact.for_all_iff. tc. - intros cl hl. - unfold valid_clause. - destruct min_premise as [k0|] eqn:hk0 => //. - destruct cl as [prem [l k]] => /=. cbn in hk0. - rewrite /clsdiff in hl. - destruct (proj1 (Clauses.diff_spec _ _ _) hl) as [hlcls hl']. - eapply in_clauses_with_concl in hlcls as [lW incls]. - specialize (H _ lW). cbn -[clsdiff] in H. cbn in lW. - specialize (hv _ lW) as [vl hvl]. rewrite /level_value_above (level_value_MapsTo hvl). - rewrite (level_value_MapsTo hvl) in H; depelim H. - (* etransitivity; tea. *) - set (prem' := non_W_atoms W prem). - assert (ne : LevelExprSet.is_empty prem' = false). - { now eapply (non_W_atoms_ne W (prem, (l, k)) cls). } - set (preml := {| t_set := prem'; t_ne := ne |}). - assert (min_premise m prem ≤ min_premise m preml). - { eapply min_premise_subset. eapply non_W_atoms_subset. } - (* min_i (f(x_i)-k_i) <= max_i(f(x_i)) - min(k_i) *) - pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. - rewrite hk0 in H0. depelim H0. rename y into minpreml. - pose proof (min_premise_max_premise _ _ _ H1) as [maxpreml eqmaxp]. - pose proof (max_premise_value_spec m preml _ eqmaxp) as [amax [exmax [inmaxpre eqmaxpre]]]. - rewrite -eqmaxp in eqmaxpre. - pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. - assert (min_premise m preml ≤ Some (maxpreml - premise_min preml))%Z. - { rewrite eqminpre in H1. - specialize (amax _ inminpre). destruct amax as [k' [lk' hk']]. - depelim hk'. - pose proof (min_atom_value_levelexpr_value m exmin _ _ H2 lk'). - rewrite eqminpre H2. constructor. rewrite H3. - rewrite eqmaxpre in eqmaxp. - assert (expmin.2 <= exmin.2). specialize (apmin _ inminpre). lia. - lia. } - apply Z.leb_le. rewrite H1 in H2. depelim H2. - transitivity (k + (maxpreml - premise_min preml)). lia. - assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff)%nat. - { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. - unfold gain. cbn. - pose proof (premise_min_subset preml prem). - enough (premise_min prem <= premise_min preml) by lia. - forward H3. eapply non_W_atoms_subset. lia. } - transitivity (v_minus_w_bound W m + (gain (preml, (l, k)))). - 2:lia. - unfold gain. cbn -[max_premise_value premise_min]. - assert (k + (maxpreml - premise_min preml) = - (maxpreml + k - premise_min preml)) as ->. lia. - assert (maxpreml <= v_minus_w_bound W m). - { pose proof (v_minus_w_bound_spec W m exmax). - have [hlevels _] := (@levels_exprs_non_W_atoms W prem (level exmax)). - rewrite levelexprset_levels_spec in hlevels. - forward hlevels. - exists exmax.2. now destruct exmax. - rewrite LevelSet.diff_spec in hlevels. - destruct hlevels. - forward H4 by auto. - rewrite eqmaxp in eqmaxpre. unfold levelexpr_value in eqmaxpre. rewrite -eqmaxpre in H4. - now depelim H4. - } - lia. - Qed. +Definition sum_W W (f : LevelSet.elt -> nat) : nat := + LevelSet.fold (fun w acc => acc + f w)%nat W 0%nat. - Lemma level_value_default_def {m x v} : level_value m x = Some v -> level_value_default m x = v. - Proof. unfold level_value_default. now intros ->. Qed. +Lemma sum_W_0 {W f} l : sum_W W f = 0%nat -> LevelSet.In l W -> f l = 0%nat. +Proof. + rewrite /sum_W. + eapply LevelSetProp.fold_rec. + - intros x hin. firstorder eauto. + - intros x a s' s'' inw nins' hadd ih heq. + forward ih by lia. + intros hin. + apply hadd in hin as []; subst. lia. + now apply ih. +Qed. - Lemma level_values_in_W m m' W x : - defined_model_of W m -> - m ⩽ m' -> - LevelSet.In x W -> level_value m x ≤ level_value m' x -> - exists k k', level_value m x = Some k /\ level_value m' x = Some k' /\ (k <= k'). - Proof. - intros hwv ext hin hleq. - specialize (hwv _ hin) as x'. destruct x' as [k hl]. rewrite (level_value_MapsTo hl) in hleq. - eapply defined_model_of_ext in ext; tea. - specialize (ext _ hin) as [k' hl']. - rewrite (level_value_MapsTo hl') in hleq. depelim hleq. - do 2 eexists. intuition eauto. - now rewrite (level_value_MapsTo hl). - now rewrite (level_value_MapsTo hl'). - Qed. +Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := + sum_W W (fun w => Z.to_nat (measure_w W cls m w)). - Lemma measure_le {W cls m m'} : - defined_model_of W m -> - model_map_outside W m m' -> - m ⩽ m' -> - (measure W cls m' <= measure W cls m)%nat. - Proof. - intros hwv hout hle. - unfold measure, measure_w, sum_W. - rewrite (v_minus_w_bound_irrel _ _ hout). - rewrite !LevelSet.fold_spec. unfold flip. - eapply fold_left_le; unfold flip. 2:lia. - - intros. rewrite LevelSet_In_elements in H. - have lexx' := (model_le_values x hle). - eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. - erewrite !level_value_default_def; tea. lia. - Qed. +Lemma measure_model W cls m : + defined_model_of W m -> + let clsdiff := cls_diff cls W in + measure W cls m = 0%nat -> is_model clsdiff m. +Proof using. + intros dnf clsdiff hm. + apply Clauses.for_all_spec. tc. + intros cl hcl. + destruct (valid_clause) eqn:vc => //. + eapply invalid_clause_measure in dnf; tea. + 2:{ rewrite vc //. } + enough (measure_w W cls m (concl cl) = 0). lia. + rewrite /measure in hm. + move/(sum_W_0 (concl cl)): hm => /fwd; [|lia]. + apply Clauses.diff_spec in hcl as [clw clr]. + now eapply in_clauses_with_concl in clw as [clw incls]. +Qed. - Lemma measure_lt {W cls m m'} : - defined_model_of W m -> - model_map_outside W m m' -> - m ⩽ m' -> - (exists l, [/\ LevelSet.In l W, (0 < measure_w W cls m l)%Z & - opt_le Z.lt (level_value m l) (level_value m' l)])%Z -> - (measure W cls m' < measure W cls m)%nat. - Proof. - intros hwv hout hle. - unfold measure, measure_w, sum_W. - rewrite (v_minus_w_bound_irrel _ _ hout). - intros hlt. - rewrite !LevelSet.fold_spec. unfold flip. - eapply fold_left_ne_lt; unfold flip. - - unfold flip. intros; lia. - - unfold flip; intros; lia. - - destruct hlt as [l [hin _]]. intros he. rewrite -LevelSetProp.elements_Empty in he. lsets. - - intros. rewrite LevelSet_In_elements in H. - have lexx' := (model_le_values x hle). - eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. - erewrite !level_value_default_def; tea. lia. - - intros. rewrite LevelSet_In_elements in H. - have lexx' := (model_le_values x hle). - eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. - erewrite !level_value_default_def; tea. lia. - - destruct hlt as [l [hinl hbound hlev]]. - exists l. rewrite LevelSet_In_elements. split => //. - intros acc acc' accle. - eapply Nat.add_le_lt_mono => //. - depelim hlev. rewrite /level_value_default ?H0 ?H1 in hbound |- *. - lia. now eapply defined_model_of_value_None in H; tea. - Qed. +Lemma level_value_default_def {m x v} : level_value m x = Some v -> level_value_default m x = v. +Proof. unfold level_value_default. now intros ->. Qed. - Lemma check_model_spec_diff {cls w m w' m' w''} : - model_of w m -> - model_of w'' m -> - let cls := (cls_diff cls w) in - check_model cls (w'', m) = Some (w', m') -> - [/\ w'' ⊂_lset w', w' ⊂_lset (w'' ∪ w), - exists cl : clause, - let cll := level (concl cl) in - [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' - & (opt_le Z.lt (level_value m cll) (level_value m' cll))%Z] - & model_extension w' m m']. - Proof. - cbn; intros mof tot cm. - pose proof (clauses_conclusions_diff_left cls w (cls ⇂ w)). - apply check_model_has_invariants in cm as []. - split => //. lsets. - eapply model_of_subset. exact mof. tea. exact tot. - Qed. +Lemma level_values_in_W m m' W x : + defined_model_of W m -> + m ⩽ m' -> + LevelSet.In x W -> level_value m x ≤ level_value m' x -> + exists k k', level_value m x = Some k /\ level_value m' x = Some k' /\ (k <= k'). +Proof. + intros hwv ext hin hleq. + specialize (hwv _ hin) as x'. destruct x' as [k hl]. rewrite (level_value_MapsTo hl) in hleq. + eapply defined_model_of_ext in ext; tea. + specialize (ext _ hin) as [k' hl']. + rewrite (level_value_MapsTo hl') in hleq. depelim hleq. + do 2 eexists. intuition eauto. + now rewrite (level_value_MapsTo hl). + now rewrite (level_value_MapsTo hl'). +Qed. - Lemma valid_model_only_model W W' m cls : - forall vm : valid_model W W' m cls, - only_model_of W m -> only_model_of W (model_model vm). - Proof. - intros vm. - have incl := model_incl vm. - destruct vm as [m' mof isupd clsincl ism]. cbn. - move: isupd; rewrite /is_update_of. - destruct LevelSet.is_empty eqn:heq. now intros ->. - intros su om. - eapply strictly_updates_only_model_gen in su; tea. - eapply only_model_of_eq; tea. intro. lsets. - Qed. +Lemma measure_le {W cls m m'} : + defined_model_of W m -> + model_map_outside W m m' -> + m ⩽ m' -> + (measure W cls m' <= measure W cls m)%nat. +Proof. + intros hwv hout hle. + unfold measure, measure_w, sum_W. + rewrite (v_minus_w_bound_irrel _ _ hout). + rewrite !LevelSet.fold_spec. unfold flip. + eapply fold_left_le; unfold flip. 2:lia. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. + erewrite !level_value_default_def; tea. lia. +Qed. - Lemma valid_model_is_update_of W W' m cls : - model_of W m -> - forall vm : valid_model W W' (restrict_model W m) (cls ⇂ W), - is_update_of (cls ⇂ W) W' m (model_update m (model_model vm)). - Proof. - intros mofW vm. - have incl := model_incl vm. - destruct vm as [m' mof isupd clsincl ism]. cbn. - move: isupd. rewrite /is_update_of. - destruct LevelSet.is_empty eqn:he. - - intros <-. now rewrite model_update_restrict. - - intros su. eapply strictly_updates_restrict_model in su; tea. - Qed. +Lemma measure_lt {W cls m m'} : + defined_model_of W m -> + model_map_outside W m m' -> + m ⩽ m' -> + (exists l, [/\ LevelSet.In l W, (0 < measure_w W cls m l)%Z & + opt_le Z.lt (level_value m l) (level_value m' l)])%Z -> + (measure W cls m' < measure W cls m)%nat. +Proof. + intros hwv hout hle. + unfold measure, measure_w, sum_W. + rewrite (v_minus_w_bound_irrel _ _ hout). + intros hlt. + rewrite !LevelSet.fold_spec. unfold flip. + eapply fold_left_ne_lt; unfold flip. + - unfold flip. intros; lia. + - unfold flip; intros; lia. + - destruct hlt as [l [hin _]]. intros he. rewrite -LevelSetProp.elements_Empty in he. lsets. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. + erewrite !level_value_default_def; tea. lia. + - intros. rewrite LevelSet_In_elements in H. + have lexx' := (model_le_values x hle). + eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. + erewrite !level_value_default_def; tea. lia. + - destruct hlt as [l [hinl hbound hlev]]. + exists l. rewrite LevelSet_In_elements. split => //. + intros acc acc' accle. + eapply Nat.add_le_lt_mono => //. + depelim hlev. rewrite /level_value_default ?H0 ?H1 in hbound |- *. + lia. now eapply defined_model_of_value_None in H; tea. +Qed. - Lemma valid_model_is_update_of_eq W W' m cls cls' : - model_of W m -> - forall vm : valid_model W W' (restrict_model W m) cls, - cls =_clset (cls' ⇂ W) -> - is_update_of cls W' m (model_update m (model_model vm)). - Proof. - intros mofW vm. - have incl := model_incl vm. - destruct vm as [m' mof isupd clsincl ism]. cbn. - move: isupd. rewrite /is_update_of. - destruct LevelSet.is_empty eqn:he. - - intros <-. now rewrite model_update_restrict. - - intros su eq. rewrite eq in su. eapply strictly_updates_restrict_model in su; tea. - now rewrite eq. - Qed. +Lemma check_model_spec_diff {cls w m w' m' w''} : + model_of w m -> + model_of w'' m -> + let cls := (cls_diff cls w) in + check_model cls (w'', m) = Some (w', m') -> + [/\ w'' ⊂_lset w', w' ⊂_lset (w'' ∪ w), + exists cl : clause, + let cll := level (concl cl) in + [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' + & (opt_le Z.lt (level_value m cll) (level_value m' cll))%Z] + & model_extension w' m m']. +Proof. + cbn; intros mof tot cm. + pose proof (clauses_conclusions_diff_left cls w (cls ⇂ w)). + apply check_model_has_invariants in cm as []. + split => //. lsets. + eapply model_of_subset. exact mof. tea. exact tot. +Qed. + +Lemma valid_model_only_model W W' m cls : + forall vm : valid_model W W' m cls, + only_model_of W m -> only_model_of W (model_model vm). +Proof. + intros vm. + have incl := model_incl vm. + destruct vm as [m' mof isupd clsincl ism]. cbn. + move: isupd; rewrite /is_update_of. + destruct LevelSet.is_empty eqn:heq. now intros ->. + intros su om. + eapply strictly_updates_only_model_gen in su; tea. + eapply only_model_of_eq; tea. intro. lsets. +Qed. + +Lemma valid_model_is_update_of W W' m cls : + model_of W m -> + forall vm : valid_model W W' (restrict_model W m) (cls ⇂ W), + is_update_of (cls ⇂ W) W' m (model_update m (model_model vm)). +Proof. + intros mofW vm. + have incl := model_incl vm. + destruct vm as [m' mof isupd clsincl ism]. cbn. + move: isupd. rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros <-. now rewrite model_update_restrict. + - intros su. eapply strictly_updates_restrict_model in su; tea. +Qed. + +Lemma valid_model_is_update_of_eq W W' m cls cls' : + model_of W m -> + forall vm : valid_model W W' (restrict_model W m) cls, + cls =_clset (cls' ⇂ W) -> + is_update_of cls W' m (model_update m (model_model vm)). +Proof. + intros mofW vm. + have incl := model_incl vm. + destruct vm as [m' mof isupd clsincl ism]. cbn. + move: isupd. rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he. + - intros <-. now rewrite model_update_restrict. + - intros su eq. rewrite eq in su. eapply strictly_updates_restrict_model in su; tea. + now rewrite eq. +Qed. + +Section InnerLoop. Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) (loop : forall (V' U' : LevelSet.t) (cls' : clauses) (minit m : model) From f3a75818a9b1bfcace2dbcdfe52a93ed1c367ad1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 11 Sep 2025 18:20:41 +0200 Subject: [PATCH 047/164] Enforce clauses to be enabled in the abstract model --- common/theories/LoopChecking/Deciders.v | 72 +++++++++++++++++-- common/theories/LoopChecking/Model.v | 30 +++++--- common/theories/LoopChecking/Models.v | 32 +++++---- .../LoopChecking/PartialLoopChecking.v | 30 ++++---- 4 files changed, 116 insertions(+), 48 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index e2dd67aa2..16d7b887e 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -1,5 +1,5 @@ (* Distributed under the terms of the MIT license. *) -From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import ssreflect ssrfun ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils. @@ -252,6 +252,24 @@ Proof. funelim (check cls cl) => //. Qed. +Arguments symmetry {A R Symmetric} {x y}. + +Lemma check_looping {cls cl v isl} : + check cls cl = IsLooping v isl -> ~ (exists V, clauses_sem V cls). +Proof. + move/check_entails_looping/clauses_sem_entails_all => h [] V /h. + rewrite interp_add_prems. lia. +Qed. + +Lemma check_valid_looping {cls cl v isl m} : + enabled_clauses m cls -> + is_model cls m -> + check cls cl = IsLooping v isl -> False. +Proof. + move=> en /(valid_clauses_model _ _ en) csem /check_looping; apply. + now eexists. +Qed. + Theorem check_invalid {cls cl} : check cls cl = Invalid -> ~ entails cls cl. Proof. @@ -320,7 +338,7 @@ Proof. repeat split. - lsets. - lsets. - - have ms := min_model_map_spec k cls' (model_model m). + - have ms := min_model_map_spec cls' (model_model m). set (map := min_model_map _ _) in *. destruct ms as [hm [hcls hext]]. rewrite LevelSet.union_spec => [] []. @@ -329,7 +347,7 @@ Proof. now move: hcls => /(_ _ hin _ ink). * move/(model_of_V m k). move=> [] x /hext. firstorder. - - have ms := min_model_map_spec k cls' (model_model m). + - have ms := min_model_map_spec cls' (model_model m). set (map := min_model_map _ _) in *. destruct ms as [hm [hcls hext]]. rewrite LevelSet.union_spec. @@ -344,9 +362,38 @@ Proof. forward ho by now exists v. now right. Qed. +Lemma in_levels le prems : LevelExprSet.In le prems -> LevelSet.In le (levels prems). +Proof. + destruct le. intros hin. + apply levelexprset_levels_spec. now exists z. +Qed. + +Lemma min_model_map_enabled m cls cls' : + enabled_clauses m cls -> + enabled_clauses (min_model_map m cls') (Clauses.union cls cls'). +Proof. + intros en cl. + rewrite Clauses.union_spec => -[]. + - move/en; rewrite /enabled_clause => -[z hmin]. + have := @min_premise_pres m (min_model_map m cls') (premise cl) => /fwd. + apply min_model_map_acc. + rewrite hmin => h; depelim h. now exists y. + - intros hin; rewrite /enabled_clause. + have [hm [incl hext]] := min_model_map_spec cls' m. + have [hle [minp [inp ->]]] := min_premise_spec (min_model_map m cls') (premise cl). + move: (incl _ hin). move/(_ minp) => /fwd. + { apply clause_levels_spec. left. now apply in_levels. } + move=> [k hmap]. + specialize (hm minp k hmap) as [_ hm _]. + destruct minp. + move: hm => /(_ _ hin)/(_ _ inp). intros le; depelim le. + exists (y - z). now rewrite /min_atom_value (level_value_MapsTo hmap). +Qed. + Module CorrectModel. Record t {V cls} := { the_model : model; + enabled_model : enabled_clauses the_model cls; only_model_of_V : only_model_of V the_model; model_updates : LevelSet.t; clauses_declared : clauses_levels cls ⊂_lset V; @@ -355,11 +402,12 @@ Module CorrectModel. #[local] Obligation Tactic := program_simpl. Equations? infer_extension_correct {V W init cls} (m : valid_model V W init cls) + (enabled : enabled_clauses init cls) (hincl : only_model_of V init) (hs : clauses_levels cls ⊂_lset V) (cls' : clauses) (hs' : clauses_levels cls' ⊂_lset V) : (t V (Clauses.union cls cls')) + premises := - infer_extension_correct m hincl hs cls' hs' with infer_extension m hincl hs cls' := + infer_extension_correct m enabled hincl hs cls' hs' with infer_extension m hincl hs cls' := | Loop u _ => inr u | Model w m' _ => inl {| @@ -368,6 +416,10 @@ Module CorrectModel. model_updates := w; clauses_declared := _; model_valid := {| model_model := m'.(model_model) |} |}. Proof. + - eapply min_model_map_enabled. + eapply enabled_clauses_ext. + have mupd := I.model_updates m. eapply is_update_of_ext in mupd. exact mupd. + exact enabled. - have := valid_model_only_model _ _ _ _ m hincl. now apply only_model_of_min_model_map. - intros x; rewrite clauses_levels_spec; rw Clauses.union_spec. @@ -385,8 +437,9 @@ Module CorrectModel. Equations? infer_extension_valid {V cls} (m : t V cls) cls' : option (t V (Clauses.union cls cls') + premises) := infer_extension_valid m cls' with inspect (LevelSet.subset (clauses_levels cls') V) := | exist false heq => None - | exist true heq := Some (infer_extension_correct (model_valid m) _ _ cls' _). + | exist true heq := Some (infer_extension_correct (model_valid m) _ _ _ cls' _). Proof. + - apply enabled_model. - apply only_model_of_V. - now apply m. - now apply LevelSet.subset_spec in heq. @@ -408,6 +461,7 @@ Module Abstract. refine {| the_model := LevelMap.empty _; only_model_of_V := _; model_updates := LevelSet.empty; |}. + - red. intros cl hin; clsets. - intros l. split. lsets. intros [x hm]. now eapply LevelMapFact.F.empty_mapsto_iff in hm. - now intros l; rewrite clauses_levels_spec. @@ -428,6 +482,12 @@ Module Abstract. refine {| the_model := LevelMap.add l None m.(model).(the_model); only_model_of_V := _; model_updates := m.(model).(model_updates); |}. + - eapply enabled_clauses_ext. 2:apply m.(model).(enabled_model). + intros l' k hm. exists k. split => //. 2:reflexivity. + rewrite LevelMapFact.F.add_mapsto_iff. right. split => //. + intros ->. apply LevelSetProp.FM.not_mem_iff in hneq. apply hneq. + have hv := only_model_of_V m.(model). apply hv. + now exists k. - intros k. rewrite LevelSet.add_spec /LevelSet.E.eq. rw LevelMapFact.F.add_mapsto_iff. have hyp := m.(model).(only_model_of_V) k. @@ -437,7 +497,7 @@ Module Abstract. apply LevelSetFact.not_mem_iff in hneq. contradiction. - have hyp := m.(model).(clauses_declared). lsets. - destruct m as [levels clauses vm]; cbn in *. - destruct vm as [init omofV W incl vm]. + destruct vm as [init en omofV W incl vm]. destruct vm as [M mofV mupd mcls mok]. cbn in *. refine {| model_model := LevelMap.add l None M |}. * intros k. rewrite LevelSet.add_spec LevelMapFact.F.add_in_iff. firstorder. now left. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index a00fd2e87..eaead2b6f 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -60,7 +60,7 @@ *) -From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import ssreflect ssrbool ssrfun ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils. @@ -1602,9 +1602,8 @@ Module Model (LS : LevelSets). strictly_updates cls W m m' -> model_of W m'. Proof. - move/strictly_updates_model_of_gen/(_ LevelSet.empty). - intros H. forward H. apply model_of_empty. - rewrite LevelSetProp.empty_union_1 in H => //. lsets. + move/strictly_updates_model_of_gen/(_ LevelSet.empty)/(_ (model_of_empty _)). + rewrite LevelSetProp.empty_union_1 //. lsets. Qed. Lemma strictly_updates_only_model_gen cls W m m' : @@ -1617,11 +1616,11 @@ Module Model (LS : LevelSets). destruct cl as [prems [concl cl]]. destruct H0 as [minv [hmin ? heq]]. setoid_rewrite heq. setoid_rewrite LevelMapFact.F.add_mapsto_iff. cbn. - destruct (Level.eq_dec concl x). - { subst. rewrite LevelSet.union_spec LevelSet.singleton_spec. + case: (Level.eq_dec concl x). + { move=> ->. rewrite LevelSet.union_spec LevelSet.singleton_spec. firstorder; exists (Some (cl + minv)); left; split => //. } { rewrite LevelSet.union_spec LevelSet.singleton_spec /LevelSet.E.eq. - firstorder. subst x. congruence. } + firstorder. congruence. } - intros W' tot. eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. eapply only_model_of_eq; tea. intros x; lsets. @@ -2045,11 +2044,9 @@ Lemma is_update_of_empty cls m : * left. split => //. intros []. congruence. destruct H2 as [yrest hin]. eapply restrict_model_spec in hin as []. contradiction. - intros mtot mof -> hm. specialize (IHstrictly_updates1 mtot mof eq_refl hm). - specialize (IHstrictly_updates2 (model_update mtot m')). have model_of : model_of W (model_update mtot m'). by apply model_of_model_update. - specialize (IHstrictly_updates2 model_of eq_refl). - forward IHstrictly_updates2. + move: (IHstrictly_updates2 (model_update mtot m') model_of eq_refl) => /fwd h. { rewrite hm in H. eapply strictly_updates_from_restrict in H; tea. 2:eapply clauses_conclusions_restrict_clauses. now rewrite restrict_model_update. } @@ -2057,7 +2054,7 @@ Lemma is_update_of_empty cls m : have eqm : (model_update (model_update mtot m') m'') =m model_update mtot m''. { eapply model_update_trans. eapply strictly_updates_ext in H0. intros l [k hin]. apply H0 in hin as [k' []]. now exists k'. } - now rewrite eqm in IHstrictly_updates2. + now rewrite eqm in h. Qed. Lemma strictly_updates_restrict_model cls W W' m' : @@ -3045,6 +3042,17 @@ Lemma is_update_of_empty cls m : lia. Qed. + Lemma valid_clauses_model model cls : + enabled_clauses model cls -> + is_model cls model -> + clauses_sem (valuation_of_model model) cls. + Proof. + move=> en ism cl hin. + apply valid_clause_model. + now apply en. + now move/Clauses.for_all_spec: ism; apply. + Qed. + Lemma init_model_enabled cls : enabled_clauses (max_clause_premises cls) cls. Proof. unfold enabled_clauses. diff --git a/common/theories/LoopChecking/Models.v b/common/theories/LoopChecking/Models.v index a15b514f4..a4b1e301a 100644 --- a/common/theories/LoopChecking/Models.v +++ b/common/theories/LoopChecking/Models.v @@ -434,25 +434,27 @@ Module Models (LS : LevelSets). destruct hext as [l' []]; exists l'; split => //. constructor. } Qed. - Lemma min_model_map_acc l cls m : + Lemma min_model_map_acc cls m : let map := min_model_map m cls in - (forall k, LevelMap.MapsTo l k map -> max_of_map l k m) /\ + (forall l k, LevelMap.MapsTo l k map -> max_of_map l k m) /\ m ⩽ map. Proof. cbn. rewrite /min_model_map. eapply ClausesProp.fold_rec. 2:{ intros. destruct H2 as [hf hin]. - have [hm hnin] := min_model_clause_spec l x a. split. - intros k. + intros l k. + have [hm hnin] := min_model_clause_spec l x a. move/hm. rewrite /is_max_of_clause_model. intros [[ism' ism] hasm]. destruct hasm; eauto. intros kl'. move/hin => [k' [hmk' lek']]. red in ism. specialize (ism _ hmk'). now transitivity k'. transitivity a => //. - intros l' k ha. specialize (hnin l' k (or_introl ha)). + intros l k ha. + have [hm hnin] := min_model_clause_spec l x a. + specialize (hnin l k (or_introl ha)). exact hnin. } split; [|reflexivity]. - intros k hin k' hin'. + intros l k hin k' hin'. eapply LevelMapFact.F.MapsTo_fun in hin; tea. subst; reflexivity. Qed. @@ -468,9 +470,9 @@ Module Models (LS : LevelSets). subst; reflexivity. Qed. - Lemma min_model_map_spec l cls m : + Lemma min_model_map_spec cls m : let map := min_model_map m cls in - (forall k, LevelMap.MapsTo l k map -> + (forall l k, LevelMap.MapsTo l k map -> [/\ (exists cl, Clauses.In cl cls /\ is_in_clause l k cl) \/ LevelMap.MapsTo l k m, (forall cl, Clauses.In cl cls -> max_of_premises l k (premise cl)) & max_of_map l k m]) /\ (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l map) /\ @@ -478,7 +480,7 @@ Module Models (LS : LevelSets). Proof. cbn. rewrite /min_model_map. - have hgen : forall cls m, (forall k, LevelMap.MapsTo l k (Clauses.fold min_model_clause cls m) -> + have hgen : forall cls m, (forall l k, LevelMap.MapsTo l k (Clauses.fold min_model_clause cls m) -> [/\ (exists cl : Clauses.elt, Clauses.In cl cls /\ is_in_clause l k cl) \/ LevelMap.MapsTo l k m, forall cl : Clauses.elt, Clauses.In cl cls -> max_of_premises l k (premise cl) @@ -486,7 +488,7 @@ Module Models (LS : LevelSets). (forall cl, Clauses.In cl cls -> forall l, LevelSet.In l (clause_levels cl) -> LevelMap.In l (Clauses.fold min_model_clause cls m)) /\ m ⩽ Clauses.fold min_model_clause cls m. 2:{ specialize (hgen cls m). destruct hgen as [hgen [hcls H]]; split; eauto. - intros k hm. specialize (hgen k hm) as [] => //. + intros l k hm. specialize (hgen l k hm) as [] => //. split => //. eapply max_of_map_ext; tea. } clear. intros cls m. @@ -514,13 +516,13 @@ Module Models (LS : LevelSets). have := min_model_clause_spec l' x a. cbn. move=> [] _ /(_ l' k' (or_introl ina)). clear. firstorder. } - intros k. + intros l k. have := min_model_clause_spec l x a. cbn. intros [hm hm'] hmk. destruct (hm _ hmk). split => //. { destruct H0; eauto. { left; exists x. split => //. apply hadd. now left. } - { specialize (ih _ H0) as []. destruct H1; eauto. left. + { specialize (ih _ _ H0) as []. destruct H1; eauto. left. move: H1 => [] w []; exists w; split; eauto. apply hadd. now right. } } { move=> cl /hadd => [] [<-|hin']. { now move: H => []. } @@ -530,7 +532,7 @@ Module Models (LS : LevelSets). forward ihcls. { eapply clause_levels_spec. left. eapply levelexprset_levels_spec. now exists k'. } destruct ihcls as [ka ihcls]. - specialize (ih _ ihcls) as [ihm ihcls' maxm]. + specialize (ih _ _ ihcls) as [ihm ihcls' maxm]. specialize (ihcls' _ hin' _ h). transitivity ka => //. destruct H as [mp mmap]. @@ -545,9 +547,9 @@ Module Models (LS : LevelSets). intros incl om l. split. - move=> /om => [] [k inm]. - have [hmap [hcls hext]] := min_model_map_spec l cls m. + have [hmap [hcls hext]] := min_model_map_spec cls m. specialize (hext l k inm). firstorder. - - have [hmap [hcls hext]] := min_model_map_spec l cls m. + - have [hmap [hcls hext]] := min_model_map_spec cls m. move=> [] x /hmap => [] [excl allcl maxm]. red in maxm. destruct excl as [[cl [incls incl']]|inm]. diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index a64d656f2..f24efd8d0 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -300,8 +300,9 @@ Proof. assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff)%nat. { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. unfold gain. cbn. - pose proof (premise_min_subset preml prem). - forward H. eapply non_W_atoms_subset. lia. } + have := premise_min_subset preml prem => /fwd. + { eapply non_W_atoms_subset. } + lia. } eapply Z.lt_le_trans with (bound + Z.of_nat (Z.to_nat (gain (preml, (l, k)))))%Z; try lia. unfold gain; cbn. enough ((level_value_default m l) < (v_minus_w_bound W m) + (k - premise_min preml))%Z. lia. @@ -323,12 +324,12 @@ Proof. { eapply premise_min_subset. eapply non_W_atoms_subset. } assert (y <= maxpreml - (premise_min preml))%Z. { rewrite eqpminpre. rewrite H2 in eqminpre; symmetry in eqminpre. - pose proof (min_atom_value_levelexpr_value m exmin). rewrite /levelexpr_value in H4. + move: (min_atom_value_levelexpr_value m exmin). rewrite /levelexpr_value. specialize (amax _ inminpre) as amax'. rewrite eqmaxpre in amax'. destruct amax' as [vexmin [eqexmin ltexmin]]. - assert (expmin.2 <= exmin.2). specialize (apmin _ inminpre). lia. - specialize (H4 _ _ eqminpre eqexmin). rewrite H4. depelim ltexmin. - rewrite -eqmaxpre in H6. noconf H6. + have hle : expmin.2 <= exmin.2 by move: (apmin _ inminpre); lia. + move/(_ _ _ eqminpre eqexmin) => ->. depelim ltexmin. + rewrite -eqmaxpre in H5. noconf H5. lia. } transitivity (k + (maxpreml - (premise_min preml)))%Z. lia. assert (k + (maxpreml - (premise_min preml)) = @@ -336,12 +337,11 @@ Proof. enough (maxpreml <= (v_minus_w_bound W m))%Z. lia. { have vm := v_minus_w_bound_spec W m exmax. unfold levelexpr_value in eqmaxpre. rewrite -eqmaxpre in vm. - have [hlevels _] := (@levels_exprs_non_W_atoms W prem (level exmax)). - rewrite levelexprset_levels_spec in hlevels. - forward hlevels. - exists exmax.2. now destruct exmax. - rewrite LevelSet.diff_spec in hlevels. - destruct hlevels as [_ nw]. specialize (vm nw). depelim vm. lia. } + have := (@levels_exprs_non_W_atoms W prem (level exmax)). + rewrite levelexprset_levels_spec => -[] /fwd. + { exists exmax.2. now destruct exmax. } + rewrite LevelSet.diff_spec => [] [_ nw] _. + specialize (vm nw). depelim vm. lia. } Qed. Definition option_of_result {V U m cls} (r : result V U m cls) : option model := @@ -385,10 +385,8 @@ Proof. rewrite /sum_W. eapply LevelSetProp.fold_rec. - intros x hin. firstorder eauto. - - intros x a s' s'' inw nins' hadd ih heq. - forward ih by lia. - intros hin. - apply hadd in hin as []; subst. lia. + - move=> x a s' s'' inw nins' hadd + afx. + move/fwd; [lia|] => ih /hadd[] eq. now move: afx; rewrite eq. now apply ih. Qed. From a024eeab4a08ef967e13bdfb5b6e8d1db65c4243 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 11 Sep 2025 23:12:51 +0200 Subject: [PATCH 048/164] Finish proving "add" --- common/theories/LoopChecking/Common.v | 8 + common/theories/LoopChecking/Deciders.v | 93 ++++++- common/theories/LoopChecking/HornClauses.v | 7 - common/theories/LoopChecking/Interfaces.v | 14 +- common/theories/Universes.v | 26 +- template-rocq/_RocqProject.in | 4 +- template-rocq/src/g_template_rocq.ml | 40 +-- template-rocq/theories/ExtractLoopChecking.v | 2 +- template-rocq/theories/TemplateLoopChecking.v | 228 +++++++++++++++--- 9 files changed, 323 insertions(+), 99 deletions(-) diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v index 4ce95ed28..28b9e79ef 100644 --- a/common/theories/LoopChecking/Common.v +++ b/common/theories/LoopChecking/Common.v @@ -17,6 +17,14 @@ Notation fwd := (ltac:(move=> /(_ _)/Wrap[])). Arguments exist {A P}. Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. +#[program] Global Instance reflect_eq_Z : ReflectEq Z := { + eqb := Z.eqb + }. +Next Obligation. + destruct (Z.eqb_spec x y); constructor => //. +Qed. + + Definition option_map2 {A} (f : A -> A -> A) (o o' : option A) : option A := match o, o' with | Some x, Some y => Some (f x y) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 16d7b887e..d2140c50c 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -392,12 +392,12 @@ Qed. Module CorrectModel. Record t {V cls} := - { the_model : model; - enabled_model : enabled_clauses the_model cls; - only_model_of_V : only_model_of V the_model; + { initial_model : model; + enabled_model : enabled_clauses initial_model cls; + only_model_of_V : only_model_of V initial_model; model_updates : LevelSet.t; clauses_declared : clauses_levels cls ⊂_lset V; - model_valid : valid_model V model_updates the_model cls }. + model_valid : valid_model V model_updates initial_model cls }. Arguments t : clear implicits. #[local] Obligation Tactic := program_simpl. @@ -411,7 +411,7 @@ Module CorrectModel. | Loop u _ => inr u | Model w m' _ => inl {| - the_model := min_model_map m.(model_model) cls'; + initial_model := min_model_map m.(model_model) cls'; only_model_of_V := _; model_updates := w; clauses_declared := _; model_valid := {| model_model := m'.(model_model) |} |}. @@ -458,7 +458,7 @@ Module Abstract. clauses := Clauses.empty; model := _ |}. Next Obligation. - refine {| the_model := LevelMap.empty _; + refine {| initial_model := LevelMap.empty _; only_model_of_V := _; model_updates := LevelSet.empty; |}. - red. intros cl hin; clsets. @@ -474,12 +474,76 @@ Module Abstract. intros x hin. now apply Clauses.empty_spec in hin. Qed. + Lemma levelmap_add_comm {A} l o l' o' (m : LevelMap.t A) : l <> l' -> + LevelMap.add l o (LevelMap.add l' o' m) =m + LevelMap.add l' o' (LevelMap.add l o m). + Proof. + intros neq. + apply LevelMapFact.F.Equal_mapsto_iff => k' o''. + rewrite !LevelMapFact.F.add_mapsto_iff /Level.eq. + firstorder; subst. right. split => //. auto. + left; firstorder. + right; firstorder. + Qed. + + Lemma strictly_updates_add clauses W m m' l : + ~ LevelSet.In l (clauses_levels clauses) -> + strictly_updates clauses W m m' -> + strictly_updates clauses W (LevelMap.add l None m) (LevelMap.add l None m'). + Proof. + intros hnin; elim; clear -hnin. + - move=> m [prems [concl k]] m' hin [] v [] hmin habov hm'. + constructor => //. exists v. split => //. + * erewrite min_premise_preserved; tea. + intros. + have neq : x <> l. + { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (concl, k)). + split => //. apply clause_levels_spec. now left. } + rewrite /level_value. + rewrite LevelMapFact.F.add_neq_o; auto. + * have neq : concl <> l. + { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (l, k)). + split => //. apply clause_levels_spec. now right. } + rewrite /level_value_above /level_value LevelMapFact.F.add_neq_o; auto. + * have neq : concl <> l. + { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (l, k)). + split => //. apply clause_levels_spec. now right. } + now rewrite levelmap_add_comm // hm'. + - move=>> su ihsu su' ihsu'. + econstructor; tea. + Qed. + + Lemma is_model_add clauses l m : + ~ LevelSet.In l (clauses_levels clauses) -> + is_model clauses m -> + is_model clauses (LevelMap.add l None m). + Proof. + move=> hnin ism. + eapply Clauses.for_all_spec; tc => cl hin'. + move/Clauses.for_all_spec: ism => /(_ _ hin'). + destruct cl as [prems [concl k]]. + move/valid_clause_elim => he. + apply valid_clause_intro => z. + erewrite (@min_premise_preserved _ m); tea. + - move/he. + have neq : concl <> l. + { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (l, k)). + split => //. apply clause_levels_spec. now right. } + rewrite /level_value LevelMapFact.F.add_neq_o; auto. + - intros x hin. + have neq : x <> l. + { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (concl, k)). + split => //. apply clause_levels_spec. now left. } + rewrite /level_value. + rewrite LevelMapFact.F.add_neq_o; auto. + Qed. + Equations? declare_level (m : t) (l : Level.t) : option t := declare_level m l with inspect (LevelSet.mem l m.(levels)) := | exist true _ => None | exist false hneq => Some {| levels := LevelSet.add l m.(levels); clauses := m.(clauses) |}. Proof. - refine {| the_model := LevelMap.add l None m.(model).(the_model); + refine {| initial_model := LevelMap.add l None m.(model).(initial_model); only_model_of_V := _; model_updates := m.(model).(model_updates); |}. - eapply enabled_clauses_ext. 2:apply m.(model).(enabled_model). @@ -505,9 +569,14 @@ Module Abstract. rewrite /is_update_of. destruct (LevelSet.is_empty) eqn:hw. now intros ->. - { apply (todo "strict update weakening"). } + { eapply levelset_not_Empty_is_empty in hw. + apply LevelSetFact.not_mem_iff in hneq. + apply strictly_updates_add. + now move/incl. } * lsets. - * apply (todo "cannot activate more clauses"). + * apply LevelSetFact.not_mem_iff in hneq. + apply is_model_add; tea. + now move/incl. Qed. Equations enforce_clauses (m : t) (cls : Clauses.t) : option (t + premises) := @@ -528,9 +597,9 @@ Module LoopChecking (LS : LevelSets). Notation univ := LS.LevelExprSet.nonEmptyLevelExprSet. Inductive constraint_type := UnivEq | UnivLe. - Notation constraint := (univ * constraint_type * univ). + Definition constraint := (univ * constraint_type * univ). - Definition enforce_constraint (cstr : constraint) (cls : Clauses.t) : Clauses.t := + Local Definition enforce_constraint (cstr : constraint) (cls : Clauses.t) : Clauses.t := let '(l, d, r) := cstr in match d with | UnivLe => @@ -562,6 +631,6 @@ Module LoopChecking (LS : LevelSets). (* Returns the valuation of the model: a minimal assignement from levels to constraints that make the enforced clauses valid. *) - Definition valuation m := Model.valuation_of_model m.(Impl.Abstract.model).(Impl.CorrectModel.the_model). + Definition valuation m := Model.valuation_of_model m.(Impl.Abstract.model).(Impl.CorrectModel.initial_model). End LoopChecking. \ No newline at end of file diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 4a1c5f89e..30e0513f7 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -142,13 +142,6 @@ Module Clauses (LS : LevelSets). destruct (LevelExpr.compare_spec t0 t1); repeat constructor; tas. now subst. Qed. - #[program] Global Instance reflect_eq_Z : ReflectEq Z := { - eqb := Z.eqb - }. - Next Obligation. - destruct (Z.eqb_spec x y); constructor => //. - Qed. - Global Instance reflect_t : ReflectEq t := reflect_prod _ _ . Definition eq_dec : forall (l1 l2 : t), {l1 = l2} + {l1 <> l2} := Classes.eq_dec. diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 9b160cba9..4f6fcd30f 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -41,14 +41,15 @@ End FMapOrderedType_from_UsualOrderedType. Module Type LevelOrderedType. Include UsualOrderedType. - - Parameter reflect_eq : ReflectEq t. - #[local] Existing Instance reflect_eq. Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. +End LevelOrderedType. - Parameter to_string : t -> string. +Module Type LevelOrderedTypeWithReflect. + Include LevelOrderedType. -End LevelOrderedType. + Parameter reflect_eq : ReflectEq t. + Parameter to_string : t -> string. +End LevelOrderedTypeWithReflect. Module Type FMapOTInterface (E : UsualOrderedType). Module OT := FMapOrderedType_from_UsualOrderedType E. @@ -75,14 +76,13 @@ End LevelExprSet_fun. Module Type LevelSets. (* Signature of levels: decidable, ordered type *) - Declare Module Level : LevelOrderedType. + Declare Module Level : LevelOrderedTypeWithReflect. Declare Module LevelSet : LevelSet_fun Level. Declare Module LevelExpr : LevelExprItf Level. Declare Module LevelExprSet : LevelExprSet_fun Level LevelExpr. Declare Module LevelMap : FMapOTInterface Level. End LevelSets. - Module FromLevelSets (LS : LevelSets). Export LS. diff --git a/common/theories/Universes.v b/common/theories/Universes.v index fbb2f2856..db02017af 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -158,6 +158,12 @@ Module Level. Definition eq_dec : forall (l1 l2 : t), {l1 = l2}+{l1 <> l2} := Classes.eq_dec. + #[refine] Instance reflect_eq : ReflectEq t := + { ReflectEq.eqb := eqb }. + Proof. + intros x y. apply reflect_reflectProp, eqb_spec. + Qed. + End Level. Module LevelSet := MSetAVL.Make Level. @@ -342,9 +348,6 @@ Module LevelExprSet. Record nonEmptyLevelExprSet := { t_set : LevelExprSet.t ; t_ne : LevelExprSet.is_empty t_set = false }. - - - End LevelExprSet. Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. @@ -2963,14 +2966,17 @@ Definition print_constraint_type d := | ConstraintType.Eq => "=" end. +Definition print_level_constraint '(l1, d, l2) := + string_of_level l1 ^ " " ^ + print_constraint_type d ^ " " ^ string_of_level l2. + Definition print_level_constraint_set t := - print_list (fun '(l1, d, l2) => - string_of_level l1 ^ " " ^ - print_constraint_type d ^ " " ^ string_of_level l2) + print_list print_level_constraint " /\ " (ConstraintSet.elements t). +Definition print_univ_constraint '(l1, d, l2) := + string_of_universe (l1 : Universe.t) ^ " " ^ + print_constraint_type d ^ " " ^ string_of_universe (l2 : Universe.t). + Definition print_univ_constraint_set t := - print_list (fun '(l1, d, l2) => - string_of_universe (l1 : Universe.t) ^ " " ^ - print_constraint_type d ^ " " ^ string_of_universe (l2 : Universe.t)) - " /\ " (UnivConstraintSet.elements t). + print_list print_univ_constraint " /\ " (UnivConstraintSet.elements t). diff --git a/template-rocq/_RocqProject.in b/template-rocq/_RocqProject.in index 6cd5b754c..d32a3f643 100644 --- a/template-rocq/_RocqProject.in +++ b/template-rocq/_RocqProject.in @@ -3,8 +3,8 @@ -I . # Generic loop checking algorithm -theories/LoopChecking.v -theories/TemplateLoopChecking.v +# theories/LoopChecking.v +# theories/TemplateLoopChecking.v # Basic Ast files theories/Ast.v diff --git a/template-rocq/src/g_template_rocq.ml b/template-rocq/src/g_template_rocq.ml index 2d0b77341..a9187abbd 100644 --- a/template-rocq/src/g_template_rocq.ml +++ b/template-rocq/src/g_template_rocq.ml @@ -1,6 +1,6 @@ let _ = Mltop.add_known_module "rocq-metarocq-template-rocq.plugin" -# 4 "src/g_template_coq.mlg" +# 4 "src/g_template_rocq.mlg" open Attributes @@ -73,7 +73,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template Vernacextend.TyNil)))), (let coqpp_body def poly = Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 67 "src/g_template_coq.mlg" +# 67 "src/g_template_rocq.mlg" fun ~pm -> let (env, evm) = fresh_env () in let (evm, def) = Constrintern.interp_open_constr env evm def in let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmTestQuote) in @@ -82,7 +82,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template run_template_program ~pm env evm ~poly pgm ) ~pm) in fun def ?loc ~atts () -> coqpp_body def (Attributes.parse -# 66 "src/g_template_coq.mlg" +# 66 "src/g_template_rocq.mlg" polymorphic atts)), None))] @@ -103,7 +103,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template Vernacextend.TyNil)))))), (let coqpp_body name def poly = Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 77 "src/g_template_coq.mlg" +# 77 "src/g_template_rocq.mlg" fun ~pm -> let (env, evm) = fresh_env () in let (evm, def) = Constrintern.interp_open_constr env evm def in let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteDefinition) in @@ -112,7 +112,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template run_template_program ~pm env evm ~poly pgm ) ~pm) in fun name def ?loc ~atts () -> coqpp_body name def (Attributes.parse -# 76 "src/g_template_coq.mlg" +# 76 "src/g_template_rocq.mlg" polymorphic atts)), None))] @@ -138,7 +138,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template Vernacextend.TyNil))))))))), (let coqpp_body name rd def poly = Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 87 "src/g_template_coq.mlg" +# 87 "src/g_template_rocq.mlg" fun ~pm -> let (env, evm) = fresh_env () in let (evm, def) = Constrintern.interp_open_constr env evm def in (* TODO : implem quoting of tactic reductions so that we can use ptmQuoteDefinitionRed *) @@ -149,7 +149,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template run_template_program ~pm env evm ~poly pgm ) ~pm) in fun name rd def ?loc ~atts () -> coqpp_body name rd def (Attributes.parse -# 86 "src/g_template_coq.mlg" +# 86 "src/g_template_rocq.mlg" polymorphic atts)), None))] @@ -172,7 +172,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template Vernacextend.TyNil))))))), (let coqpp_body name def poly = Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 99 "src/g_template_coq.mlg" +# 99 "src/g_template_rocq.mlg" fun ~pm -> let (env, evm) = fresh_env () in let (evm, def) = Constrintern.interp_open_constr env evm def in let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteRecDefinition) in @@ -181,7 +181,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template run_template_program ~pm env evm ~poly pgm ) ~pm) in fun name def ?loc ~atts () -> coqpp_body name def (Attributes.parse -# 98 "src/g_template_coq.mlg" +# 98 "src/g_template_rocq.mlg" polymorphic atts)), None))] @@ -199,7 +199,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template Vernacextend.TyNil)))), (let coqpp_body def poly = Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 109 "src/g_template_coq.mlg" +# 109 "src/g_template_rocq.mlg" fun ~pm -> let (env, evm) = fresh_env () in let (evm, def) = Constrintern.interp_open_constr env evm def in let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmTestUnquote) in @@ -208,7 +208,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template run_template_program ~pm env evm ~poly pgm ) ~pm) in fun def ?loc ~atts () -> coqpp_body def (Attributes.parse -# 108 "src/g_template_coq.mlg" +# 108 "src/g_template_rocq.mlg" polymorphic atts)), None))] @@ -229,7 +229,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template Vernacextend.TyNil)))))), (let coqpp_body name def poly = Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 119 "src/g_template_coq.mlg" +# 119 "src/g_template_rocq.mlg" fun ~pm -> let (env, evm) = fresh_env () in let (evm, def) = Constrintern.interp_open_constr env evm def in let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmMkDefinition) in @@ -239,7 +239,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template run_template_program ~pm env evm ~poly pgm ) ~pm) in fun name def ?loc ~atts () -> coqpp_body name def (Attributes.parse -# 118 "src/g_template_coq.mlg" +# 118 "src/g_template_rocq.mlg" polymorphic atts)), None))] @@ -257,7 +257,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template Vernacextend.TyNil)))), (let coqpp_body def poly = Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 130 "src/g_template_coq.mlg" +# 130 "src/g_template_rocq.mlg" fun ~pm -> let (env, evm) = fresh_env () in let (evm, def) = Constrintern.interp_open_constr env evm def in let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmMkInductive) in @@ -266,7 +266,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template run_template_program ~pm env evm ~poly pgm ) ~pm) in fun def ?loc ~atts () -> coqpp_body def (Attributes.parse -# 129 "src/g_template_coq.mlg" +# 129 "src/g_template_rocq.mlg" polymorphic atts)), None))] @@ -282,7 +282,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template Vernacextend.TyNil))), (let coqpp_body def poly = Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 140 "src/g_template_coq.mlg" +# 140 "src/g_template_rocq.mlg" fun ~pm -> let (env, evm) = fresh_env () in let (pgm, ctx) = Constrintern.interp_constr env evm def in let evm = Evd.from_ctx ctx in @@ -290,7 +290,7 @@ let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template run_template_program ~pm env evm ~poly pgm ) ~pm) in fun def ?loc ~atts () -> coqpp_body def (Attributes.parse -# 139 "src/g_template_coq.mlg" +# 139 "src/g_template_rocq.mlg" polymorphic atts)), None))] @@ -302,7 +302,7 @@ let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "Template Extend.TUentry (Genarg.get_arg_tag wit_tactic), Tacentries.TyNil))), (fun c tac ist -> -# 152 "src/g_template_coq.mlg" +# 152 "src/g_template_rocq.mlg" (* quote the given term, pass the result to t *) Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -320,7 +320,7 @@ let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "Template Extend.TUentry (Genarg.get_arg_tag wit_tactic), Tacentries.TyNil))), (fun c tac ist -> -# 164 "src/g_template_coq.mlg" +# 164 "src/g_template_rocq.mlg" Proofview.Goal.enter (begin fun gl -> let env = Proofview.Goal.env gl in let evm = Proofview.Goal.sigma gl in @@ -336,7 +336,7 @@ let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "Template Tacentries.TyArg (Extend.TUentry (Genarg.get_arg_tag wit_constr), Tacentries.TyArg (Extend.TUentry (Genarg.get_arg_tag wit_tactic), Tacentries.TyNil))), (fun c tac ist -> -# 176 "src/g_template_coq.mlg" +# 176 "src/g_template_rocq.mlg" let open Proofview.Notations in Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (name, poly) -> Proofview.Goal.enter (begin fun gl -> diff --git a/template-rocq/theories/ExtractLoopChecking.v b/template-rocq/theories/ExtractLoopChecking.v index 5d197983b..d181b66cd 100644 --- a/template-rocq/theories/ExtractLoopChecking.v +++ b/template-rocq/theories/ExtractLoopChecking.v @@ -1,6 +1,6 @@ From Equations Require Import Equations. From Coq Require Import ExtrOcamlBasic ExtrOcamlNatInt ExtrOcamlZInt. -From MetaCoq.Template Require Import LoopChecking. +From MetaRocq.Common.LoopChecking Require Import Common Interfaces Deciders. Extract Constant BinInt.Z.of_nat => "(fun x -> x)". Extract Constant BinInt.Z.to_nat => "(fun x -> x)". diff --git a/template-rocq/theories/TemplateLoopChecking.v b/template-rocq/theories/TemplateLoopChecking.v index 3bddcae79..727f8b26d 100644 --- a/template-rocq/theories/TemplateLoopChecking.v +++ b/template-rocq/theories/TemplateLoopChecking.v @@ -5,7 +5,7 @@ From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils. From MetaRocq.Common Require Import Universes. -From MetaRocq.Template Require Import LoopChecking. +From MetaRocq.Common.LoopChecking Require Import Common Interfaces Deciders. From Equations Require Import Equations. Set Equations Transparent. @@ -15,9 +15,7 @@ Module MoreLevel. Import Universes. Include Level. - Definition reflect_eq : ReflectEq t := reflect_level. Definition to_string := string_of_level. - End MoreLevel. Module LevelMap. @@ -25,13 +23,149 @@ Module LevelMap. Include FMapAVL.Make OT. End LevelMap. +Module LevelExprZ. + Definition t := (Level.t * Z)%type. + Local Open Scope Z_scope. + + Definition succ (l : t) : t := (fst l, Z.succ (snd l)). + + Definition eq : t -> t -> Prop := eq. + + Definition eq_equiv : Equivalence eq := _. + + Inductive lt_ : t -> t -> Prop := + | ltLevelExpr1 l n n' : (n < n') -> lt_ (l, n) (l, n') + | ltLevelExpr2 l l' b b' : Level.lt l l' -> lt_ (l, b) (l', b'). + Derive Signature for lt_. + Definition lt := lt_. + + Global Instance lt_strorder : StrictOrder lt. + Proof. + constructor. + - intros x X; inversion X. subst. lia. subst. + eapply Level.lt_strorder; eassumption. + - intros x y z X1 X2; invs X1; invs X2; constructor; tea. + etransitivity; tea. + etransitivity; tea. + Qed. + + Definition lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt. + intros x x' H1 y y' H2; now rewrite H1 H2. + Qed. + + Definition compare (x y : t) : comparison := + match x, y with + | (l1, b1), (l2, b2) => + match Level.compare l1 l2 with + | Eq => Z.compare b1 b2 + | x => x + end + end. + + Definition compare_spec : + forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y). + Proof. + intros [? ?] [? ?]; cbn; repeat constructor. + destruct (Level.compare_spec t0 t1); repeat constructor; tas. + subst. + destruct (Z.compare_spec z z0); repeat constructor; tas. congruence. + Qed. + + Global Instance reflect_t : ReflectEq t := reflect_prod _ _ . + + Definition eq_dec : forall (l1 l2 : t), {l1 = l2} + {l1 <> l2} := Classes.eq_dec. + + Definition eq_leibniz (x y : t) : eq x y -> x = y := id. + +End LevelExprZ. + +Module LevelExprZSet. + Include MSetList.MakeWithLeibniz LevelExprZ. + + Definition levels (e : t) := + fold (fun le => LevelSet.add (fst le)) e LevelSet.empty. + + Record nonEmptyLevelExprSet + := { t_set : t ; + t_ne : is_empty t_set = false }. +End LevelExprZSet. +Module LevelExprZSetFacts := WFactsOn LevelExprZ LevelExprZSet. +Module LevelExprZSetProp := MSetProperties.OrdProperties LevelExprZSet. + +Module LevelSet. + Include MakeWithLeibniz Level. +End LevelSet. +Module LS <: LevelSets. + Module Level := MoreLevel . + Module LevelSet := LevelSet. + Module LevelExpr := LevelExprZ. + Module LevelExprSet := LevelExprZSet. + Module LevelMap := LevelMap. +End LS. + Module UnivLoopChecking. - Module LoopCheck := LoopChecking MoreLevel LevelSet LevelExpr LevelExprSet LevelMap. + Module LoopCheck := LoopChecking LS. Include LoopCheck. End UnivLoopChecking. Import UnivLoopChecking. +Definition to_levelexprzset (u : LevelExprSet.t) : LS.LevelExprSet.t := + LevelExprSet.fold (fun '(l, k) => LS.LevelExprSet.add (l, Z.of_nat k)) u LS.LevelExprSet.empty. + +Lemma to_levelexprzset_spec u : + forall l k, LevelExprSet.In (l, k) u -> LevelExprZSet.In (l, Z.of_nat k) (to_levelexprzset u). +Proof. + intros l k. + rewrite /to_levelexprzset. + apply LevelExprSetProp.fold_rec. + - now move=> s' hs' /hs'. + - move=> x a s' s'' hin hnin hadd ih /hadd []. + * intros ->. apply LevelExprZSet.add_spec. now left. + * intros hin'. destruct x. apply LevelExprZSet.add_spec. now right. +Qed. + +Program Definition to_atoms (u : Universe.t) : LevelExprZSet.nonEmptyLevelExprSet := + {| LevelExprZSet.t_set := to_levelexprzset u |}. +Next Obligation. + destruct u. cbn. + destruct (LevelExprZSet.is_empty _) eqn:he => //. + apply LevelExprZSet.is_empty_spec in he. + assert (LevelExprSet.is_empty t_set). + apply LevelExprSet.is_empty_spec. intros x hin. + destruct x. eapply (he (t, Z.of_nat n)). + now apply to_levelexprzset_spec. + congruence. +Qed. + +Definition from_levelexprzset (u : LS.LevelExprSet.t) : LevelExprSet.t := + LS.LevelExprSet.fold (fun '(l, k) =>LevelExprSet.add (l, Z.to_nat k)) u LevelExprSet.empty. + +Lemma from_levelexprzset_spec u : + forall l k, LevelExprZSet.In (l, k) u -> LevelExprSet.In (l, Z.to_nat k) (from_levelexprzset u). +Proof. + intros l k. + rewrite /from_levelexprzset. + apply LevelExprZSetProp.P.fold_rec. + - now move=> s' hs' /hs'. + - move=> x a s' s'' hin hnin hadd ih /hadd []. + * intros ->. apply LevelExprSet.add_spec. now left. + * intros hin'. destruct x. apply LevelExprSet.add_spec. now right. +Qed. + +Program Definition from_atoms (u : univ) : Universe.t := + {| LevelExprSet.t_set := from_levelexprzset (LS.LevelExprSet.t_set u) |}. +Next Obligation. + destruct u. cbn. + destruct (LevelExprSet.is_empty _) eqn:he => //. + apply LevelExprSet.is_empty_spec in he. + assert (LevelExprZSet.is_empty t_set). + apply LevelExprZSet.is_empty_spec. intros x hin. + destruct x. eapply (he (t, Z.to_nat z)). + now apply from_levelexprzset_spec. + congruence. +Qed. + Definition to_constraint (x : UnivConstraint.t) : constraint := let '(l, d, r) := x in let '(l, d, r) := match d with @@ -40,7 +174,9 @@ Definition to_constraint (x : UnivConstraint.t) : constraint := if (k enforce_constraint (to_constraint cstr) acc) cstrs (clauses_of_list []). - -Definition enforce_level_constraints (cstrs : ConstraintSet.t) : clauses := - ConstraintSet.fold (fun cstr acc => enforce_constraint (level_constraint_to_constraint cstr) acc) cstrs (clauses_of_list []). + in (to_atoms l, d, to_atoms r). Declare Scope levelnat_scope. Delimit Scope levelnat_scope with levelnat. @@ -77,28 +207,6 @@ Module LevelNatMapNotation. End LevelNatMapNotation. Import LevelNatMapNotation. Arguments LevelMap.Bst {elt} this%levelnat {is_bst}. -(* -Definition valuation_of_model (m : model) : LevelMap.t nat := - let max := LevelMap.fold (fun l k acc => Nat.max k acc) m 0%Z in - LevelMap.fold (fun l k acc => LevelMap.add l (max - k)%nat acc) m (LevelMap.empty _). - -Definition print_level_nat_map (m : LevelMap.t nat) := - let list := LevelMap.elements m in - print_list (fun '(l, w) => string_of_level l ^ " -> " ^ string_of_nat w) nl list. - -Definition print_lset (l : LevelSet.t) := - let list := LevelSet.elements l in - print_list string_of_level " " list. - -Arguments model_model {V m cls}. - -Definition print_result {V cls} (m : infer_result V cls) := - match m with - | Loop => "looping" - | Model w m _ => "satisfiable with model: " ^ print_level_nat_map (model_model m) ^ nl ^ " W = " ^ - print_lset w - ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model (model_model m)) - end. *) From MetaRocq.Template Require Import All Core. Definition time : forall {A} {B : A -> Type}, string -> (forall x : A, B x) -> forall x : A, B x := @@ -115,14 +223,58 @@ Universes u v. #[universes(polymorphic)] Definition check_le@{u v} : unit := tt. +Definition univ_model := Impl.Abstract.t. + +(* We ignore errors here, which can happen only if the levels are already declared *) +Definition declare_levels (m : univ_model) (l : LevelSet.t) := + LevelSet.fold (fun l m => match declare_level l m with None => m | Some m => m end) l m. + +Definition enforce_level_constraints (m : univ_model) (l : ConstraintSet.t) := + ConstraintSet.fold (fun c m => + match m with + | inl m => + let c := (level_constraint_to_constraint c) in + match enforce c m with + | None => (inr (c, None)) + | Some (inl m) => (inl m) + | Some (inr u) => (inr (c, Some u)) + end + | inr err => inr err + end) l (inl m). + +Import Impl.I.Model.Model.Clauses.FLS. + +Definition of_constraint (c : constraint) : UnivConstraint.t := + let '(l, d, r) := c in + let d' := match d with + | UnivLe => ConstraintType.Le 0 + | UnivEq => ConstraintType.Eq + end + in + (from_atoms l, d', from_atoms r). + +Definition print_result (r : model + (constraint × option univ)) : string := + match r with + | inl m => "Model: \n" ++ print_level_nat_map (valuation m) + | inr (c, None) => "Constraint uses undeclared levels: " ++ + Universes.print_univ_constraint (of_constraint c) + | inr (c, Some u) => "Constraint " ++ + Universes.print_univ_constraint (of_constraint c) ++ " entails a loop on " ++ + string_of_universe (from_atoms u) + end. + Definition test : TemplateMonad unit := tmQuoteUniverses >>= fun ctx => - let clauses := time "building clauses" enforce_level_constraints (snd ctx) in - tmMsg (print_clauses clauses) ;; + let m := time "declaring levels" (declare_levels init_model) (fst ctx) in + let m' := time "enforcing clauses" (enforce_level_constraints m) (snd ctx) in + tmMsg (print_result m') ;; + (* tmMsg (print_clauses clauses) ;; *) (* tmMsg (string_of_nat (LevelSet.cardinal (fst ctx)));; *) (* ++ " universes and " ++ string_of_nat (ConstraintSet.cardinal (snd ctx)) ++ " constraints") ;; *) tmMsg "done". +(* MetaRocq Run test. *) + (* let result := time "loop-checking" TemplateLoopChecking.UnivLoopChecking.infer clauses in *) (* tmMsg (TemplateLoopChecking.UnivLoopChecking.print_result result). *) From MetaRocq.Template Require Import Pretty. @@ -136,7 +288,3 @@ MetaRocq Run (ctx <- tmQuoteUniverses ;; Definition make_level (n : ident) : Level.t := Level.level n. -Definition check_constraint (cls : clauses) c := - - - From 0c428b0c282543c095cf0baef7fd4d41f11b5c41 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 12 Sep 2025 12:02:09 +0200 Subject: [PATCH 049/164] Add another layer of abstraction for constraints -> clauses --- common/theories/LoopChecking/Deciders.v | 58 +++- common/theories/LoopChecking/Model.v | 32 +- .../theories/LoopChecking/UnivLoopChecking.v | 300 ++++++++++++++++++ template-rocq/theories/TemplateLoopChecking.v | 206 ------------ 4 files changed, 373 insertions(+), 223 deletions(-) create mode 100644 template-rocq/theories/LoopChecking/UnivLoopChecking.v diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index d2140c50c..0005e041d 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -565,8 +565,7 @@ Module Abstract. destruct vm as [M mofV mupd mcls mok]. cbn in *. refine {| model_model := LevelMap.add l None M |}. * intros k. rewrite LevelSet.add_spec LevelMapFact.F.add_in_iff. firstorder. now left. - * move: mupd. - rewrite /is_update_of. + * move: mupd; rewrite /is_update_of. destruct (LevelSet.is_empty) eqn:hw. now intros ->. { eapply levelset_not_Empty_is_empty in hw. @@ -599,19 +598,46 @@ Module LoopChecking (LS : LevelSets). Inductive constraint_type := UnivEq | UnivLe. Definition constraint := (univ * constraint_type * univ). - Local Definition enforce_constraint (cstr : constraint) (cls : Clauses.t) : Clauses.t := + Definition clauses_of_le l r := + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) (LevelExprSet.t_set l) Clauses.empty. + + Lemma clauses_of_le_spec l r : + forall cl, Clauses.In cl (clauses_of_le l r) <-> + LevelExprSet.Exists (fun lk => cl = (r, lk)) l. + Proof. + intros cl; rewrite /clauses_of_le. + eapply LevelExprSetProp.fold_rec. + - move=> s' he; split. clsets. + move=> [] x []; lesets. + - move=> x a s' s'' hin hnin hadd ih. + rewrite Clauses.add_spec. split. + * move=> [->|]. firstorder. + rewrite ih. firstorder. + * move=> [] x' [] /hadd[<-|]; auto. + rewrite ih. right; firstorder. + Qed. + + Local Definition to_clauses (cstr : constraint) : Clauses.t := let '(l, d, r) := cstr in match d with - | UnivLe => - LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) (LevelExprSet.t_set l) cls - | UnivEq => - let cls := - LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) (LevelExprSet.t_set l) cls - in - let cls' := - LevelExprSet.fold (fun rk acc => Clauses.add (l, rk) acc) (LevelExprSet.t_set r) cls - in cls' + | UnivLe => clauses_of_le l r + | UnivEq => Clauses.union (clauses_of_le l r) (clauses_of_le r l) + end. + + Lemma to_clauses_spec l d r : + forall cl, Clauses.In cl (to_clauses (l, d, r)) <-> + match d with + | UnivLe => LevelExprSet.Exists (fun lk => cl = (r, lk)) l + | UnivEq => LevelExprSet.Exists (fun lk => cl = (r, lk)) l \/ LevelExprSet.Exists (fun rk => cl = (l, rk)) r end. + Proof. + intros cl. destruct d => //=. + - rewrite Clauses.union_spec. + have := clauses_of_le_spec l r cl. + have := clauses_of_le_spec r l cl. + firstorder. + - apply clauses_of_le_spec. + Qed. Definition init_model := Impl.Abstract.init_model. @@ -621,16 +647,16 @@ Module LoopChecking (LS : LevelSets). (* Returns either a model or a looping universe, i.e. such that u >= u + 1 is implied by the constraint *) Definition enforce c (m : model) : option (model + univ) := - Impl.Abstract.enforce_clauses m (enforce_constraint c Clauses.empty). + Impl.Abstract.enforce_clauses m (to_clauses c). - (* Returns true is the clause is valid in the model and all its possible consistent extensions. + (* Returns true is the constraint is valid in the model and all its possible consistent extensions. Returns false if the constraint results in an inconsistent set of constraints or it simply is not valid. *) Definition check m c := - Impl.check_clauses m.(Impl.Abstract.clauses) (enforce_constraint c Clauses.empty). + Impl.check_clauses m.(Impl.Abstract.clauses) (to_clauses c). (* Returns the valuation of the model: a minimal assignement from levels to constraints that make the enforced clauses valid. *) Definition valuation m := Model.valuation_of_model m.(Impl.Abstract.model).(Impl.CorrectModel.initial_model). -End LoopChecking. \ No newline at end of file +End LoopChecking. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index eaead2b6f..cabc2525d 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -42,7 +42,7 @@ a loop, i.e. a situation where [cls ⊢ a → a + 1] for some (non-empty) set of atoms [a] (i.e. a contradiction when seen through the valuations). - Alltogether, by choosing appropriate initial models (defined in [Models.v]), this allows to decide + Altogether, by choosing appropriate initial models (defined in [Models.v]), this allows to decide satisfiability and validity. For satisfiabiliy [cls, prems → concl + k|=] we try to find a model of [cls /\ prems → concl + k] @@ -1096,6 +1096,36 @@ Module Model (LS : LevelSets). now apply premise_min_spec_aux. Qed. + + Definition to_positive (s : premises) : premises := + let z := premise_min s in + add_prems (- z) s. + + Lemma to_positive_spec (s : premises) : forall l k, LevelExprSet.In (l, k) s <-> LevelExprSet.In (l, k - premise_min s) (to_positive s). + Proof. + intros l k; rewrite /to_positive. + rewrite In_add_prems. split. + - move=> hin; exists (l, k). split => //. + - move=> [] [l' k'] [] hin heq. noconf heq. + now have -> : k = k' by lia. + Qed. + + Lemma to_positive_spec_2 (s : premises) : forall l k, LevelExprSet.In (l, k) (to_positive s) <-> LevelExprSet.In (l, k + premise_min s) s. + Proof. + intros l k; rewrite /to_positive. + rewrite In_add_prems. split. + - move=> [] [l' k'] [] hin heq. noconf heq. + now have <- : k' = k' + - premise_min s + premise_min s by lia. + - move=> hin; exists (l, k + premise_min s). split => //. + cbn. lia_f_equal. + Qed. + + Lemma to_positive_pos (s : premises) : forall l k, LevelExprSet.In (l, k) (to_positive s) -> k >= 0. + Proof. + move=> l k /to_positive_spec_2. + move: (premise_min_spec s) => [] + hex hs; move /(_ _ hs). cbn. lia. + Qed. + Lemma premise_max_spec_aux s k : premise_max s = k -> (forall x, LevelExprSet.In x s -> x.2 <= k) /\ diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v new file mode 100644 index 000000000..f5a20a3ba --- /dev/null +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -0,0 +1,300 @@ +(* Distributed under the terms of the MIT license. *) +(* This module provides an instantiation of the deciders for universe checking, + i.e. for constraints on non-empty level expressions (l, k) where k ∈ 𝐍 *) + +From Stdlib Require Import ssreflect ssrbool. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils. +From MetaRocq.Common Require Import Universes. +From MetaRocq.Common.LoopChecking Require Import Common Interfaces Deciders. +From Equations Require Import Equations. +Set Equations Transparent. + +Import Universes. + +Module MoreLevel. + Import Universes. + Include Level. + + Definition to_string := string_of_level. +End MoreLevel. + +Module LevelMap. + Module OT := FMapOrderedType_from_UsualOrderedType Level. + Include FMapAVL.Make OT. +End LevelMap. + +Module LevelExprZ. + Definition t := (Level.t * Z)%type. + Local Open Scope Z_scope. + + Definition succ (l : t) : t := (fst l, Z.succ (snd l)). + + Definition eq : t -> t -> Prop := eq. + + Definition eq_equiv : Equivalence eq := _. + + Inductive lt_ : t -> t -> Prop := + | ltLevelExpr1 l n n' : (n < n') -> lt_ (l, n) (l, n') + | ltLevelExpr2 l l' b b' : Level.lt l l' -> lt_ (l, b) (l', b'). + Derive Signature for lt_. + Definition lt := lt_. + + Global Instance lt_strorder : StrictOrder lt. + Proof. + constructor. + - intros x X; inversion X. subst. lia. subst. + eapply Level.lt_strorder; eassumption. + - intros x y z X1 X2; invs X1; invs X2; constructor; tea. + etransitivity; tea. + etransitivity; tea. + Qed. + + Definition lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt. + intros x x' H1 y y' H2; now rewrite H1 H2. + Qed. + + Definition compare (x y : t) : comparison := + match x, y with + | (l1, b1), (l2, b2) => + match Level.compare l1 l2 with + | Eq => Z.compare b1 b2 + | x => x + end + end. + + Definition compare_spec : + forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y). + Proof. + intros [? ?] [? ?]; cbn; repeat constructor. + destruct (Level.compare_spec t0 t1); repeat constructor; tas. + subst. + destruct (Z.compare_spec z z0); repeat constructor; tas. congruence. + Qed. + + Global Instance reflect_t : ReflectEq t := reflect_prod _ _ . + + Definition eq_dec : forall (l1 l2 : t), {l1 = l2} + {l1 <> l2} := Classes.eq_dec. + + Definition eq_leibniz (x y : t) : eq x y -> x = y := id. + +End LevelExprZ. + +Module LevelExprZSet. + Include MSetList.MakeWithLeibniz LevelExprZ. + + Definition levels (e : t) := + fold (fun le => LevelSet.add (fst le)) e LevelSet.empty. + + Record nonEmptyLevelExprSet + := { t_set : t ; + t_ne : is_empty t_set = false }. +End LevelExprZSet. +Module LevelExprZSetFacts := WFactsOn LevelExprZ LevelExprZSet. +Module LevelExprZSetProp := MSetProperties.OrdProperties LevelExprZSet. + +Module LevelSet. + Include MakeWithLeibniz Level. +End LevelSet. +Module LS <: LevelSets. + Module Level := MoreLevel . + Module LevelSet := LevelSet. + Module LevelExpr := LevelExprZ. + Module LevelExprSet := LevelExprZSet. + Module LevelMap := LevelMap. +End LS. + +Definition to_levelexprzset (u : LevelExprSet.t) : LS.LevelExprSet.t := + LevelExprSet.fold (fun '(l, k) => LS.LevelExprSet.add (l, Z.of_nat k)) u LS.LevelExprSet.empty. + +Lemma to_levelexprzset_spec_1 u : + forall l k, LevelExprSet.In (l, k) u -> LevelExprZSet.In (l, Z.of_nat k) (to_levelexprzset u). +Proof. + intros l k. + rewrite /to_levelexprzset. + apply LevelExprSetProp.fold_rec. + - move=> s' hs'; now move=> /hs'. + - move=> x a s' s'' hin hnin hadd ih /hadd []. + + intros ->. apply LevelExprZSet.add_spec. now left. + + intros hin'. destruct x. apply LevelExprZSet.add_spec. now right. +Qed. + +Lemma to_levelexprzset_spec_2 u : + forall l k, LevelExprZSet.In (l, k) (to_levelexprzset u) -> LevelExprSet.In (l, Z.to_nat k) u /\ (0 <= k)%Z. +Proof. + intros l k. + rewrite /to_levelexprzset. + apply LevelExprSetProp.fold_rec. + - now move=> s' hs' /LevelExprZSetFacts.empty_iff. + - move=> x a s' s'' hin hnin hadd ih. + destruct x as [l' k']. + rewrite LS.LevelExprSet.add_spec => -[]. + + intros [= -> eq]. subst k. split. apply hadd. now left. lia. + + intros hin'. move: (ih hin') => []; split => //. apply hadd; now right. +Qed. + +Program Definition to_atoms (u : Universe.t) : LevelExprZSet.nonEmptyLevelExprSet := + {| LevelExprZSet.t_set := to_levelexprzset u |}. +Next Obligation. + destruct u. cbn. + destruct (LevelExprZSet.is_empty _) eqn:he => //. + apply LevelExprZSet.is_empty_spec in he. + assert (LevelExprSet.is_empty t_set). + apply LevelExprSet.is_empty_spec. intros x hin. + destruct x. eapply (he (t, Z.of_nat n)). + now apply to_levelexprzset_spec_1. + congruence. +Qed. + +Definition from_levelexprzset (u : LS.LevelExprSet.t) : LevelExprSet.t := + LS.LevelExprSet.fold (fun '(l, k) => LevelExprSet.add (l, Z.to_nat k)) u LevelExprSet.empty. + +Lemma from_levelexprzset_spec u : + forall l k, LevelExprZSet.In (l, k) u -> LevelExprSet.In (l, Z.to_nat k) (from_levelexprzset u). +Proof. + intros l k. + rewrite /from_levelexprzset. + apply LevelExprZSetProp.P.fold_rec. + - now move=> s' hs' /hs'. + - move=> x a s' s'' hin hnin hadd ih /hadd []. + * intros ->. apply LevelExprSet.add_spec. now left. + * intros hin'. destruct x. apply LevelExprSet.add_spec. now right. +Qed. + +Lemma from_levelexprzset_spec_2 u : + forall l k, LevelExprSet.In (l, k) (from_levelexprzset u) -> exists z, LevelExprZSet.In (l, z) u /\ k = Z.to_nat z. +Proof. + intros l k. + rewrite /from_levelexprzset. + apply LevelExprZSetProp.P.fold_rec. + - now move=> s' hs' /LevelExprSetFact.empty_iff. + - move=> x a s' s'' hin hnin hadd ih. + destruct x as [l' k']. + rewrite LevelExprSet.add_spec => -[]. + + intros [= -> eq]. subst k. exists k'. split => //. apply hadd. now left. + + intros hin'. move: (ih hin') => [z [hin'' ->]]. exists z. split => //. + apply hadd. now right. +Qed. + +Program Definition from_atoms (u : LS.LevelExprSet.nonEmptyLevelExprSet) : Universe.t := + {| LevelExprSet.t_set := from_levelexprzset (LS.LevelExprSet.t_set u) |}. +Next Obligation. + destruct u. cbn. + destruct (LevelExprSet.is_empty _) eqn:he => //. + apply LevelExprSet.is_empty_spec in he. + assert (LevelExprZSet.is_empty t_set). + apply LevelExprZSet.is_empty_spec. intros x hin. + destruct x. eapply (he (t, Z.to_nat z)). + now apply from_levelexprzset_spec. + congruence. +Qed. + + +Module UnivLoopChecking. + Module LoopCheck := LoopChecking LS. + + Definition to_constraint (x : UnivConstraint.t) : LoopCheck.constraint := + let '(l, d, r) := x in + let '(l, d, r) := match d with + | ConstraintType.Eq => (l, LoopCheck.UnivEq, r) + | ConstraintType.Le k => + if (k (Universe.make' l, LoopCheck.UnivEq, Universe.make' r) + | ConstraintType.Le k => + if (k + Clauses.Subset (LoopCheck.to_clauses (to_constraint c)) (LoopCheck.Impl.Abstract.clauses model) }. + + Module C := LoopCheck.Impl.I.Model.Model.Clauses. + Import C. + + Lemma exists_to_atoms a u : + LevelExprSet.Exists (fun lk : LevelExprSet.elt => a = lk) (to_atoms u) -> + Universes.LevelExprSet.Exists (fun lk => a = (fst lk, Z.of_nat (snd lk))) u. + Proof. + rewrite /to_atoms; cbn; move=> [] [l k] [] hin ->. + move/to_levelexprzset_spec_2: hin => [] hin hpos. + exists (l, Z.to_nat k). split => //=. + rewrite Z2Nat.id //. + Qed. + + Lemma exists_to_atoms_2 a (u : Universe.t) : + Universes.LevelExprSet.Exists (fun lk => a = lk) u -> + LevelExprSet.Exists (fun lk : LevelExprSet.elt => a = (lk.1, Z.to_nat lk.2)) (to_atoms u). + Proof. + rewrite /to_atoms; cbn; move=> [] [l k] [] hin ->. + move/to_levelexprzset_spec_1: hin => hin. + exists (l, Z.of_nat k). split => //=. + rewrite Nat2Z.id //. + Qed. + + Equations? init_model : univ_model := + init_model := {| model := LoopCheck.init_model; + constraints := UnivConstraintSet.empty |}. + Proof. split; try ucsets. + move=> hyp; apply UnivConstraintSetFact.empty_iff. + destruct c as [[l d] r]. destruct d; cbn in hyp. + destruct Z.ltb. cbn in hyp. + move: hyp. rewrite /Clauses.Subset. + rw LoopCheck.clauses_of_le_spec. + move=> h. + have h' := fun a e => h _ (exists_to_atoms_2 _ _ e). + specialize (hyp ()) apply hyp. + 2:{ } + de +clset. + + (* We ignore errors here, which can happen only if the levels are already declared *) + Definition declare_levels (m : univ_model) (l : LevelSet.t) := + LevelSet.fold (fun l m => match LoopCheck.declare_level l m with None => m | Some m => m end) l m. + + Definition enforce_level_constraints (m : univ_model) (l : ConstraintSet.t) := + ConstraintSet.fold (fun c m => + match m with + | inl m => + let c := (level_constraint_to_constraint c) in + match LoopCheck.enforce c m with + | None => (inr (c, None)) + | Some (inl m) => (inl m) + | Some (inr u) => (inr (c, Some u)) + end + | inr err => inr err + end) l (inl m). + + Import LoopCheck.Impl.I.Model.Model.Clauses.FLS. + + Definition of_constraint (c : LoopCheck.constraint) : UnivConstraint.t := + let '(l, d, r) := c in + let d' := match d with + | LoopCheck.UnivLe => ConstraintType.Le 0 + | LoopCheck.UnivEq => ConstraintType.Eq + end + in + (from_atoms l, d', from_atoms r). + + Definition enforce (c : UnivConstraint.t) (m : univ_model) := + match LoopCheck.enforce (to_constraint c) m with + | + + + + + +End UnivLoopChecking. diff --git a/template-rocq/theories/TemplateLoopChecking.v b/template-rocq/theories/TemplateLoopChecking.v index 727f8b26d..a527667b0 100644 --- a/template-rocq/theories/TemplateLoopChecking.v +++ b/template-rocq/theories/TemplateLoopChecking.v @@ -9,184 +9,6 @@ From MetaRocq.Common.LoopChecking Require Import Common Interfaces Deciders. From Equations Require Import Equations. Set Equations Transparent. -Import Universes. - -Module MoreLevel. - Import Universes. - Include Level. - - Definition to_string := string_of_level. -End MoreLevel. - -Module LevelMap. - Module OT := FMapOrderedType_from_UsualOrderedType Level. - Include FMapAVL.Make OT. -End LevelMap. - -Module LevelExprZ. - Definition t := (Level.t * Z)%type. - Local Open Scope Z_scope. - - Definition succ (l : t) : t := (fst l, Z.succ (snd l)). - - Definition eq : t -> t -> Prop := eq. - - Definition eq_equiv : Equivalence eq := _. - - Inductive lt_ : t -> t -> Prop := - | ltLevelExpr1 l n n' : (n < n') -> lt_ (l, n) (l, n') - | ltLevelExpr2 l l' b b' : Level.lt l l' -> lt_ (l, b) (l', b'). - Derive Signature for lt_. - Definition lt := lt_. - - Global Instance lt_strorder : StrictOrder lt. - Proof. - constructor. - - intros x X; inversion X. subst. lia. subst. - eapply Level.lt_strorder; eassumption. - - intros x y z X1 X2; invs X1; invs X2; constructor; tea. - etransitivity; tea. - etransitivity; tea. - Qed. - - Definition lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt. - intros x x' H1 y y' H2; now rewrite H1 H2. - Qed. - - Definition compare (x y : t) : comparison := - match x, y with - | (l1, b1), (l2, b2) => - match Level.compare l1 l2 with - | Eq => Z.compare b1 b2 - | x => x - end - end. - - Definition compare_spec : - forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y). - Proof. - intros [? ?] [? ?]; cbn; repeat constructor. - destruct (Level.compare_spec t0 t1); repeat constructor; tas. - subst. - destruct (Z.compare_spec z z0); repeat constructor; tas. congruence. - Qed. - - Global Instance reflect_t : ReflectEq t := reflect_prod _ _ . - - Definition eq_dec : forall (l1 l2 : t), {l1 = l2} + {l1 <> l2} := Classes.eq_dec. - - Definition eq_leibniz (x y : t) : eq x y -> x = y := id. - -End LevelExprZ. - -Module LevelExprZSet. - Include MSetList.MakeWithLeibniz LevelExprZ. - - Definition levels (e : t) := - fold (fun le => LevelSet.add (fst le)) e LevelSet.empty. - - Record nonEmptyLevelExprSet - := { t_set : t ; - t_ne : is_empty t_set = false }. -End LevelExprZSet. -Module LevelExprZSetFacts := WFactsOn LevelExprZ LevelExprZSet. -Module LevelExprZSetProp := MSetProperties.OrdProperties LevelExprZSet. - -Module LevelSet. - Include MakeWithLeibniz Level. -End LevelSet. -Module LS <: LevelSets. - Module Level := MoreLevel . - Module LevelSet := LevelSet. - Module LevelExpr := LevelExprZ. - Module LevelExprSet := LevelExprZSet. - Module LevelMap := LevelMap. -End LS. - -Module UnivLoopChecking. - Module LoopCheck := LoopChecking LS. - Include LoopCheck. -End UnivLoopChecking. - -Import UnivLoopChecking. - -Definition to_levelexprzset (u : LevelExprSet.t) : LS.LevelExprSet.t := - LevelExprSet.fold (fun '(l, k) => LS.LevelExprSet.add (l, Z.of_nat k)) u LS.LevelExprSet.empty. - -Lemma to_levelexprzset_spec u : - forall l k, LevelExprSet.In (l, k) u -> LevelExprZSet.In (l, Z.of_nat k) (to_levelexprzset u). -Proof. - intros l k. - rewrite /to_levelexprzset. - apply LevelExprSetProp.fold_rec. - - now move=> s' hs' /hs'. - - move=> x a s' s'' hin hnin hadd ih /hadd []. - * intros ->. apply LevelExprZSet.add_spec. now left. - * intros hin'. destruct x. apply LevelExprZSet.add_spec. now right. -Qed. - -Program Definition to_atoms (u : Universe.t) : LevelExprZSet.nonEmptyLevelExprSet := - {| LevelExprZSet.t_set := to_levelexprzset u |}. -Next Obligation. - destruct u. cbn. - destruct (LevelExprZSet.is_empty _) eqn:he => //. - apply LevelExprZSet.is_empty_spec in he. - assert (LevelExprSet.is_empty t_set). - apply LevelExprSet.is_empty_spec. intros x hin. - destruct x. eapply (he (t, Z.of_nat n)). - now apply to_levelexprzset_spec. - congruence. -Qed. - -Definition from_levelexprzset (u : LS.LevelExprSet.t) : LevelExprSet.t := - LS.LevelExprSet.fold (fun '(l, k) =>LevelExprSet.add (l, Z.to_nat k)) u LevelExprSet.empty. - -Lemma from_levelexprzset_spec u : - forall l k, LevelExprZSet.In (l, k) u -> LevelExprSet.In (l, Z.to_nat k) (from_levelexprzset u). -Proof. - intros l k. - rewrite /from_levelexprzset. - apply LevelExprZSetProp.P.fold_rec. - - now move=> s' hs' /hs'. - - move=> x a s' s'' hin hnin hadd ih /hadd []. - * intros ->. apply LevelExprSet.add_spec. now left. - * intros hin'. destruct x. apply LevelExprSet.add_spec. now right. -Qed. - -Program Definition from_atoms (u : univ) : Universe.t := - {| LevelExprSet.t_set := from_levelexprzset (LS.LevelExprSet.t_set u) |}. -Next Obligation. - destruct u. cbn. - destruct (LevelExprSet.is_empty _) eqn:he => //. - apply LevelExprSet.is_empty_spec in he. - assert (LevelExprZSet.is_empty t_set). - apply LevelExprZSet.is_empty_spec. intros x hin. - destruct x. eapply (he (t, Z.to_nat z)). - now apply from_levelexprzset_spec. - congruence. -Qed. - -Definition to_constraint (x : UnivConstraint.t) : constraint := - let '(l, d, r) := x in - let '(l, d, r) := match d with - | ConstraintType.Eq => (l, UnivEq, r) - | ConstraintType.Le k => - if (k (Universe.make' l, UnivEq, Universe.make' r) - | ConstraintType.Le k => - if (k match declare_level l m with None => m | Some m => m end) l m. - -Definition enforce_level_constraints (m : univ_model) (l : ConstraintSet.t) := - ConstraintSet.fold (fun c m => - match m with - | inl m => - let c := (level_constraint_to_constraint c) in - match enforce c m with - | None => (inr (c, None)) - | Some (inl m) => (inl m) - | Some (inr u) => (inr (c, Some u)) - end - | inr err => inr err - end) l (inl m). - -Import Impl.I.Model.Model.Clauses.FLS. - -Definition of_constraint (c : constraint) : UnivConstraint.t := - let '(l, d, r) := c in - let d' := match d with - | UnivLe => ConstraintType.Le 0 - | UnivEq => ConstraintType.Eq - end - in - (from_atoms l, d', from_atoms r). - Definition print_result (r : model + (constraint × option univ)) : string := match r with | inl m => "Model: \n" ++ print_level_nat_map (valuation m) From 38cbca707e0373927204e3657b8896e6702d6806 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 13 Sep 2025 19:27:09 +0200 Subject: [PATCH 050/164] Before renamings --- common/theories/LoopChecking/Common.v | 2 + common/theories/LoopChecking/Deciders.v | 208 +++++++- common/theories/LoopChecking/Interfaces.v | 4 +- common/theories/LoopChecking/Model.v | 489 +++++++++++------- .../LoopChecking/PartialLoopChecking.v | 6 +- common/theories/Universes.v | 34 +- .../theories/LoopChecking/UnivLoopChecking.v | 356 +++++++++++-- 7 files changed, 842 insertions(+), 257 deletions(-) diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v index 28b9e79ef..1e80553f5 100644 --- a/common/theories/LoopChecking/Common.v +++ b/common/theories/LoopChecking/Common.v @@ -17,6 +17,8 @@ Notation fwd := (ltac:(move=> /(_ _)/Wrap[])). Arguments exist {A P}. Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. +Arguments symmetry {A R Symmetric} {x y}. + #[program] Global Instance reflect_eq_Z : ReflectEq Z := { eqb := Z.eqb }. diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 0005e041d..f2c954961 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -252,8 +252,6 @@ Proof. funelim (check cls cl) => //. Qed. -Arguments symmetry {A R Symmetric} {x y}. - Lemma check_looping {cls cl v isl} : check cls cl = IsLooping v isl -> ~ (exists V, clauses_sem V cls). Proof. @@ -400,15 +398,23 @@ Module CorrectModel. model_valid : valid_model V model_updates initial_model cls }. Arguments t : clear implicits. + Record loop {cls} := + { loop_univ : premises; + loop_on_univ : cls ⊢a loop_univ → succ_prems loop_univ; + }. + Arguments loop : clear implicits. + + Definition result V cls := (t V cls + loop cls)%type. + #[local] Obligation Tactic := program_simpl. Equations? infer_extension_correct {V W init cls} (m : valid_model V W init cls) (enabled : enabled_clauses init cls) (hincl : only_model_of V init) (hs : clauses_levels cls ⊂_lset V) (cls' : clauses) - (hs' : clauses_levels cls' ⊂_lset V) : (t V (Clauses.union cls cls')) + premises := + (hs' : clauses_levels cls' ⊂_lset V) : result V (Clauses.union cls cls') := infer_extension_correct m enabled hincl hs cls' hs' with infer_extension m hincl hs cls' := - | Loop u _ => inr u + | Loop u isl => inr {| loop_univ := u; loop_on_univ := isl |} | Model w m' _ => inl {| initial_model := min_model_map m.(model_model) cls'; @@ -434,16 +440,27 @@ Module CorrectModel. - apply m'. Qed. - Equations? infer_extension_valid {V cls} (m : t V cls) cls' : option (t V (Clauses.union cls cls') + premises) := + Equations? infer_extension_valid {V cls} (m : t V cls) cls' : option (result V (Clauses.union cls cls')) := infer_extension_valid m cls' with inspect (LevelSet.subset (clauses_levels cls') V) := | exist false heq => None - | exist true heq := Some (infer_extension_correct (model_valid m) _ _ _ cls' _). + | exist true heq => Some (infer_extension_correct (model_valid m) _ _ _ cls' _). Proof. - apply enabled_model. - apply only_model_of_V. - now apply m. - now apply LevelSet.subset_spec in heq. Qed. + + Lemma infer_extension_valid_None {V cls} (m : t V cls) cls' : + infer_extension_valid m cls' = None <-> ~ LevelSet.Subset (clauses_levels cls') V. + Proof. + funelim (infer_extension_valid m cls') => //=. + - split=> // eq. clear Heqcall H. exfalso. + apply LevelSet.subset_spec in heq. contradiction. + - split=> // _ hsub. clear H. + move/negP: heq => /LevelSet.subset_spec. contradiction. + Qed. + End CorrectModel. Module Abstract. @@ -474,6 +491,14 @@ Module Abstract. intros x hin. now apply Clauses.empty_spec in hin. Qed. + Lemma init_model_levels : + levels init_model = LevelSet.empty. + Proof. reflexivity. Qed. + + Lemma init_model_clause : + clauses init_model = Clauses.empty. + Proof. reflexivity. Qed. + Lemma levelmap_add_comm {A} l o l' o' (m : LevelMap.t A) : l <> l' -> LevelMap.add l o (LevelMap.add l' o' m) =m LevelMap.add l' o' (LevelMap.add l o m). @@ -491,9 +516,12 @@ Module Abstract. strictly_updates clauses W m m' -> strictly_updates clauses W (LevelMap.add l None m) (LevelMap.add l None m'). Proof. - intros hnin; elim; clear -hnin. - - move=> m [prems [concl k]] m' hin [] v [] hmin habov hm'. - constructor => //. exists v. split => //. + move=> hnin su; move: W m m' su; + apply: strictly_updates_elim; [|move=>m [prems [concl k]] m' incl su|move=>ls ls' m m' m'' su ihsu su' ihsu']. + { solve_proper. } + - move: su => [] v [] hmin habov hm'. cbn. + eapply update_one; tea => //. + exists v. split => //. * erewrite min_premise_preserved; tea. intros. have neq : x <> l. @@ -509,8 +537,7 @@ Module Abstract. { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (l, k)). split => //. apply clause_levels_spec. now right. } now rewrite levelmap_add_comm // hm'. - - move=>> su ihsu su' ihsu'. - econstructor; tea. + - eapply trans_update; tea. Qed. Lemma is_model_add clauses l m : @@ -578,20 +605,110 @@ Module Abstract. now move/incl. Qed. - Equations enforce_clauses (m : t) (cls : Clauses.t) : option (t + premises) := + Lemma declare_level_clauses {m l m'} : + declare_level m l = Some m' -> clauses m = clauses m'. + Proof. + funelim (declare_level m l) => //=. + intros [= <-]. now cbn. + Qed. + + Lemma declare_level_levels {m l m'} : + declare_level m l = Some m' -> ~ LevelSet.In l (levels m) /\ levels m' =_lset LevelSet.add l (levels m). + Proof. + funelim (declare_level m l) => //=. + intros [= <-]. split; cbn => //. + move/LevelSet.mem_spec. rewrite hneq => //. + Qed. + + Lemma declare_level_None {m l} : + declare_level m l = None <-> LevelSet.In l (levels m). + Proof. + funelim (declare_level m l) => //=; clear H Heqcall. + - apply LevelSet.mem_spec in e. firstorder. + - split => //. + move/LevelSet.mem_spec. rewrite hneq => //. + Qed. + + Equations enforce_clauses (m : t) (cls : Clauses.t) : option (t + loop (Clauses.union (clauses m) cls)) := enforce_clauses m cls with infer_extension_valid m.(model) cls := | None => None | Some (inl m') => Some (inl {| model := m' |}) | Some (inr u) => Some (inr u). + Lemma enforce_clauses_None m cls : + enforce_clauses m cls = None <-> + ~ LevelSet.Subset (clauses_levels cls) (levels m). + Proof. + simp enforce_clauses. + have:= @infer_extension_valid_None _ _ (model m) cls. + destruct infer_extension_valid as [[]|]; simp enforce_clauses; split => //. + 1-2:move/H => //. intuition. + Qed. + + Lemma enforce_clauses_not_None m cls : + enforce_clauses m cls <> None <-> LevelSet.Subset (clauses_levels cls) (levels m). + Proof. + unfold not. rewrite enforce_clauses_None. + destruct (LevelSet.subset (clauses_levels cls) (levels m)) eqn:he. + apply LevelSet.subset_spec in he. firstorder. + move/negP: he. + intros ne. red in ne. + split => //. + intros ne'. destruct ne'. intros hs. + apply LevelSet.subset_spec in hs. apply ne. now rewrite hs. + Qed. + + Lemma enforce_clauses_levels m cls m' : + enforce_clauses m cls = Some (inl m') -> + levels m' = levels m. + Proof. + funelim (enforce_clauses m cls) => //=. + intros [= <-]. now cbn. + Qed. + + Lemma enforce_clauses_clauses m cls m' : + enforce_clauses m cls = Some (inl m') -> + clauses m' = Clauses.union (clauses m) cls. + Proof. + funelim (enforce_clauses m cls) => //=. + intros [= <-]. now cbn. + Qed. + + Lemma enforce_clauses_inconsistent m cls u : + enforce_clauses m cls = Some (inr u) -> + ~ exists V, clauses_sem V (Clauses.union (clauses m) cls). + Proof. + funelim (enforce_clauses m cls) => //=. + intros [= <-]. clear -u. intros [V cs]. + destruct u as [u loop]. + eapply clauses_sem_entails_all in loop; tea. + now rewrite interp_add_prems in loop. + Qed. + + Definition check_clauses m cls := + check_clauses (clauses m) cls. + + Lemma check_clauses_ok m cls : + check_clauses m cls -> forall V, clauses_sem V (clauses m) -> clauses_sem V cls. + Proof. + rewrite /check_clauses /Deciders.check_clauses. + move/Clauses.for_all_spec => ha V cs cl /ha. + destruct check eqn:ch => // _. + eapply check_entails in ch. now apply ch. + Qed. + End Abstract. End Deciders. Module LoopChecking (LS : LevelSets). Module Impl := Deciders(LS). Import Impl.I. + Import Impl.Abstract. - Definition model := Impl.Abstract.t. + Definition model := t. + + Definition levels := levels. + Definition clauses := clauses. Notation univ := LS.LevelExprSet.nonEmptyLevelExprSet. @@ -642,12 +759,56 @@ Module LoopChecking (LS : LevelSets). Definition init_model := Impl.Abstract.init_model. (* Returns None if already declared *) - Definition declare_level l m := Impl.Abstract.declare_level m l. + Definition declare_level := Impl.Abstract.declare_level. + + Lemma declare_level_levels {m l m'} : + declare_level m l = Some m' -> ~ LevelSet.In l (levels m) /\ levels m' =_lset LevelSet.add l (levels m). + Proof. apply declare_level_levels. Qed. + + Lemma declare_level_None {m l} : + declare_level m l = None <-> LevelSet.In l (levels m). + Proof. apply declare_level_None. Qed. + + Lemma declare_level_clauses l m m' : declare_level m l = Some m' -> Impl.Abstract.clauses m = Impl.Abstract.clauses m'. + Proof. apply declare_level_clauses. Qed. + + Definition loop m c := Impl.CorrectModel.loop (Clauses.union (clauses m) (to_clauses c)). (* Returns either a model or a looping universe, i.e. such that u >= u + 1 is implied by the constraint *) - Definition enforce c (m : model) : option (model + univ) := - Impl.Abstract.enforce_clauses m (to_clauses c). + Definition enforce (m : model) c : option (model + loop m c) := + enforce_clauses m (to_clauses c). + + Lemma enforce_None {m cls} : + enforce m cls = None <-> ~ LevelSet.Subset (clauses_levels (to_clauses cls)) (levels m). + Proof. + apply enforce_clauses_None. + Qed. + + Lemma enforce_not_None {m cls} : + enforce m cls <> None <-> LevelSet.Subset (clauses_levels (to_clauses cls)) (levels m). + Proof. + apply enforce_clauses_not_None. + Qed. + + Lemma enforce_inconsistent {m cls u} : + enforce m cls = Some (inr u) -> + ~ exists V, clauses_sem V (Clauses.union (clauses m) (to_clauses cls)). + Proof. + apply enforce_clauses_inconsistent. + Qed. + + Lemma enforce_clauses {m cls m'} : + enforce m cls = Some (inl m') -> + clauses m' = Clauses.union (clauses m) (to_clauses cls). + Proof. + apply enforce_clauses_clauses. + Qed. + + Lemma enforce_levels m cls m' : + enforce m cls = Some (inl m') -> + levels m' = levels m. + Proof. apply enforce_clauses_levels. Qed. (* Returns true is the constraint is valid in the model and all its possible consistent extensions. Returns false if the constraint results in an inconsistent set of constraints or it simply @@ -655,8 +816,21 @@ Module LoopChecking (LS : LevelSets). Definition check m c := Impl.check_clauses m.(Impl.Abstract.clauses) (to_clauses c). + Lemma check_correct {m c} : + check m c -> forall V, clauses_sem V (clauses m) -> clauses_sem V (to_clauses c). + Proof. apply check_clauses_ok. Qed. + (* Returns the valuation of the model: a minimal assignement from levels to constraints that make the enforced clauses valid. *) - Definition valuation m := Model.valuation_of_model m.(Impl.Abstract.model).(Impl.CorrectModel.initial_model). + Definition valuation m := Model.valuation_of_model m.(Impl.Abstract.model).(Impl.CorrectModel.model_valid).(model_model). + + Definition model_valuation m : clauses_sem (valuation m) (clauses m). + Proof. + destruct m as [levels clauses []]; cbn. + apply valid_clauses_model; tea; cbn. + - eapply enabled_clauses_ext; tea. + exact: is_update_of_ext (model_updates model_valid). + - apply model_valid. + Qed. End LoopChecking. diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 4f6fcd30f..10ae18580 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -56,8 +56,8 @@ Module Type FMapOTInterface (E : UsualOrderedType). Include FMapInterface.Sfun OT. End FMapOTInterface. -Module Type LevelSet_fun (Level : LevelOrderedType). - Include SWithLeibniz with Module E := Level. +Module Type LevelSet_fun (Level : UsualOrderedType). + Include S with Module E := Level. End LevelSet_fun. Module Type LevelExprItf (Level : LevelOrderedType). diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index cabc2525d..0955e8be0 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -19,6 +19,12 @@ value, then [m] is already a model of [cls]. Note that some clauses in [cls] might not be activated/enabled by the model [m] (they hence hold vacuously). + Note that [strictly_updates] is indexed by clauses and a levelset which should not be compared + by Leibniz equality, we rather use a set(oid)-specific equality for them, hence [strictly_updates] + is defined by so-called "Fording" of the index. We provide an elimination principle and "smart" + constructors that can be nicer to work with: [strictly_updates_elim], [one_update] and [trans_update], + and show that [strictly_updates] is [Proper] for these notions of equality. + We also show the relation of a model to entailment: - If an entailment [cls ⊢ prems → concl] holds then any valid model [m] of the clauses [cls] satisfies [prems → concl], i.e [ is_model cls m -> valid_clause m (prems, concl) ]. @@ -230,13 +236,15 @@ Module Model (LS : LevelSets). [/\ min_premise m prems = Some v, ~~ level_value_above m concl (k + v) & m' =m (LevelMap.add concl (Some (k + v)) m)]. - Inductive strictly_updates cls : LevelSet.t -> model -> model -> Prop := + Inductive strictly_updates cls (s : LevelSet.t) : model -> model -> Prop := | update_one m cl m' : Clauses.In cl cls -> - strict_update m cl m' -> strictly_updates cls (LevelSet.singleton (clause_conclusion cl)) m m' + s =_lset (LevelSet.singleton (clause_conclusion cl)) -> + strict_update m cl m' -> strictly_updates cls s m m' | update_trans {ls ls' m m' m''} : strictly_updates cls ls m m' -> strictly_updates cls ls' m' m'' -> - strictly_updates cls (LevelSet.union ls ls') m m''. + s =_lset LevelSet.union ls ls' -> + strictly_updates cls s m m''. Definition is_update_of cls upd minit m := if LevelSet.is_empty upd then minit =m m @@ -281,22 +289,62 @@ Module Model (LS : LevelSets). Instance strictly_updates_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) strictly_updates. Proof. intros ? ? H ? ? H' ? ? H'' ? ? H'''. - eapply LevelSet.eq_leibniz in H'. subst y0. split. - induction 1 in y, H, y1, H'', y2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. - now rewrite <- H. move: H1; unfold strict_update. destruct cl as [premse []]. + induction 1 in y0, H', y, H, y1, H'', y2, H'''|- *; + [econstructor 1|econstructor 2]; eauto. + now rewrite <- H. now rewrite -H'. move: H2; unfold strict_update. + destruct cl as [premse []]. intros [v []]; exists v; split; try setoid_rewrite <- H; try setoid_rewrite <- H''; try setoid_rewrite <- H'''; firstorder. - eapply IHstrictly_updates1; firstorder. firstorder. - induction 1 in x, H, x1, H'', x2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. - now rewrite H. move: H1; unfold strict_update. destruct cl as [premse []]. + 3:{ rewrite -H'. exact H0. } + eapply IHstrictly_updates1; try firstorder. eapply IHstrictly_updates2; tea. reflexivity. reflexivity. + induction 1 in x, H, x0, H', x1, H'', x2, H'''|- * ; [econstructor 1|econstructor 2]; eauto. + now rewrite H. now rewrite H' H1. move: H2; unfold strict_update. destruct cl as [premse []]. intros [v []]; exists v; split; try setoid_rewrite H; try setoid_rewrite H''; try setoid_rewrite H'''; firstorder. - eapply IHstrictly_updates1; firstorder. firstorder. + 3:{ now rewrite H' H0. } + eapply IHstrictly_updates1; try firstorder. + eapply IHstrictly_updates2; auto; reflexivity. + Qed. + + Lemma trans_update {cls m ls ls' m' m''} : + strictly_updates cls ls m m' -> + strictly_updates cls ls' m' m'' -> + strictly_updates cls (ls ∪ ls') m m''. + Proof. + intros hin su; econstructor 2; trea. + Qed. + + Lemma one_update {cls m cl m'} : + Clauses.In cl cls -> strict_update m cl m' -> + strictly_updates cls (LevelSet.singleton (clause_conclusion cl)) m m'. + Proof. + intros hin su; econstructor; trea. + Qed. + + (* We have a more confortable elimination principle + now for compatible predicates *) + Lemma strictly_updates_elim : + forall (cls : Clauses.t) (P : LevelSet.t -> model -> model -> Prop) + (HP : Proper (LevelSet.Equal ==> eq ==> eq ==> iff) P), + (forall m cl m', Clauses.In cl cls -> + strict_update m cl m' -> P (LevelSet.singleton (clause_conclusion cl)) m m') -> + (forall (ls ls' : LevelSet.t) (m m' m'' : model), + strictly_updates cls ls m m' -> + P ls m m' -> + strictly_updates cls ls' m' m'' -> + P ls' m' m'' -> P (ls ∪ ls') m m'') -> + forall (s : LevelSet.t) (m m0 : model), + strictly_updates cls s m m0 -> P s m m0. + Proof. + intros cls P cP h0 h1. + induction 1. + - rewrite H0. now apply h0. + - rewrite H1. now eapply h1. Qed. Lemma strictly_updates_step cls w m m' m'' : @@ -304,18 +352,15 @@ Module Model (LS : LevelSets). forall cl, Clauses.In cl cls -> strict_update m' cl m'' -> strictly_updates cls (LevelSet.add (clause_conclusion cl) w) m m''. Proof. - induction 1. + revert w m m'. + apply: strictly_updates_elim. + { solve_proper. } - intros. - replace (LevelSet.add (clause_conclusion cl0) (LevelSet.singleton (clause_conclusion cl))) - with (LevelSet.union (LevelSet.singleton (clause_conclusion cl)) (LevelSet.singleton (clause_conclusion cl0))). - eapply update_trans; eapply update_one; tea. - eapply LevelSet.eq_leibniz. red. lsets. + eapply update_trans; tea. 2:{ econstructor 1; tea. reflexivity. } + eapply update_one. 3:tea. auto. reflexivity. lsets. - intros. - specialize (IHstrictly_updates2 _ H1 H2). - replace (LevelSet.add (clause_conclusion cl) (LevelSet.union ls ls')) - with (LevelSet.union ls (LevelSet.add (clause_conclusion cl) ls')). - eapply update_trans; tea. - eapply LevelSet.eq_leibniz. red. lsets. + specialize (H2 _ H3 H4). + eapply update_trans; tea. lsets. Qed. Lemma strictly_updates_weaken cls w cls' : @@ -323,7 +368,7 @@ Module Model (LS : LevelSets). forall m m', strictly_updates cls w m m' -> strictly_updates cls' w m m'. Proof. intros hcls m m'. - induction 1. constructor => //. now eapply hcls. + induction 1. econstructor => //. now eapply hcls. econstructor 2; tea. Qed. @@ -339,14 +384,31 @@ Module Model (LS : LevelSets). - rewrite Clauses.add_spec. left; reflexivity. Qed. + #[export] Instance clauses_with_concl_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> Clauses.Equal) clauses_with_concl. + Proof. + intros ? ? H ? ? H' l. + rewrite !in_clauses_with_concl. + now rewrite H H'. + Qed. + + #[export] Instance restrict_clauses_proper : Proper (Clauses.Equal ==> LevelSet.Equal ==> Clauses.Equal) restrict_clauses. + Proof. + intros ? ? H ? ? H' l. + rewrite !in_restrict_clauses. + now rewrite H H'. + Qed. + Lemma strictly_updates_strenghten {cls W m m'} : strictly_updates cls W m m' -> strictly_updates (cls ↓ W) W m m'. Proof. induction 1. - - constructor. rewrite in_clauses_with_concl. split => //. - eapply LevelSet.singleton_spec; reflexivity. exact H0. - - rewrite clauses_with_concl_union. econstructor 2. + - setoid_rewrite H0 at 2. eapply one_update. + rewrite in_clauses_with_concl. split => //. + rewrite H0. + eapply LevelSet.singleton_spec; reflexivity. exact H1. + - setoid_rewrite H1. rewrite clauses_with_concl_union. + eapply trans_update. eapply strictly_updates_weaken; tea. intros x; clsets. eapply strictly_updates_weaken; tea. intros x; clsets. Qed. @@ -386,24 +448,28 @@ Module Model (LS : LevelSets). now apply eqlistA_eq. Qed. - #[export] Instance check_model_aux_proper : Proper (Clauses.Equal ==> eq ==> eq) check_model_aux. + Definition eqwm (x y : LevelSet.t * LevelMap.t (option Z)) := + LevelSet.Equal x.1 y.1 /\ LevelMap.Equal x.2 y.2. + + Instance eqwm_equiv : Equivalence eqwm. Proof. - intros ? ? eq ? ? ->. - rewrite /check_model_aux. - rewrite !ClausesProp.fold_spec_right. - now rewrite eq. + unfold eqwm; split. + - intros [] => //=. + - intros [] [] [] => //=. cbn in *. split; now symmetry. + - intros [] [] [] [] [] => //=; cbn in *. split. + now transitivity t1. now transitivity t2. Qed. - #[export] Instance check_model_proper : Proper (Clauses.Equal ==> eq ==> eq) check_model. + Definition eqwm_list (x y : list Level.t * LevelMap.t (option Z)) := + x.1 = y.1 /\ LevelMap.Equal x.2 y.2. + + Instance eqwm_list_equiv : Equivalence eqwm_list. Proof. - intros cls cls' eq. - intros wm wm' ->. - unfold check_model. - destruct (check_model_aux cls _) eqn:eqc. - destruct (check_model_aux cls' _) eqn:eqc' => //. - pose proof (check_model_aux_proper cls cls' eq ([], wm'.2) _ eq_refl). - rewrite eqc eqc' in H. noconf H. - destruct l => //. + unfold eqwm; split. + - intros [] => //=. + - intros [] [] [] => //=. cbn in *. split; now symmetry. + - intros [] [] [] [] [] => //=; cbn in *. split. + now transitivity l0. now transitivity t0. Qed. Lemma update_value_valid {m cl} : @@ -456,7 +522,7 @@ Module Model (LS : LevelSets). move: (@update_value_valid m cl). now rewrite upd. * intros [= <- <-]. split => //. + intros. eapply (f_equal (@List.length _)) in H. cbn in H; lia. - + intros _. split => //. constructor. clsets. unfold strict_update. + + intros _. split => //. apply one_update. clsets. unfold strict_update. move: upd. unfold update_value. destruct cl as [prems [concl k]]. cbn. destruct min_premise => //. @@ -492,10 +558,11 @@ Module Model (LS : LevelSets). { subst w''. specialize (H eq_refl) as []. subst m''. destruct (eqb_spec w w'); subst; try congruence. specialize (H3 H) as []. subst w'. exists [clause_conclusion x]. split => //. - replace (LevelSetProp.of_list [clause_conclusion x]) with (LevelSet.singleton (clause_conclusion x)). + setoid_replace (LevelSetProp.of_list [clause_conclusion x]) with (LevelSet.singleton (clause_conclusion x)). eapply ClausesProp.Add_Equal in hadd. rewrite hadd. eapply strictly_updates_weaken; tea. clsets. - eapply LevelSet.eq_leibniz. red. intros ?. rewrite LevelSetProp.of_list_1. firstorder. constructor. - rewrite LevelSet.singleton_spec in H3. firstorder. depelim H3. subst. lsets. depelim H3. } + intros ?. rewrite LevelSetProp.of_list_1 InA_In_eq. firstorder. subst a. + now apply LevelSet.singleton_spec. + apply LevelSet.singleton_spec in H3. now constructor. } specialize (H0 H4). destruct (eqb_spec w'' w'); subst. { specialize (H2 eq_refl) as []; subst m''. @@ -503,17 +570,78 @@ Module Model (LS : LevelSets). eapply strictly_updates_weaken; tea. intros ? ?. eapply hadd. clsets. } forward H3 by auto. destruct H3 as [->]. destruct H0 as [pref [-> su]]. eexists (clause_conclusion x :: pref); split => //. - replace (LevelSetProp.of_list (clause_conclusion x :: pref)) with (LevelSet.union (LevelSetProp.of_list pref) (LevelSet.singleton (clause_conclusion x))). + setoid_replace (LevelSetProp.of_list (clause_conclusion x :: pref)) with (LevelSet.union (LevelSetProp.of_list pref) (LevelSet.singleton (clause_conclusion x))). eapply (strictly_updates_weaken _ _ s'') in su; tea; try firstorder. eapply (strictly_updates_weaken _ _ s'') in H3; tea; try firstorder. 2:{ intros ?; rewrite Clauses.singleton_spec. intros ->. now apply hadd. } - exact: update_trans _ su H3. - apply LevelSet.eq_leibniz. intros ?. cbn. lsets. + exact: trans_update su H3. + intros ?. cbn. lsets. + Qed. + + Inductive lift_option_rel {A} (R : relation A) : relation (option A) := + | lift_none : lift_option_rel R None None + | lift_some x y : R x y -> lift_option_rel R (Some x) (Some y). + Derive Signature for lift_option_rel. + Instance update_value_proper : Proper (LevelMap.Equal ==> eq ==> lift_option_rel LevelMap.Equal) update_value. + Proof. + intros x y eqm [prems [concl k]] ? <- => //=. + rewrite /update_value. + setoid_rewrite eqm at 1. destruct min_premise => //=. + setoid_rewrite eqm at 1. destruct level_value_above => //=; constructor. + now rewrite eqm. + constructor. + Qed. + + Instance check_clause_model_proper : Proper (eq ==> eqwm_list ==> eqwm_list) check_clause_model. + Proof. + intros [prems [concl k]] ? <- [] [] eq. + set (cl := (prems, (concl, k))) in *. + cbn. destruct eq as [eql eqm]. cbn in *. subst l0. + have equpd := update_value_proper t t0 eqm cl cl eq_refl. + depelim equpd. rewrite H H0. split => //. + rewrite H0 H1. split => //. + Qed. + + #[export] Instance check_model_aux_proper : Proper (Clauses.Equal ==> eqwm_list ==> eqwm_list) check_model_aux. + Proof. + intros ? ? eq [] [] []; cbn in *. subst l0. + rewrite /check_model_aux. + rewrite !ClausesProp.fold_spec_right. + rewrite eq. induction (List.rev (Clauses.elements y)); cbn. + red; split => //=. rewrite IHl0. reflexivity. + Qed. + + #[export] Instance check_model_aux_proper_strict : Proper (Clauses.Equal ==> eq ==> eq) check_model_aux. + Proof. + intros ? ? eq [] [] []; cbn in *. + rewrite /check_model_aux. + rewrite !ClausesProp.fold_spec_right. now rewrite eq. + Qed. + + #[export] Instance check_model_proper : Proper (Clauses.Equal ==> eqwm ==> lift_option_rel eqwm) check_model. + Proof. + intros cls cls' eq. + intros wm wm' eqm. + unfold check_model. + have := (check_model_aux_proper cls cls' eq ([], wm.2) ([], wm'.2)) => /fwd. + split => //=. apply eqm. + move=> []. + destruct (check_model_aux cls _) eqn:eqc. + destruct (check_model_aux cls' _) eqn:eqc' => //= <-. + destruct l => //. constructor. destruct eqm. constructor. + split => //=. now rewrite H. + Qed. + + #[export] Instance check_model_proper_strict : Proper (Clauses.Equal ==> eq ==> eq) check_model. + Proof. + intros cls cls' eq ? ? ->. + unfold check_model. now rewrite eq. Qed. Lemma check_model_spec {cls w m w' m'} : check_model cls (w, m) = Some (w', m') -> - exists w'', strictly_updates cls w'' m m' /\ w' = LevelSet.union w w''. + exists w'', strictly_updates cls w'' m m' /\ + w' =_lset LevelSet.union w w''. Proof. unfold check_model. destruct check_model_aux eqn:cm. @@ -522,7 +650,7 @@ Module Model (LS : LevelSets). intros [= <- <-]. destruct H0 as [pref [heq su]]. rewrite app_nil_r in heq. subst pref. exists (LevelSetProp.of_list (t :: l)). split => //. - eapply LevelSet.eq_leibniz. intros ?. cbn. lsets. + intros ?. cbn. lsets. Qed. @@ -537,11 +665,11 @@ Module Model (LS : LevelSets). Lemma strictly_updates_invalid cls w m m' : strictly_updates cls w m m' -> ~~ is_model cls m. Proof. induction 1. - - eapply strict_update_invalid in H0. + - eapply strict_update_invalid in H1. apply/negbT. unfold is_model. destruct Clauses.for_all eqn:fa => //. eapply Clauses.for_all_spec in fa; tc. eapply fa in H. - now rewrite H in H0. + now rewrite H in H1. - auto. Qed. @@ -563,9 +691,9 @@ Module Model (LS : LevelSets). forall cls', strictly_updates cls' w init_model m -> strictly_updates (Clauses.union cls cls') w' init_model m' /\ w ⊂_lset w'. Proof. - move/check_model_spec => [w'' [su ->]]. - intros cls' su'. split. - eapply update_trans; eapply strictly_updates_weaken; tea; clsets. lsets. + move/check_model_spec => [w'' [su eq]]. rw eq. + intros cls' su'. split. 2:lsets. + eapply trans_update; eapply strictly_updates_weaken; tea; clsets. Qed. Lemma strictly_updates_non_empty {cls W m m'} : @@ -582,7 +710,7 @@ Module Model (LS : LevelSets). induction 1. - intros he. specialize (he (clause_conclusion cl)). destruct cl as [prems [concl k]]. - destruct H0 as [? [? ? heq]]. + destruct H1 as [? [? ? heq]]. setoid_rewrite heq in he. eapply (he (Some (k + x))); cbn. rewrite LevelMapFact.F.add_mapsto_iff. firstorder. - intros he. now apply IHstrictly_updates2. @@ -593,7 +721,7 @@ Module Model (LS : LevelSets). Proof. induction 1. - intros x. rewrite clauses_conclusions_spec. firstorder. exists cl. - eapply LevelSet.singleton_spec in H1; red in H1; subst. split => //. + move: H2. rewrite H0. move/LevelSet.singleton_spec => ->. split => //. - lsets. Qed. @@ -618,7 +746,7 @@ Module Model (LS : LevelSets). induction 1. - exists (clause_conclusion cl). destruct cl as [prems [concl k]]. - destruct H0 as [? [? ? heq]]. cbn. + destruct H1 as [? [? ? heq]]. cbn. setoid_rewrite heq. exists (k + x)%Z; cbn. rewrite LevelMapFact.F.add_mapsto_iff. firstorder. - assumption. @@ -795,7 +923,7 @@ Module Model (LS : LevelSets). Lemma strictly_updates_ext cls w m m' : strictly_updates cls w m m' -> m ⩽ m'. Proof. induction 1. - now eapply strict_update_ext in H0. + now eapply strict_update_ext in H1. now transitivity m'. Qed. @@ -1429,8 +1557,8 @@ Module Model (LS : LevelSets). strictly_updates cls w m m'. Proof. move/check_model_spec => [w' [su ->]]. - replace (LevelSet.union LevelSet.empty w') with w' => //. - eapply LevelSet.eq_leibniz. intros x; lsets. + setoid_replace (LevelSet.union LevelSet.empty w') with w' => //. + intros x; lsets. Qed. Lemma check_model_is_model {W cls m} : @@ -1516,7 +1644,7 @@ Module Model (LS : LevelSets). strictly_updates (Clauses.union cls cls') (LevelSet.union W W') m m''. Proof. intros su su'. - eapply update_trans; eapply strictly_updates_weaken; tea; clsets. + eapply trans_update; eapply strictly_updates_weaken; tea; clsets. Qed. Lemma check_model_is_update_of {cls cls' U W minit m m'} : @@ -1528,8 +1656,10 @@ Module Model (LS : LevelSets). destruct LevelSet.is_empty eqn:he. - intros ->. eapply LevelSetFact.is_empty_2 in he. eapply LevelSetProp.empty_is_empty_1 in he. - eapply LevelSet.eq_leibniz in he. rewrite he. - move/check_model_updates_spec_empty. intros H; split => //. 2:lsets. + have := check_model_proper cls' cls' (reflexivity cls') (U, m) (LevelSet.empty, m) => /fwd /fwd. + split => //. intros h; depelim h. rewrite H => //. + rewrite H0. intros [= ->]. destruct y as [W' m'']. destruct H as [eq eq']; cbn in *. + move/check_model_updates_spec_empty: H1. rewrite eq -eq'. intros H; split => //. 2:lsets. eapply strictly_updates_weaken; tea. clsets. - intros hs. move/check_model_spec => [w'' [su ->]]. split; [|lsets]. eapply strictly_updates_trans; tea. @@ -1575,6 +1705,17 @@ Module Model (LS : LevelSets). now apply hu. now apply hv. Qed. + Instance model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) model_of. + Proof. + intros ? ? H ? ? H'. unfold model_of. setoid_rewrite H. + now setoid_rewrite H'. + Qed. + + Instance defined_model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) defined_model_of. + Proof. + unfold defined_model_of; solve_proper. + Qed. + Lemma defined_model_of_union {U V cls} : defined_model_of U cls -> defined_model_of V cls -> @@ -1603,31 +1744,26 @@ Module Model (LS : LevelSets). strictly_updates cls W m m' -> forall W', model_of W' m -> model_of (LevelSet.union W' W) m'. Proof. - clear. - induction 1. - - intros W' tot x. + clear. move: W m m'. + apply: strictly_updates_elim. + { solve_proper. } + - intros m cl m' incl su W' tot x. destruct cl as [prems [concl cl]]. - destruct H0 as [minv [hmin ? heq]]. setoid_rewrite heq. + destruct su as [minv [hmin ? heq]]. setoid_rewrite heq. setoid_rewrite LevelMapFact.F.add_in_iff. cbn. destruct (Level.eq_dec concl x). { now left. } { rewrite LevelSet.union_spec; intros [hin|hin]. { eapply tot in hin as [wit mt]. right; exists wit. assumption. } { eapply LevelSet.singleton_spec in hin. red in hin; subst. congruence. } } - - intros W' tot. - eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. + - intros ls ls' m m' m'' su ihsu su' ihsu' W' tot. + eapply ihsu in tot. eapply ihsu' in tot. eapply model_of_subset; tea. intros x; lsets. Qed. Lemma model_of_empty m : model_of LevelSet.empty m. Proof. intros x; now move/LevelSet.empty_spec. Qed. - Instance model_of_proper : Proper (LevelSet.Equal ==> LevelMap.Equal ==> iff) model_of. - Proof. - intros ? ? H ? ? H'. unfold model_of. setoid_rewrite H. - now setoid_rewrite H'. - Qed. - Lemma strictly_updates_total_model {cls W m m'} : strictly_updates cls W m m' -> model_of W m'. @@ -1640,19 +1776,19 @@ Module Model (LS : LevelSets). strictly_updates cls W m m' -> forall W', only_model_of W' m -> only_model_of (LevelSet.union W' W) m'. Proof. - clear. - induction 1. - - intros W' tot x. + move: W m m'; apply: strictly_updates_elim. + { solve_proper. } + - intros m cl m' incl su W' tot x. destruct cl as [prems [concl cl]]. - destruct H0 as [minv [hmin ? heq]]. setoid_rewrite heq. + destruct su as [minv [hmin ? heq]]. setoid_rewrite heq. setoid_rewrite LevelMapFact.F.add_mapsto_iff. cbn. case: (Level.eq_dec concl x). { move=> ->. rewrite LevelSet.union_spec LevelSet.singleton_spec. firstorder; exists (Some (cl + minv)); left; split => //. } { rewrite LevelSet.union_spec LevelSet.singleton_spec /LevelSet.E.eq. firstorder. congruence. } - - intros W' tot. - eapply IHstrictly_updates1 in tot. eapply IHstrictly_updates2 in tot. + - intros ls ls' m m' m'' su ihsu su' ihsu' W' tot. + eapply ihsu in tot. eapply ihsu' in tot. eapply only_model_of_eq; tea. intros x; lsets. Qed. @@ -1685,15 +1821,15 @@ Module Model (LS : LevelSets). forall l k, LevelMap.MapsTo l k m' -> LevelSet.In l W \/ LevelMap.MapsTo l k m. Proof. induction 1. - + eapply strict_update_modify in H0 as [k eq]. - intros l k'. rewrite LevelSet.singleton_spec. + + eapply strict_update_modify in H1 as [k eq]. + intros l k'. rewrite H0. rewrite LevelSet.singleton_spec. rewrite eq. rewrite LevelMapFact.F.add_mapsto_iff. intros [[]|] => //. red in H0; subst. - left. lsets. now right. - + intros. eapply IHstrictly_updates2 in H1. - destruct H1. left; lsets. - eapply IHstrictly_updates1 in H1 as []. left; lsets. + now left. now right. + + intros. eapply IHstrictly_updates2 in H2 as []. + left; lsets. + eapply IHstrictly_updates1 in H2 as []. left; lsets. now right. Qed. @@ -1702,16 +1838,16 @@ Module Model (LS : LevelSets). forall l k, LevelMap.MapsTo l k m -> LevelSet.In l W \/ LevelMap.MapsTo l k m'. Proof. induction 1. - + eapply strict_update_modify in H0 as [k eq]. - intros l k'. rewrite LevelSet.singleton_spec. + + eapply strict_update_modify in H1 as [k eq]. + intros l k'. rewrite H0 LevelSet.singleton_spec. rewrite eq. rewrite LevelMapFact.F.add_mapsto_iff. intros hm. unfold Level.eq. destruct (Level.eq_dec l (clause_conclusion cl)). subst. now left. right. right. auto. - + intros. eapply IHstrictly_updates1 in H1 as []. + + intros. eapply IHstrictly_updates1 in H2 as []. left; lsets. - eapply IHstrictly_updates2 in H1 as []. left; lsets. + eapply IHstrictly_updates2 in H2 as []. left; lsets. now right. Qed. @@ -1759,36 +1895,38 @@ Module Model (LS : LevelSets). check_model_invariants cls w m w' m' true. Proof. intros mof tot. - move/check_model_spec => [w'' [su ->]]. + move/check_model_spec => [w'' [su eq]]. cbn. split. - lsets. - apply strictly_updates_incl in su. lsets. - - clear -su. induction su. - * exists cl. split => //. now eapply strict_update_invalid. - unfold clause_conclusion. lsets. - destruct cl as [prems [concl k]]. - destruct H0 as [minp [hin hnabove habove]]. - move: hnabove habove. rewrite /level_value_above. - cbn. destruct level_value eqn:hv => //; try constructor. - intros hle. intros ->. rewrite level_value_add. constructor. - move/negbTE: hle. lia. - * destruct IHsu1 as [cl []]. + - clear -su eq. + move: w'' m m' su w' eq; apply: strictly_updates_elim. + { intros ? ? meq ? ? -> ? ? ->. rw meq. reflexivity. } + * move=> m cl m' incl su w' eq. exists cl. split => //. now eapply strict_update_invalid. + unfold clause_conclusion. rewrite eq. rewrite /clause_conclusion. lsets. + destruct cl as [prems [concl k]]. + destruct su as [minp [hin hnabove habove]]. + move: hnabove habove. rewrite /level_value_above. + cbn. destruct level_value eqn:hv => //; try constructor. + intros hle. intros ->. rewrite level_value_add. constructor. + move/negbTE: hle. lia. + * move=> ls ls' > su ihsu su' ihsu' w' eq. specialize (ihsu _ (reflexivity _)) as [cl []]. exists cl. split => //. lsets. - apply strictly_updates_ext in su2. + apply strictly_updates_ext in su'. depelim H2; rewrite ?H3. 2:{ rewrite H2; constructor. } - eapply level_value_MapsTo', su2 in H4 as [k' [map le]]. + eapply level_value_MapsTo', su' in H4 as [k' [map le]]. eapply level_value_MapsTo in map. rewrite map. depelim le. constructor; lia. - constructor. now eapply strictly_updates_ext. clear -mof su. induction su. - * move: H0; unfold strict_update. destruct cl as [prems [concl k]]. + * move: H1; unfold strict_update. destruct cl as [prems [concl k]]. intros [v [hmi nabove eqm]]. intros l. rewrite eqm. rewrite LevelMapFact.F.add_in_iff. specialize (mof l). rewrite clauses_conclusions_spec in mof. firstorder. * specialize (IHsu1 mof). transitivity m' => //. apply IHsu2. intros l hin. specialize (mof _ hin). now apply IHsu1 in mof. * eapply model_map_outside_weaken. now eapply strictly_updates_outside. lsets. - - eapply strictly_updates_model_of_gen in su; tea. + - eapply strictly_updates_model_of_gen in su; tea. now rewrite eq. Qed. Definition infers_atom (m : model) (l : Level.t) (k : Z) := Some k ≤ level_value m l. @@ -1853,7 +1991,7 @@ Lemma is_update_of_empty cls m : move=> su /is_update_of_case; intros [[empw eq]|su']. rewrite <- eq. eapply (strictly_updates_weaken cls). clsets. eapply strictly_updates_W_eq; tea. lsets. - eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. + eapply trans_update; tea; eapply strictly_updates_weaken; tea; clsets. Qed. Definition restrict_model W (m : model) := @@ -2043,15 +2181,17 @@ Lemma is_update_of_empty cls m : mr =m (restrict_model W m) -> strictly_updates (cls ⇂ W) W' m (model_update m m'). Proof. - intros cls' mr. induction 1. - - intros mi mofW -> hm. - constructor. auto. + intros cls' mr. + move: W' mr m'; apply: strictly_updates_elim. + { solve_proper. } + - move=> m cl m' incl su mi mofW eq hm. subst cls'. + apply one_update. auto. destruct cl as [prems [concl k]]. - destruct H0 as [v [hmin above heq]]. + destruct su as [v [hmin above heq]]. rewrite hm in hmin, above. exists v. split => //. eapply min_premise_restrict with W => //. - { intros l k' hp. move/in_restrict_clauses: H => [] //= _ hsub _. apply hsub. + { intros l k' hp. move/in_restrict_clauses: incl => [] //= _ hsub _. apply hsub. rewrite levelexprset_levels_spec. now exists k'. } move: above. rewrite /level_value_above /level_value. @@ -2061,9 +2201,9 @@ Lemma is_update_of_empty cls m : now rewrite (LevelMap.find_1 hkr). + move=> ncl _. elim: find_spec => // => k' inm. - apply in_restrict_clauses in H as [inconcl inprems incls]. cbn in *. + apply in_restrict_clauses in incl as [inconcl inprems incls]. cbn in *. elim ncl. exists k'. eapply restrict_model_spec. split => //. - + apply in_restrict_clauses in H as [inconcl inprems incls]. cbn in *. + + apply in_restrict_clauses in incl as [inconcl inprems incls]. cbn in *. rewrite heq. intro. apply levelmap_find_eq => k'. rewrite hm. rewrite model_update_spec !LevelMapFact.F.add_mapsto_iff restrict_model_spec. @@ -2073,17 +2213,18 @@ Lemma is_update_of_empty cls m : * right. split. right => //. now exists k'. * left. split => //. intros []. congruence. destruct H2 as [yrest hin]. eapply restrict_model_spec in hin as []. contradiction. - - intros mtot mof -> hm. specialize (IHstrictly_updates1 mtot mof eq_refl hm). + - move=> ls ls' m m' m'' su ihsu su' ihsu' mtot mof eq hm. subst cls'. + specialize (ihsu mtot mof eq_refl hm). have model_of : model_of W (model_update mtot m'). by apply model_of_model_update. - move: (IHstrictly_updates2 (model_update mtot m') model_of eq_refl) => /fwd h. - { rewrite hm in H. eapply strictly_updates_from_restrict in H; tea. + move: (ihsu' (model_update mtot m') model_of eq_refl) => /fwd h. + { rewrite hm in su. eapply strictly_updates_from_restrict in su; tea. 2:eapply clauses_conclusions_restrict_clauses. now rewrite restrict_model_update. } - eapply update_trans; tea. + eapply trans_update; tea. have eqm : (model_update (model_update mtot m') m'') =m model_update mtot m''. - { eapply model_update_trans. eapply strictly_updates_ext in H0. - intros l [k hin]. apply H0 in hin as [k' []]. now exists k'. } + { eapply model_update_trans. eapply strictly_updates_ext in su'. + intros l [k hin]. apply su' in hin as [k' []]. now exists k'. } now rewrite eqm in h. Qed. @@ -2107,7 +2248,7 @@ Lemma is_update_of_empty cls m : eapply strictly_updates_W_eq; tea. lsets. - eapply strictly_updates_restrict_model in su'. eapply strictly_updates_weaken in su'. 2:eapply restrict_clauses_subset. - eapply update_trans; tea; eapply strictly_updates_weaken; tea; clsets. + eapply trans_update; tea; eapply strictly_updates_weaken; tea; clsets. now apply strictly_updates_total_model in su. Qed. @@ -2240,12 +2381,12 @@ Lemma is_update_of_empty cls m : Proof. induction 1. - cbn. destruct cl as [prems [concl k]]; cbn in H0. - destruct H0 as [hz [hmin habov heq]]. + destruct H1 as [hz [hmin habov heq]]. rewrite H0. move=> l /LevelSet.singleton_spec => -> //=. setoid_rewrite heq. exists (k + hz)%Z. apply LevelMapFact.F.add_mapsto_iff. left; split => //. - - apply defined_model_of_union; auto. + - rewrite H1. apply defined_model_of_union; auto. eapply defined_model_of_ext. exact IHstrictly_updates1. now apply strictly_updates_ext in H0. Qed. @@ -2383,12 +2524,15 @@ Lemma is_update_of_empty cls m : strictly_updates cls W' m m' -> exists l, LevelSet.In l W' /\ ~ LevelSet.In l W. Proof. - intros vm. induction 1. - - exists (clause_conclusion cl). split => //. lsets. intros hin. - eapply strict_update_invalid in H0. + intros vm su. + move: W' m m' su vm; apply: strictly_updates_elim. + { intros ? ? eq ? ? -> ? ? ->. now setoid_rewrite eq. } + - move=> m cl m' incl su vm. exists (clause_conclusion cl). split => //. lsets. intros hin. + eapply strict_update_invalid in su. eapply is_model_invalid_clause in vm; tea. apply vm. eapply in_clauses_with_concl. split => //. - - destruct (IHstrictly_updates1 vm). exists x. + - move=> ls ls' m m' m'' su ihsu su' ihsu' vm. + destruct (ihsu vm). exists x. rewrite LevelSet.union_spec. firstorder. Qed. @@ -2399,7 +2543,7 @@ Lemma is_update_of_empty cls m : induction su. - intros mv l hin. apply mv in hin. destruct cl as [prems [concl k]]. - destruct H0 as [minv [eqmin nabove eqm]]. rewrite eqm. + destruct H1 as [minv [eqmin nabove eqm]]. rewrite eqm. rewrite LevelMapFact.F.add_in_iff. now right. - eauto. Qed. @@ -2412,9 +2556,9 @@ Lemma is_update_of_empty cls m : Qed. Lemma check_model_update_of {cls U m W m'} : check_model cls (U, m) = Some (W, m') -> - exists W', is_update_of cls W' m m' /\ W = LevelSet.union U W'. + exists W', is_update_of cls W' m m' /\ W =_lset LevelSet.union U W'. Proof. - move/check_model_spec => [w'' [su ->]]. exists w''. split => //. + move/check_model_spec => [w'' [su eq]]. rw eq. exists w''. split => //. now eapply is_update_of_strictly_updates. Qed. @@ -2423,9 +2567,10 @@ Lemma is_update_of_empty cls m : (forall l k, LevelSet.In l V -> LevelMap.MapsTo l k minit -> exists k', LevelMap.MapsTo l (Some k') m /\ opt_le Z.lt k (Some k')). Proof. - induction 1. - - intros l k hin hm. - move: H0; rewrite /strict_update. + move: V minit m; apply: strictly_updates_elim. + { intros ? ? eq ? ? -> ? ? ->. now setoid_rewrite eq. } + - move=> m cl m' incl su l k hin hm. + move: su; rewrite /strict_update. destruct cl as [prems [concl gain]]. move=> [] v [] minp hlt. cbn in hin. eapply LevelSet.singleton_spec in hin. red in hin; subst l. move/negbTE: hlt; rewrite /level_value_above. @@ -2434,13 +2579,13 @@ Lemma is_update_of_empty cls m : destruct level_value eqn:hl => //. * rewrite (level_value_MapsTo hm) in hl. noconf hl. constructor. lia. * rewrite (level_value_MapsTo hm) in hl. noconf hl. constructor. - - intros l k; rewrite LevelSet.union_spec; move=> [] hin hm. - apply IHstrictly_updates1 in hm as [k' [hle hm']]; tea. - eapply strictly_updates_ext in H0. apply H0 in hle as [k'' [hm'' lek'']]. + - move=> ls ls' m m' m'' su ihsu su' ihsu' l k; rewrite LevelSet.union_spec; move=> [] hin hm. + apply ihsu in hm as [k' [hle hm']]; tea. + eapply strictly_updates_ext in su'. apply su' in hle as [k'' [hm'' lek'']]. depelim lek''. exists y. split => //. depelim hm'; constructor; lia. - eapply strictly_updates_ext in H. eapply H in hm as [k' [hm' lek']]. - eapply IHstrictly_updates2 in hm' as [k'' [hm'' lek'']]; tea. + eapply strictly_updates_ext in su. eapply su in hm as [k' [hm' lek']]. + eapply ihsu' in hm' as [k'' [hm'' lek'']]; tea. exists k''. split => //. depelim lek'; depelim lek''; constructor; lia. Qed. @@ -2513,31 +2658,10 @@ Lemma is_update_of_empty cls m : model_of V m -> model_rel_partial Z.lt V m m'. Proof. - intros su; induction su. - - intros htot l. split; revgoals. - { intros nin k. destruct cl as [prems [concl conclk]]; cbn in *. - destruct H0 as [minp [hmin nabove hm']]. - rewrite hm'. rewrite LevelMapFact.F.add_mapsto_iff. - assert (concl <> l). intros ->. - apply nin, in_singleton. - firstorder. } - intros inv k hin. - red in htot. - specialize (htot (clause_conclusion cl) (in_singleton _)) as [mconcl mt]. - destruct cl as [prems [concl conclk]]; cbn in *. - destruct H0 as [minp [hmin nabove hm']]. - eapply LevelSet.singleton_spec in inv; red in inv; subst l. - eapply LevelMapFact.F.MapsTo_fun in hin; tea. noconf hin. - exists (Some (conclk + minp))%Z. split => //. - rewrite hm'. - rewrite LevelMapFact.F.add_mapsto_iff. left. split => //. - move/negbTE: nabove; move/level_value_not_above_spec. - now rewrite (level_value_MapsTo mt). - - move/model_of_union_inv => [] totls totls'. - forward IHsu1 by auto. - forward IHsu2. - { eapply model_of_sext. exact totls. assumption. eassumption. } - now eapply model_rel_partial_trans. + move=> h mV l. split => //. + - move/strictly_updates_all: h => h; move=> inv k /h; move/(_ inv) => [k' []]. + exists (Some k'); split => //. + - now eapply strictly_updates_outside. Qed. #[program] @@ -2599,32 +2723,30 @@ Lemma is_update_of_empty cls m : - intros. rewrite H. firstorder. lesets. Qed. - Lemma strictly_updates_non_empty_init_map {cls W m m'} : - strictly_updates cls W m m' -> ~ LevelMap.Empty m. - Proof. - induction 1. - - destruct cl as [prems [concl k]]. - destruct H0 as [? [? ? heq]]. - eapply min_premise_spec_aux in H0 as [_ [[] [inprems heq']]]. - unfold min_atom_value in heq'. - destruct level_value eqn:hl => //. apply level_value_MapsTo' in hl. - now intros e; apply e in hl. - - auto. - Qed. - Lemma strictly_updates_defined_init_map {cls W m m'} : strictly_updates cls W m m' -> defined_map m. Proof. induction 1. - destruct cl as [prems [concl k]]. - destruct H0 as [? [? ? heq]]. - eapply min_premise_spec_aux in H0 as [_ [[] [inprems heq']]]. + destruct H1 as [? [? ? heq]]. + eapply min_premise_spec_aux in H1 as [_ [[] [inprems heq']]]. unfold min_atom_value in heq'. destruct level_value eqn:hl => //. apply level_value_MapsTo' in hl. now exists t0, z0. - auto. Qed. + Lemma defined_map_ne m : defined_map m -> ~ LevelMap.Empty m. + Proof. + move=> [] k [] v hm he. now eapply he. + Qed. + + Lemma strictly_updates_non_empty_init_map {cls W m m'} : + strictly_updates cls W m m' -> ~ LevelMap.Empty m. + Proof. + now move/strictly_updates_defined_init_map/defined_map_ne. + Qed. + Definition premise_values (prems : premises) m := NonEmptySetFacts.map (fun '(l, k) => (l, option_get 0 (level_value m l))) prems. @@ -2691,9 +2813,12 @@ Lemma is_update_of_empty cls m : strictly_updates cls V mzero m -> entails_all cls (of_level_map mzero hne) (of_level_map m hne'). Proof. - intros su; induction su. + move=> su; move: V mzero m su hne hne'. + apply: strictly_updates_elim; [|move=>m cl m' incl su|move=>ls ls' m m' m'' su ihsu su' ihsu']. + { intros ? ? eq. solve_proper. } + all:intros hne hne'. - destruct cl as [prems [concl k]]. - destruct H0 as [minp [hmin nabove eqm']]. + destruct su as [minp [hmin nabove eqm']]. have [minsleq mineq] := min_premise_spec m prems. destruct mineq as [minprem [inprems eqminp]]. cbn. move: eqminp. rewrite /min_atom_value. @@ -2706,16 +2831,16 @@ Lemma is_update_of_empty cls m : destruct hin as [[eq heq]|[neq hm]]. noconf heq. have hypss := of_level_map_spec m hne. set (hyps := of_level_map m hne) in *. clearbody hyps. - have entailscl : entails cls (prems, (concl, k)) by exact: entails_in H. + have entailscl : entails cls (prems, (concl, k)) by exact: entails_in incl. move/(entails_shift (z - mink)): entailscl. cbn. move => entailscl. eapply (entails_all_one (concl := add_prems (z - mink) prems)) => //. eapply level_value_MapsTo' in hminprem. rewrite -hypss in hminprem. eapply hyps_entails; tea. red in eq; subst. exact entailscl. constructor. now rewrite of_level_map_spec. - - have hnemid : defined_map m'. by exact: strictly_updates_defined_map su1. - specialize (IHsu1 hne hnemid). - specialize (IHsu2 hnemid hne'). + - have hnemid : defined_map m'. by exact: strictly_updates_defined_map su. + specialize (ihsu hne hnemid). + specialize (ihsu' hnemid hne'). eapply entails_all_trans; tea. Qed. diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index f24efd8d0..8aac72232 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -595,12 +595,14 @@ Section InnerLoop. - have mu := model_updates mr. setoid_rewrite eqprem at 1 in mu. eapply strictly_updates_is_update_of_restrict in upd; tea. - apply check_model_spec in eqm as [Wconcl' [sumr ->]]. + apply check_model_spec in eqm as [Wconcl' [sumr eqw]]. have tr := strictly_updates_trans upd sumr. eapply strictly_updates_clauses_W; tea. { intros ?. now rewrite ClausesProp.union_sym union_diff_cls. } { have incl := model_incl mr. apply strictly_updates_incl in sumr. - have hdiff := clauses_conclusions_diff_left cls W (cls ⇂ W). lsets. } + have hdiff := clauses_conclusions_diff_left cls W (cls ⇂ W). + clear -clsW hdiff incl sumr. + lsets. } - have mW : model_of W m. { now eapply strictly_updates_model_of in upd. } have tmr : model_of W (model_model mr). diff --git a/common/theories/Universes.v b/common/theories/Universes.v index db02017af..801f1aad1 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -860,27 +860,23 @@ Qed. *) Module ConstraintType. - Inductive t_ : Set := Le (z : Z) | Eq. + Inductive t_ : Set := Le | Eq. Derive NoConfusion EqDec for t_. Definition t := t_. Definition eq : t -> t -> Prop := eq. Definition eq_equiv : Equivalence eq := _. - Definition Le0 := Le 0. - Definition Lt := Le 1. - Inductive lt_ : t -> t -> Prop := - | LeLe n m : (n < m)%Z -> lt_ (Le n) (Le m) - | LeEq n : lt_ (Le n) Eq. + | LeEq : lt_ Le Eq. Derive Signature for lt_. Definition lt := lt_. Global Instance lt_strorder : StrictOrder lt. Proof. constructor. - - intros []; intro X; inversion X. lia. - - intros ? ? ? X Y; invs X; invs Y; constructor. lia. + - intros []; intro X; inversion X. + - intros ? ? ? X Y; invs X; invs Y; constructor. Qed. Global Instance lt_compat : Proper (eq ==> eq ==> iff) lt. @@ -890,22 +886,20 @@ Module ConstraintType. Definition compare (x y : t) : comparison := match x, y with - | Le n, Le m => Z.compare n m - | Le _, Eq => Datatypes.Lt + | Le, Le => Datatypes.Eq + | Le, Eq => Datatypes.Lt | Eq, Eq => Datatypes.Eq | Eq, _ => Datatypes.Gt end. Lemma compare_spec x y : CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). Proof. - destruct x, y; repeat constructor. simpl. - destruct (Z.compare_spec z z0); simpl; constructor. - subst; constructor. now constructor. now constructor. + destruct x, y; repeat constructor. Qed. Lemma eq_dec x y : {eq x y} + {~ eq x y}. Proof. - unfold eq. decide equality. apply Z.eq_dec. + unfold eq. decide equality. Qed. End ConstraintType. @@ -1297,14 +1291,14 @@ Delimit Scope univ_scope with u. Section Univ. Context {cf: checker_flags}. - Inductive satisfies0 (v : valuation) : LevelConstraint.t -> Prop := - | satisfies0_Lt (l l' : Level.t) (z : Z) : (Z.of_nat (val v l) <= Z.of_nat (val v l') - z)%Z - -> satisfies0 v (l, ConstraintType.Le z, l') - | satisfies0_Eq (l l' : Level.t) : val v l = val v l' + Inductive satisfies0 (v : valuation) : UnivConstraint.t -> Prop := + | satisfies0_Lt (l l' : Universe.t) : (val v l <= val v l')%nat + -> satisfies0 v (l, ConstraintType.Le, l') + | satisfies0_Eq (l l' : Universe.t) : val v l = val v l' -> satisfies0 v (l, ConstraintType.Eq, l'). - Definition satisfies v : ConstraintSet.t -> Prop := - ConstraintSet.For_all (satisfies0 v). + Definition satisfies v : UnivConstraintSet.t -> Prop := + UnivConstraintSet.For_all (satisfies0 v). Lemma satisfies_union v φ1 φ2 : satisfies v (CS.union φ1 φ2) diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v index f5a20a3ba..2189af6d8 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -2,7 +2,7 @@ (* This module provides an instantiation of the deciders for universe checking, i.e. for constraints on non-empty level expressions (l, k) where k ∈ 𝐍 *) -From Stdlib Require Import ssreflect ssrbool. +From Stdlib Require Import ssreflect ssrfun ssrbool. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils. @@ -16,7 +16,6 @@ Import Universes. Module MoreLevel. Import Universes. Include Level. - Definition to_string := string_of_level. End MoreLevel. @@ -94,11 +93,8 @@ End LevelExprZSet. Module LevelExprZSetFacts := WFactsOn LevelExprZ LevelExprZSet. Module LevelExprZSetProp := MSetProperties.OrdProperties LevelExprZSet. -Module LevelSet. - Include MakeWithLeibniz Level. -End LevelSet. Module LS <: LevelSets. - Module Level := MoreLevel . + Module Level := MoreLevel. Module LevelSet := LevelSet. Module LevelExpr := LevelExprZ. Module LevelExprSet := LevelExprZSet. @@ -190,7 +186,6 @@ Next Obligation. congruence. Qed. - Module UnivLoopChecking. Module LoopCheck := LoopChecking LS. @@ -219,8 +214,11 @@ Module UnivLoopChecking. Record univ_model := { model : LoopCheck.model; constraints : UnivConstraintSet.t; - repr_constraints : forall c, UnivConstraintSet.In c constraints <-> - Clauses.Subset (LoopCheck.to_clauses (to_constraint c)) (LoopCheck.Impl.Abstract.clauses model) }. + repr_constraints : forall c, UnivConstraintSet.In c constraints -> + Clauses.Subset (LoopCheck.to_clauses (to_constraint c)) (LoopCheck.Impl.Abstract.clauses model); + repr_constraints_inv : forall cl, Clauses.In cl (LoopCheck.Impl.Abstract.clauses model) -> + exists c, UnivConstraintSet.In c constraints /\ Clauses.In cl (LoopCheck.to_clauses (to_constraint c)) + }. Module C := LoopCheck.Impl.I.Model.Model.Clauses. Import C. @@ -235,6 +233,59 @@ Module UnivLoopChecking. rewrite Z2Nat.id //. Qed. + Lemma in_to_atoms a u : + LevelExprSet.In (a.1, Z.of_nat a.2) (to_atoms u) <-> Universes.LevelExprSet.In a u. + Proof. + destruct a as [l k]. + rewrite /to_atoms //=. + split. + - move/to_levelexprzset_spec_2 => [] hin _. + now rewrite Nat2Z.id in hin. + - now move/to_levelexprzset_spec_1. + Qed. + + Lemma univ_levels_spec l u : + Universes.LevelSet.In l (Universes.LevelExprSet.levels u) <-> + exists k, Universes.LevelExprSet.In (l, k) u. + Proof. + rewrite /Universes.LevelExprSet.levels. + eapply Universes.LevelExprSetProp.fold_rec. + - move=> s' he; split. lsets. + move=> [k hin]. firstorder. + - move=> x a s' s'' hin hnin hadd. + rewrite Universes.LevelSet.add_spec. + split. + rewrite H. firstorder. + subst l. exists x.2. apply hadd. left. now destruct x. + intros [k' hin']. apply hadd in hin' as []; subst. + now left. now right; firstorder. + Qed. + + Lemma levels_in_to_atoms l u : + LevelSet.In l (levels (to_atoms u)) <-> Universes.LevelSet.In l (Universes.LevelExprSet.levels u). + Proof. + rewrite levelexprset_levels_spec. + rewrite /in_to_atoms. + split. + - move=> [] k. move/to_levelexprzset_spec_2 => [] hin _. + apply univ_levels_spec. now eexists. + - rewrite univ_levels_spec => -[] k hin. + exists (Z.of_nat k). now rewrite (in_to_atoms (l, k)). + Qed. + + Definition to_atom '(l, k) : LevelExpr.t := (l, Z.of_nat k). + + Lemma exists_to_atoms_spec f u : + LevelExprSet.Exists f (to_atoms u) <-> + exists le, Universes.LevelExprSet.In le u /\ f (to_atom le). + Proof. + rewrite /to_atoms //=; split; rewrite /LevelExprSet.Exists. + - move=> [] [] l k [] /to_levelexprzset_spec_2 [] hin hpos hf. + eexists; split; tea. cbn. rewrite Z2Nat.id //. + - move=> [] [] l k [] hin hf. exists (l, Z.of_nat k); split => //. + now apply to_levelexprzset_spec_1. + Qed. + Lemma exists_to_atoms_2 a (u : Universe.t) : Universes.LevelExprSet.Exists (fun lk => a = lk) u -> LevelExprSet.Exists (fun lk : LevelExprSet.elt => a = (lk.1, Z.to_nat lk.2)) (to_atoms u). @@ -245,38 +296,283 @@ Module UnivLoopChecking. rewrite Nat2Z.id //. Qed. + Definition choose (u : Universe.t) : Universes.LevelExpr.t := (Universes.NonEmptySetFacts.to_nonempty_list u).1. + Lemma choose_spec u : Universes.LevelExprSet.In (choose u) u. + Proof. + rewrite /choose. + have hs := Universes.NonEmptySetFacts.to_nonempty_list_spec u. + destruct Universes.NonEmptySetFacts.to_nonempty_list. cbn. + rewrite -Universes.LevelExprSet.elements_spec1 InA_In_eq -hs. + now constructor. + Qed. + + Definition choose_prems (u : premises) : LevelExpr.t := (NonEmptySetFacts.to_nonempty_list u).1. + Lemma choose_prems_spec u : LevelExprSet.In (choose_prems u) u. + Proof. + rewrite /choose_prems. + have hs := NonEmptySetFacts.to_nonempty_list_spec u. + destruct NonEmptySetFacts.to_nonempty_list. cbn. + rewrite -LevelExprSet.elements_spec1 InA_In_eq -hs. + now constructor. + Qed. + + Lemma clauses_of_le_nempty l r : ~ Clauses.Empty (LoopCheck.clauses_of_le l r). + Proof. + intros he. red in he. eapply he. + rewrite !LoopCheck.clauses_of_le_spec. + exists (choose_prems l). split; trea. + apply choose_prems_spec. + Qed. + + Lemma to_clauses_ne c : ~ Clauses.Empty (LoopCheck.to_clauses c). + Proof. + intros he. red in he. destruct c as [[l []] r]. + eapply he. apply LoopCheck.to_clauses_spec. + right. exists (choose_prems r). split; trea. apply choose_prems_spec. + eapply he. apply LoopCheck.to_clauses_spec. + exists (choose_prems l). split; trea. apply choose_prems_spec. + Qed. + + Equations? init_model : univ_model := init_model := {| model := LoopCheck.init_model; constraints := UnivConstraintSet.empty |}. - Proof. split; try ucsets. - move=> hyp; apply UnivConstraintSetFact.empty_iff. - destruct c as [[l d] r]. destruct d; cbn in hyp. - destruct Z.ltb. cbn in hyp. - move: hyp. rewrite /Clauses.Subset. - rw LoopCheck.clauses_of_le_spec. - move=> h. - have h' := fun a e => h _ (exists_to_atoms_2 _ _ e). - specialize (hyp ()) apply hyp. - 2:{ } - de -clset. + Proof. + move: H. now rewrite UnivConstraintSetFact.empty_iff. + move: H. now rewrite ClausesFact.empty_iff. + Qed. + + Local Obligation Tactic := idtac. + + Local Definition declare_levels_aux m l := + LevelSet.fold (fun l m => match LoopCheck.declare_level m l return _ with None => m | Some m => m end) l m. + + Lemma declare_levels_aux_spec m l : LoopCheck.levels (declare_levels_aux m l) =_lset + LevelSet.union l (LoopCheck.levels m). + Proof. + rewrite /declare_levels_aux. + eapply LevelSetProp.fold_rec. + - move=> s' he. lsets. + - move=> x a s' s'' hin hnin hadd heq. + apply LevelSetProp.Add_Equal in hadd. + destruct LoopCheck.declare_level eqn:decl. + * apply LoopCheck.declare_level_levels in decl as [hnin' ->]. + rewrite hadd heq. lsets. + * apply LoopCheck.declare_level_None in decl. + rewrite heq hadd. + rewrite heq LevelSet.union_spec in decl. + destruct decl => //. lsets. + Qed. + + Lemma declare_levels_aux_clauses m l : + LoopCheck.clauses (declare_levels_aux m l) =_clset LoopCheck.clauses m. + Proof. + rewrite /declare_levels_aux. + eapply LevelSetProp.fold_rec. + - move=> s' he. clsets. + - move=> x a s' s'' hin hnin hadd heq. + apply LevelSetProp.Add_Equal in hadd. + destruct LoopCheck.declare_level eqn:hd => //. + rewrite -heq. + apply LoopCheck.declare_level_clauses in hd. + unfold LoopCheck.clauses. + now rewrite hd. + Qed. (* We ignore errors here, which can happen only if the levels are already declared *) - Definition declare_levels (m : univ_model) (l : LevelSet.t) := - LevelSet.fold (fun l m => match LoopCheck.declare_level l m with None => m | Some m => m end) l m. + Program Definition declare_levels (m : univ_model) (l : LevelSet.t) := + {| model := declare_levels_aux m.(model) l; constraints := m.(constraints); |}. + Next Obligation. + Proof. + intros m l c. + rewrite [LoopCheck.Impl.Abstract.clauses _]declare_levels_aux_clauses => hin. + move: (repr_constraints m c hin) => h. + etransitivity; tea. reflexivity. + Qed. + Next Obligation. + move=> m l cl. + rewrite [LoopCheck.Impl.Abstract.clauses _]declare_levels_aux_clauses => hin. + now exact: repr_constraints_inv m cl hin. + Qed. - Definition enforce_level_constraints (m : univ_model) (l : ConstraintSet.t) := + Equations? enforce m (c : UnivConstraint.t) : option _ := + enforce m c with inspect (LoopCheck.enforce m.(model) (to_constraint c)) := + | exist None eq => None + | exist (Some (inl m')) eq => Some (inl {| model := m'; constraints := UnivConstraintSet.add c m.(constraints) |}) + | exist (Some (inr loop)) eq => Some (inr loop). + Proof. + - move=> c'. + move/LoopCheck.enforce_clauses: eq. + rewrite /LoopCheck.clauses => ->. rewrite UnivConstraintSet.add_spec => -[]. + * move=> ->. clsets. + * move=> hin. + move: (repr_constraints m c' hin) => h. clsets. + - move/LoopCheck.enforce_clauses: eq. + rewrite /LoopCheck.clauses => -> c'. + rewrite UnivLoopChecking.Clauses.union_spec => -[]. + * move/(repr_constraints_inv m c') => [] c2 []. + exists c2. split => //. + rewrite UnivConstraintSet.add_spec. now right. + * move=> hin. exists c. split => //. + rewrite UnivConstraintSet.add_spec. now left. + Qed. + + Lemma in_clause_levels_of_le lev l r : LevelSet.In lev (clauses_levels (LoopCheck.clauses_of_le l r)) <-> + LevelSet.In lev (levels l) \/ LevelSet.In lev (levels r). + Proof. + rewrite clauses_levels_spec. + setoid_rewrite LoopCheck.clauses_of_le_spec. + split. + - intros [cl [hex hin]]. + apply clause_levels_spec in hin. + destruct hex as [le [inl ->]]. cbn in *. destruct hin; auto. subst. + left. now apply LoopCheck.Impl.in_levels. + - move=> [] hin. + * eapply levelexprset_levels_spec in hin as [k hin]. + exists (r, (lev, k)). split => //. exists (lev, k). split => //. + apply clause_levels_spec. now right. + * eapply levelexprset_levels_spec in hin as [k hin]. + exists (r, choose_prems l). split => //. exists (choose_prems l). split => //. + apply choose_prems_spec. + apply clause_levels_spec. left. + apply levelexprset_levels_spec. now exists k. + Qed. + + Lemma univ_in_add n u : Universes.LevelSet.Equal + (Universes.LevelExprSet.levels (Universe.add n u)) + (Universes.LevelExprSet.levels u). + Proof. + intros l. rewrite !univ_levels_spec. + rewrite /Universe.add. rw Universes.NonEmptySetFacts.map_spec. + firstorder. destruct x0; noconf H0; cbn. now exists n0. + exists (n + x), (l, x). split => //. + Qed. + + Lemma clauses_levels_union cls cls' : clauses_levels (Clauses.union cls cls') =_lset + LevelSet.union (clauses_levels cls) (clauses_levels cls'). + Proof. + intros l. + rewrite clauses_levels_spec LevelSet.union_spec. + rw Clauses.union_spec; rewrite !clauses_levels_spec. + rw clause_levels_spec. firstorder. + Qed. + + Definition univ_constraint_levels (c : UnivConstraint.t) := + let '(l, d, r) := c in + LevelSet.union (Universes.LevelExprSet.levels l) + (Universes.LevelExprSet.levels r). + + Lemma declared_univ_cstr_levels_spec ls c : + declared_univ_cstr_levels ls c <-> + univ_constraint_levels c ⊂_lset ls. + Proof. + destruct c as [[l d] r]. + rewrite /declared_univ_cstr_levels /univ_constraint_levels. + split. + - move=> [] hl hr l'. + rewrite LevelSet.union_spec. firstorder. + - intros he; split => l'. specialize (he l'). + rewrite LevelSet.union_spec in he. firstorder. + specialize(he l'). rewrite LevelSet.union_spec in he. firstorder. + Qed. + + Definition constraint_levels (c : LoopCheck.constraint) := + LevelSet.union (levels c.1.1) (levels c.2). + + Lemma in_constraint_levels_to_constraint c : + forall l, LevelSet.In l (constraint_levels (to_constraint c)) <-> + LevelSet.In l (univ_constraint_levels c). + Proof. + intros l; destruct c as [[l' d] r]; cbn. + rewrite /constraint_levels. rewrite !LevelSet.union_spec. cbn. + destruct d. + destruct Z.ltb. + - rewrite !levels_in_to_atoms. rewrite univ_in_add. firstorder. + - rewrite !levels_in_to_atoms. rewrite univ_in_add. firstorder. + - rewrite !levels_in_to_atoms. firstorder. + Qed. + + Lemma in_to_clauses_levels c : + forall l, LevelSet.In l (clauses_levels (LoopCheck.to_clauses c)) <-> + LevelSet.In l (constraint_levels c). + Proof. + intros l. + destruct c as [[l' d] r] => //=. + destruct d. rewrite clauses_levels_union LevelSet.union_spec. + rewrite /constraint_levels //= LevelSet.union_spec. + rewrite !in_clause_levels_of_le. firstorder. + rewrite /constraint_levels //= LevelSet.union_spec. + rewrite !in_clause_levels_of_le. firstorder. + Qed. + + Lemma ndecl_nin_levels ls c : + declared_univ_cstr_levels ls c <-> + clauses_levels (LoopCheck.to_clauses (to_constraint c)) ⊂_lset ls. + Proof. + rewrite declared_univ_cstr_levels_spec. + split; intros h. + - intros ?; rewrite in_to_clauses_levels in_constraint_levels_to_constraint. apply h. + - etransitivity; tea. intros ?. + now rewrite in_to_clauses_levels in_constraint_levels_to_constraint. + Qed. + + Lemma enforce_not_none m c : enforce m c <> None <-> + declared_univ_cstr_levels (LoopCheck.levels (model m)) c. + Proof. + have := @LoopCheck.enforce_not_None (model m) (to_constraint c). + rewrite /enforce. + destruct inspect as [[[] | ] eq]. simpl. + - intros. split => // _. + rewrite ndecl_nin_levels. apply H. now rewrite eq. + - intros. split => // _. + rewrite ndecl_nin_levels. apply H. now rewrite eq. + - intros. split => //=. + now move/ndecl_nin_levels/H; rewrite eq. + Qed. + + Lemma enforce_None m c : + enforce m c = None <-> ~ declared_univ_cstr_levels (LoopCheck.levels m.(model)) c. + Proof. + rewrite /enforce. + destruct inspect as [[[] | ] eq]. simpl. + - intros. split => //. + rewrite ndecl_nin_levels. + rewrite -LoopCheck.enforce_not_None eq; elim. congruence. + - intros. split => //=. + rewrite ndecl_nin_levels. + rewrite -LoopCheck.enforce_not_None eq; elim. congruence. + - cbn. rewrite ndecl_nin_levels. + rewrite -LoopCheck.enforce_not_None eq. split => //. congruence. + Qed. + + Definition levels m := LoopCheck.levels m.(model). + + Lemma enforce_model m c m' : + enforce m c = Some (inl m') -> levels m = levels m' /\ + UnivConstraintSet.Equal (UnivConstraintSet.add c (constraints m)) (constraints m'). + Proof. + funelim (enforce m c) => //=. + move=> [=] <-; cbn. rewrite /levels //=. + split. + - clear H Heqcall. now move/LoopCheck.enforce_levels: eq. + - clear H Heqcall. reflexivity. + Qed. + + Lemma model_satisfies m : + exists V, satisfies + + (* Definition enforce_level_constraints (m : univ_model) (l : ConstraintSet.t) := ConstraintSet.fold (fun c m => match m with | inl m => let c := (level_constraint_to_constraint c) in - match LoopCheck.enforce c m with + match LoopCheck.enforce m c with | None => (inr (c, None)) | Some (inl m) => (inl m) | Some (inr u) => (inr (c, Some u)) end | inr err => inr err - end) l (inl m). + end) l (inl m). *) Import LoopCheck.Impl.I.Model.Model.Clauses.FLS. @@ -289,12 +585,4 @@ clset. in (from_atoms l, d', from_atoms r). - Definition enforce (c : UnivConstraint.t) (m : univ_model) := - match LoopCheck.enforce (to_constraint c) m with - | - - - - - End UnivLoopChecking. From d4c437b28b9c5e714f2b34bb35bca4427977e2b3 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 13 Sep 2025 23:43:10 +0200 Subject: [PATCH 051/164] WIP refactoring for a single nonempty level expr set implementation --- common/_RocqProject.in | 2 +- common/theories/Environment.v | 2 +- common/theories/EnvironmentTyping.v | 32 +- common/theories/LoopChecking/Common.v | 8 - common/theories/LoopChecking/Interfaces.v | 118 --- common/theories/Reflect.v | 20 +- common/theories/Universes.v | 816 +++++------------- common/theories/UniversesDec.v | 104 +-- common/theories/uGraph.v | 210 ++--- erasure/theories/EArities.v | 4 +- erasure/theories/ErasureFunction.v | 2 +- examples/demo.v | 4 +- examples/metarocq_tour_prelude.v | 2 +- examples/typing_correctness.v | 4 +- .../Conversion/PCUICUnivSubstitutionConv.v | 68 +- .../Conversion/PCUICWeakeningEnvConv.v | 10 +- pcuic/theories/PCUICConfluence.v | 4 +- pcuic/theories/PCUICExpandLetsCorrectness.v | 4 +- pcuic/theories/PCUICGlobalEnv.v | 2 +- pcuic/theories/PCUICInductiveInversion.v | 42 +- pcuic/theories/PCUICSubstitution.v | 2 +- pcuic/theories/PCUICUnivLevels.v | 20 +- pcuic/theories/PCUICWeakeningEnv.v | 46 +- .../Typing/PCUICUnivSubstitutionTyp.v | 2 +- quotation/theories/ToPCUIC/Common/Universes.v | 6 +- .../Universes/ConstraintSet/Instances.v | 4 +- .../ConstraintSetExtraDecide/Instances.v | 2 +- .../ConstraintSetExtraOrdProp/Instances.v | 2 +- .../ConstraintSetOrdProp/Instances.v | 2 +- .../QuotationOf/Common/Universes/Instances.v | 2 +- .../theories/ToTemplate/Common/Universes.v | 6 +- .../Universes/ConstraintSet/Instances.v | 4 +- .../ConstraintSetExtraDecide/Instances.v | 2 +- .../ConstraintSetExtraOrdProp/Instances.v | 2 +- .../ConstraintSetOrdProp/Instances.v | 2 +- .../QuotationOf/Common/Universes/Instances.v | 2 +- safechecker/theories/PCUICEqualityDec.v | 2 +- safechecker/theories/PCUICErrors.v | 2 +- safechecker/theories/PCUICSafeChecker.v | 36 +- safechecker/theories/PCUICSafeConversion.v | 2 +- safechecker/theories/PCUICTypeChecker.v | 10 +- safechecker/theories/PCUICWfEnv.v | 16 +- safechecker/theories/PCUICWfEnvImpl.v | 4 +- .../theories/PCUICToTemplateCorrectness.v | 4 +- template-rocq/src/ast_denoter.ml | 2 +- template-rocq/src/ast_quoter.ml | 4 +- template-rocq/src/constr_reification.ml | 8 +- template-rocq/theories/AstUtils.v | 2 +- template-rocq/theories/Checker.v | 8 +- template-rocq/theories/Constants.v | 8 +- .../theories/LoopChecking/UnivLoopChecking.v | 31 +- template-rocq/theories/PartialLoopChecking.v | 13 - template-rocq/theories/TemplateLoopChecking.v | 2 +- template-rocq/theories/Typing.v | 4 +- .../theories/LoopCheckingPlugin.v | 2 +- test-suite/univ.v | 4 +- utils/_RocqProject | 2 + utils/theories/All_Forall.v | 2 +- utils/theories/MRList.v | 4 +- utils/theories/MRMSets.v | 2 +- utils/theories/MRPrelude.v | 25 +- utils/theories/MRUtils.v | 16 - utils/theories/NonEmptyLevelExprSet.v | 478 ++++++++++ utils/theories/utils.v | 3 +- 64 files changed, 1122 insertions(+), 1138 deletions(-) create mode 100644 utils/theories/NonEmptyLevelExprSet.v diff --git a/common/_RocqProject.in b/common/_RocqProject.in index dcd1ed6e2..992b49d6c 100644 --- a/common/_RocqProject.in +++ b/common/_RocqProject.in @@ -1,7 +1,7 @@ -R theories MetaRocq.Common theories/Primitive.v -theories/uGraph.v +# theories/uGraph.v theories/config.v theories/Kernames.v theories/Universes.v diff --git a/common/theories/Environment.v b/common/theories/Environment.v index 08d4dfe69..a425af9ef 100644 --- a/common/theories/Environment.v +++ b/common/theories/Environment.v @@ -900,7 +900,7 @@ Module Environment (T : Term). tProd {| binder_name := nAnon; binder_relevance := rel_of_Type |} dom (lift 1 0 codom). - Definition array_uctx := ([nAnon], ConstraintSet.empty). + Definition array_uctx := ([nAnon], UnivConstraintSet.empty). Definition primitive_invariants (p : prim_tag) (cdecl : constant_body) := match p with diff --git a/common/theories/EnvironmentTyping.v b/common/theories/EnvironmentTyping.v index ea368eaf4..6ed4f360a 100644 --- a/common/theories/EnvironmentTyping.v +++ b/common/theories/EnvironmentTyping.v @@ -226,7 +226,7 @@ Module Lookup (T : Term) (E : EnvironmentSig T). be ensured if we added [global_constraints] as well as a coercion, as it would forget the extension's constraints. *) - Definition global_constraints (Σ : global_env) : ConstraintSet.t := + Definition global_constraints (Σ : global_env) : UnivConstraintSet.t := snd Σ.(universes). Definition global_uctx (Σ : global_env) : ContextSet.t := @@ -235,12 +235,12 @@ Module Lookup (T : Term) (E : EnvironmentSig T). Definition global_ext_levels (Σ : global_env_ext) : LevelSet.t := LevelSet.union (levels_of_udecl (snd Σ)) (global_levels Σ.1.(universes)). - Definition global_ext_constraints (Σ : global_env_ext) : ConstraintSet.t := - ConstraintSet.union + Definition global_ext_constraints (Σ : global_env_ext) : UnivConstraintSet.t := + UnivConstraintSet.union (constraints_of_udecl (snd Σ)) (global_constraints Σ.1). - Coercion global_ext_constraints : global_env_ext >-> ConstraintSet.t. + Coercion global_ext_constraints : global_env_ext >-> UnivConstraintSet.t. Definition global_ext_uctx (Σ : global_env_ext) : ContextSet.t := (global_ext_levels Σ, global_ext_constraints Σ). @@ -256,7 +256,7 @@ Module Lookup (T : Term) (E : EnvironmentSig T). (** Check that [uctx] instantiated at [u] is consistent with the current universe graph. *) - Definition consistent_instance `{checker_flags} (lvs : LevelSet.t) (φ : ConstraintSet.t) uctx (u : Instance.t) := + Definition consistent_instance `{checker_flags} (lvs : LevelSet.t) (φ : UnivConstraintSet.t) uctx (u : Instance.t) := match uctx with | Monomorphic_ctx => List.length u = 0 | Polymorphic_ctx c => @@ -1279,7 +1279,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Open Scope type_scope. Definition univs_ext_constraints univs φ := - ConstraintSet.union (constraints_of_udecl φ) univs. + UnivConstraintSet.union (constraints_of_udecl φ) univs. Definition satisfiable_udecl (univs : ContextSet.t) φ := consistent (univs_ext_constraints (ContextSet.constraints univs) φ). @@ -1297,7 +1297,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT let global_levels := global_levels univs in let all_levels := LevelSet.union levels global_levels in LevelSet.For_all (fun l => ~ LevelSet.In l global_levels) levels - /\ ConstraintSet.For_all (declared_cstr_levels all_levels) (constraints_of_udecl udecl) + /\ UnivConstraintSet.For_all (declared_univ_cstr_levels all_levels) (constraints_of_udecl udecl) /\ satisfiable_udecl univs udecl /\ valid_on_mono_udecl univs udecl. @@ -1425,22 +1425,22 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT ((lift_level n l, r), lift_level n l'). Definition lift_constraints n cstrs := - ConstraintSet.fold (fun elt acc => ConstraintSet.add (lift_constraint n elt) acc) - cstrs ConstraintSet.empty. + UnivConstraintSet.fold (fun elt acc => UnivConstraintSet.add (lift_constraint n elt) acc) + cstrs UnivConstraintSet.empty. Definition level_var_instance n (inst : list name) := mapi_rec (fun i _ => Level.lvar i) inst n. Fixpoint variance_cstrs (v : list Variance.t) (u u' : Instance.t) := match v, u, u' with - | _, [], [] => ConstraintSet.empty + | _, [], [] => UnivConstraintSet.empty | v :: vs, u :: us, u' :: us' => match v with | Variance.Irrelevant => variance_cstrs vs us us' - | Variance.Covariant => ConstraintSet.add (u, ConstraintType.Le 0, u') (variance_cstrs vs us us') - | Variance.Invariant => ConstraintSet.add (u, ConstraintType.Eq, u') (variance_cstrs vs us us') + | Variance.Covariant => UnivConstraintSet.add (u, ConstraintType.Le 0, u') (variance_cstrs vs us us') + | Variance.Invariant => UnivConstraintSet.add (u, ConstraintType.Eq, u') (variance_cstrs vs us us') end - | _, _, _ => (* Impossible due to on_variance invariant *) ConstraintSet.empty + | _, _, _ => (* Impossible due to on_variance invariant *) UnivConstraintSet.empty end. (** This constructs a duplication of the polymorphic universe context of the inductive, @@ -1454,9 +1454,9 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT let (inst, cstrs) := auctx in let u' := level_var_instance 0 inst in let u := lift_instance #|inst| u' in - let cstrs := ConstraintSet.union cstrs (lift_constraints #|inst| cstrs) in + let cstrs := UnivConstraintSet.union cstrs (lift_constraints #|inst| cstrs) in let cstrv := variance_cstrs v u u' in - let auctx' := (inst ++ inst, ConstraintSet.union cstrs cstrv) in + let auctx' := (inst ++ inst, UnivConstraintSet.union cstrs cstrv) in Some (Polymorphic_ctx auctx', u, u') end. @@ -1783,7 +1783,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Definition on_global_univs (c : ContextSet.t) := let levels := global_levels c in let cstrs := ContextSet.constraints c in - ConstraintSet.For_all (declared_cstr_levels levels) cstrs /\ + UnivConstraintSet.For_all (declared_univ_cstr_levels levels) cstrs /\ LS.For_all (negb ∘ Level.is_var) levels /\ consistent cstrs. diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v index 1e80553f5..66dd24d9a 100644 --- a/common/theories/LoopChecking/Common.v +++ b/common/theories/LoopChecking/Common.v @@ -11,14 +11,6 @@ Set Equations Transparent. Ltac rw l := rewrite_strat (topdown l). Ltac rw_in l H := rewrite_strat (topdown l) in H. -Notation fwd := (ltac:(move=> /(_ _)/Wrap[])). - -(* TODO move *) -Arguments exist {A P}. -Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. - -Arguments symmetry {A R Symmetric} {x y}. - #[program] Global Instance reflect_eq_Z : ReflectEq Z := { eqb := Z.eqb }. diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 10ae18580..e25a4fdfe 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -39,41 +39,11 @@ Module FMapOrderedType_from_UsualOrderedType (O : UsualOrderedType). Definition eq_dec : forall x y : O.t, {eq x y} + {~ eq x y} := eq_dec. End FMapOrderedType_from_UsualOrderedType. -Module Type LevelOrderedType. - Include UsualOrderedType. - Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. -End LevelOrderedType. - -Module Type LevelOrderedTypeWithReflect. - Include LevelOrderedType. - - Parameter reflect_eq : ReflectEq t. - Parameter to_string : t -> string. -End LevelOrderedTypeWithReflect. - Module Type FMapOTInterface (E : UsualOrderedType). Module OT := FMapOrderedType_from_UsualOrderedType E. Include FMapInterface.Sfun OT. End FMapOTInterface. -Module Type LevelSet_fun (Level : UsualOrderedType). - Include S with Module E := Level. -End LevelSet_fun. - -Module Type LevelExprItf (Level : LevelOrderedType). - Include UsualOrderedType with Definition t := (Level.t * Z)%type. - Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. -End LevelExprItf. - -Module Type LevelExprSet_fun (Level : LevelOrderedType) (LevelExpr : LevelExprItf Level). - Include SWithLeibniz with Module E := LevelExpr. - - Record nonEmptyLevelExprSet - := { t_set :> t ; - t_ne : is_empty t_set = false }. - -End LevelExprSet_fun. - Module Type LevelSets. (* Signature of levels: decidable, ordered type *) Declare Module Level : LevelOrderedTypeWithReflect. @@ -307,26 +277,6 @@ Module NonEmptySetFacts. apply or_iff_compat_l. apply in_rev. Qed. - Program Definition map (f : LevelExpr.t -> LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := - {| t_set := LevelExprSetProp.of_list (List.map f (LevelExprSet.elements u)) |}. - Next Obligation. - have hs := to_nonempty_list_spec u. - destruct (to_nonempty_list u). rewrite -hs. cbn. - apply not_Empty_is_empty => he. apply (he (f t)). - lesets. - Qed. - - Lemma map_spec f u e : - LevelExprSet.In e (map f u) <-> exists e0, LevelExprSet.In e0 u /\ e = (f e0). - Proof. - unfold map; cbn. - rewrite LevelExprSetProp.of_list_1 InA_In_eq in_map_iff. - split. - - intros [x [<- hin]]. exists x. split => //. - rewrite -InA_In_eq in hin. now apply LevelExprSet.elements_spec1 in hin. - - intros [x [hin ->]]. exists x. split => //. - rewrite -InA_In_eq. now apply LevelExprSet.elements_spec1. - Qed. Program Definition non_empty_union (u v : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := {| t_set := LevelExprSet.union u v |}. @@ -498,41 +448,6 @@ Qed. Lemma non_W_atoms_subset W l : non_W_atoms W l ⊂_leset l. Proof. intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec. Qed. -Lemma levelexprset_levels_spec_aux l (e : LevelExprSet.t) acc : - LevelSet.In l (LevelExprSet.fold (fun le : LevelExprSet.elt => LevelSet.add (level le)) e acc) <-> - (exists k, LevelExprSet.In (l, k) e) \/ LevelSet.In l acc. -Proof. - eapply LevelExprSetProp.fold_rec. - - intros. - intuition auto. destruct H1 as [k hin]. lesets. - - intros x a s' s'' hin nin hadd ih. - rewrite LevelSet.add_spec. - split. - * intros [->|]. - left. exists x.2. red in H. subst. - apply hadd. cbn. left. now destruct x. - apply ih in H. - intuition auto. - left. destruct H0 as [k Hk]. exists k. apply hadd. now right. - * intros [[k ins'']|inacc]. - eapply hadd in ins''. destruct ins''; subst. - + now left. - + right. apply ih. now left; exists k. - + right. intuition auto. -Qed. - -Lemma levelexprset_levels_spec l (e : LevelExprSet.t) : - LevelSet.In l (levels e) <-> exists k, LevelExprSet.In (l, k) e. -Proof. - rewrite levelexprset_levels_spec_aux. intuition auto. lsets. -Qed. - -Lemma univ_non_empty (u : nonEmptyLevelExprSet) : ~ LevelSet.Empty (levels u). -Proof. intros he. have := t_ne u. move/not_Empty_is_empty. - intros he'. apply he'. intros [l k] hin. red in he. specialize (he l). apply he. - rewrite levelexprset_levels_spec. now exists k. -Qed. - Lemma levels_exprs_non_W_atoms {W prem} : LevelSet.Equal (levels (non_W_atoms W prem)) (LevelSet.diff (levels prem) W). Proof. @@ -571,39 +486,6 @@ Proof. lsets. Qed. -Lemma premises_elim {P : nonEmptyLevelExprSet -> Prop} : - (forall le, P (singleton le)) -> - (forall le prems, P prems -> ~ LevelExprSet.In le prems -> P (add le prems)) -> - forall prems, P prems. -Proof. - intros hs ha. - intros []. - revert t_set0 t_ne0. - apply: LevelExprSetProp.set_induction; eauto. - - move=> s /LevelExprSetFact.is_empty_1 he ne; exfalso => //. congruence. - - intros s s' IH x nin hadd hne. - destruct (LevelExprSet.is_empty s) eqn:hem in |- . - eapply LevelExprSetFact.is_empty_2 in hem. - assert (singleton x = {| t_set := s'; t_ne := hne |}) as <- => //. - unfold singleton. apply eq_univ_equal. cbn. - intros a. specialize (hadd a). rewrite hadd. - rewrite LevelExprSet.singleton_spec. firstorder. subst. reflexivity. - specialize (IH hem). - specialize (ha x _ IH). - assert (LevelExprSet.Equal (add x {| t_set := s; t_ne := hem|}) {| t_set := s'; t_ne := hne |}). - 2:{ apply eq_univ_equal in H. now rewrite -H. } - intros x'. specialize (hadd x'). rewrite LevelExprSet.add_spec. - cbn. firstorder. subst x'. now left. -Qed. - -Lemma map_map f g x : map f (map g x) = map (f ∘ g) x. -Proof. - apply eq_univ_equal. - intros lk. - rewrite !map_spec. setoid_rewrite map_spec. - firstorder eauto. subst. firstorder. -Qed. - Definition strict_subset (s s' : LevelSet.t) := LevelSet.Subset s s' /\ ~ LevelSet.Equal s s'. diff --git a/common/theories/Reflect.v b/common/theories/Reflect.v index c5cc121f8..e8426d86e 100644 --- a/common/theories/Reflect.v +++ b/common/theories/Reflect.v @@ -381,19 +381,19 @@ Module LevelSetsUIP. End LevelSetsUIP. Module ConstraintSetsUIP. - Import ConstraintSet.Raw. + Import UnivConstraintSet.Raw. Fixpoint cs_tree_eqb (x y : t) := match x, y with - | ConstraintSet.Raw.Leaf, ConstraintSet.Raw.Leaf => true - | ConstraintSet.Raw.Node h l o r, ConstraintSet.Raw.Node h' l' o' r' => + | UnivConstraintSet.Raw.Leaf, UnivConstraintSet.Raw.Leaf => true + | UnivConstraintSet.Raw.Node h l o r, UnivConstraintSet.Raw.Node h' l' o' r' => eqb h h' && cs_tree_eqb l l' && eqb o o' && cs_tree_eqb r r' | _, _ => false end. - Scheme cs_tree_rect := Induction for ConstraintSet.Raw.tree Sort Type. + Scheme cs_tree_rect := Induction for UnivConstraintSet.Raw.tree Sort Type. - #[global,program] Instance cs_tree_reflect : ReflectEq ConstraintSet.Raw.t := + #[global,program] Instance cs_tree_reflect : ReflectEq UnivConstraintSet.Raw.t := {| eqb := cs_tree_eqb |}. Next Obligation. induction x using cs_tree_rect; destruct y; try constructor; auto; try congruence. @@ -405,10 +405,10 @@ Module ConstraintSetsUIP. Qed. Definition eqb_ConstraintSet x y := - eqb (ConstraintSet.this x) (ConstraintSet.this y). + eqb (UnivConstraintSet.this x) (UnivConstraintSet.this y). - Derive NoConfusion for ConstraintSet.Raw.tree. - Derive Signature for ConstraintSet.Raw.bst. + Derive NoConfusion for UnivConstraintSet.Raw.tree. + Derive Signature for UnivConstraintSet.Raw.bst. Lemma ok_irrel (x : t) (o o' : Ok x) : o = o'. Proof. @@ -423,11 +423,11 @@ Module ConstraintSetsUIP. apply levelconstraint_lt_irrel. Qed. - #[global,program] Instance reflect_ConstraintSet : ReflectEq ConstraintSet.t := + #[global,program] Instance reflect_ConstraintSet : ReflectEq UnivConstraintSet.t := {| eqb := eqb_ConstraintSet |}. Next Obligation. intros [thisx okx] [thisy oky]. - unfold eqb_ConstraintSet. cbn. + unfold eqb_UnivConstraintSet. cbn. cbn -[eqb]. destruct (eqb_spec thisx thisy); subst; constructor. - f_equal. apply ok_irrel. diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 801f1aad1..8405396af 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -1,6 +1,6 @@ -From Stdlib Require Import OrdersAlt MSetList MSetAVL MSetFacts MSetProperties MSetDecide FMapAVL. +From Stdlib Require Import OrdersAlt Structures.OrdersEx MSetList MSetAVL MSetFacts MSetProperties MSetDecide FMapAVL. From Equations Require Import Equations. -From MetaRocq.Utils Require Import utils MRMSets MRFSets. +From MetaRocq.Utils Require Import utils MRMSets MRFSets NonEmptyLevelExprSet. From MetaRocq.Common Require Import BasicAst config. From Stdlib Require Import ssreflect. @@ -262,6 +262,8 @@ Module LevelExpr. Definition add (k : nat) (l : t) : t := (fst l, k + snd l). + Definition level : t -> Level.t := fst. + Definition get_level (e : t) : Level.t := fst e. Definition get_noprop (e : LevelExpr.t) := Some (fst e). @@ -342,12 +344,14 @@ End LevelExpr. Module LevelExprSet. Include MSetList.MakeWithLeibniz LevelExpr. - Definition levels (e : t) := - fold (fun le => LevelSet.add (LevelExpr.get_level le)) e LevelSet.empty. - - Record nonEmptyLevelExprSet - := { t_set : LevelExprSet.t ; - t_ne : LevelExprSet.is_empty t_set = false }. + Lemma reflect_eq : ReflectEq t. + Proof. + refine {| eqb := equal |}. + intros x y. have := (equal_spec x y). + destruct equal => //; constructor. + now apply eq_leibniz, H. + intros ->. destruct H. now forward H0 by reflexivity. + Qed. End LevelExprSet. Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. @@ -372,252 +376,19 @@ Qed. #[global] Instance levelexprset_eq_dec : Classes.EqDec LevelExprSet.t := Classes.eq_dec. -Import LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). - -Derive NoConfusion for nonEmptyLevelExprSet. - -(** This coercion allows to see the non-empty set as a regular [LevelExprSet.t] *) -Coercion t_set : nonEmptyLevelExprSet >-> LevelExprSet.t. - -Module NonEmptySetFacts. - Definition singleton (e : LevelExpr.t) : nonEmptyLevelExprSet - := {| t_set := LevelExprSet.singleton e; - t_ne := eq_refl |}. - - Lemma not_Empty_is_empty s : - ~ LevelExprSet.Empty s -> LevelExprSet.is_empty s = false. - Proof. - intro H. apply not_true_is_false. intro H'. - apply H. now apply LevelExprSetFact.is_empty_2 in H'. - Qed. - - Program Definition add (e : LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet - := {| t_set := LevelExprSet.add e u |}. - Next Obligation. - apply not_Empty_is_empty; intro H. - eapply H. eapply LevelExprSet.add_spec. - left; reflexivity. - Qed. - - Lemma add_spec e u e' : - LevelExprSet.In e' (add e u) <-> e' = e \/ LevelExprSet.In e' u. - Proof. - apply LevelExprSet.add_spec. - Qed. - - Definition add_list : list LevelExpr.t -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet - := List.fold_left (fun u e => add e u). - - Lemma add_list_spec l u e : - LevelExprSet.In e (add_list l u) <-> In e l \/ LevelExprSet.In e u. - Proof. - unfold add_list. rewrite <- fold_left_rev_right. - etransitivity. 2:{ eapply or_iff_compat_r. etransitivity. - 2: apply @InA_In_eq with (A:=LevelExpr.t). - eapply InA_rev. } - induction (List.rev l); cbn. - - split. intuition. intros [H|H]; tas. invs H. - - split. - + intro H. apply add_spec in H. destruct H as [H|H]. - * left. now constructor. - * apply IHl0 in H. destruct H as [H|H]; [left|now right]. - now constructor 2. - + intros [H|H]. inv H. - * apply add_spec; now left. - * apply add_spec; right. apply IHl0. now left. - * apply add_spec; right. apply IHl0. now right. - Qed. - - Program Definition to_nonempty_list (u : nonEmptyLevelExprSet) : LevelExpr.t * list LevelExpr.t - := match LevelExprSet.elements u with - | [] => False_rect _ _ - | e :: l => (e, l) - end. - Next Obligation. - destruct u as [u1 u2]; cbn in *. revert u2. - apply eq_true_false_abs. - unfold LevelExprSet.is_empty, LevelExprSet.Raw.is_empty, - LevelExprSet.elements, LevelExprSet.Raw.elements in *. - rewrite <- Heq_anonymous; reflexivity. - Qed. - - Lemma singleton_to_nonempty_list e : to_nonempty_list (singleton e) = (e, []). - Proof. reflexivity. Defined. - - Lemma to_nonempty_list_spec u : - let '(e, u') := to_nonempty_list u in - e :: u' = LevelExprSet.elements u. - Proof. - destruct u as [u1 u2]. - unfold to_nonempty_list; cbn. - set (l := LevelExprSet.elements u1). unfold l at 2 3 4. - set (e := (eq_refl: l = LevelExprSet.elements u1)); clearbody e. - destruct l. - - exfalso. revert u2. apply eq_true_false_abs. - unfold LevelExprSet.is_empty, LevelExprSet.Raw.is_empty, - LevelExprSet.elements, LevelExprSet.Raw.elements in *. - rewrite <- e; reflexivity. - - reflexivity. - Qed. - - Lemma to_nonempty_list_spec' u : - (to_nonempty_list u).1 :: (to_nonempty_list u).2 = LevelExprSet.elements u. - Proof. - pose proof (to_nonempty_list_spec u). - now destruct (to_nonempty_list u). - Qed. - - Lemma In_to_nonempty_list (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : - LevelExprSet.In e u - <-> e = (to_nonempty_list u).1 \/ In e (to_nonempty_list u).2. - Proof. - etransitivity. symmetry. apply LevelExprSet.elements_spec1. - pose proof (to_nonempty_list_spec' u) as H. - destruct (to_nonempty_list u) as [e' l]; cbn in *. - rewrite <- H; clear. etransitivity. apply InA_cons. - eapply or_iff_compat_l. apply InA_In_eq. - Qed. - - Lemma In_to_nonempty_list_rev (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : - LevelExprSet.In e u - <-> e = (to_nonempty_list u).1 \/ In e (List.rev (to_nonempty_list u).2). - Proof. - etransitivity. eapply In_to_nonempty_list. - apply or_iff_compat_l. apply in_rev. - Qed. - - Definition map (f : LevelExpr.t -> LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := - let '(e, l) := to_nonempty_list u in - add_list (List.map f l) (singleton (f e)). - - Lemma map_spec f u e : - LevelExprSet.In e (map f u) <-> exists e0, LevelExprSet.In e0 u /\ e = (f e0). - Proof. - unfold map. symmetry. etransitivity. - { eapply iff_ex; intro. eapply and_iff_compat_r. eapply In_to_nonempty_list. } - destruct (to_nonempty_list u) as [e' l]; cbn in *. - symmetry. etransitivity. eapply add_list_spec. - etransitivity. eapply or_iff_compat_l. apply LevelExprSet.singleton_spec. - etransitivity. eapply or_iff_compat_r. - apply in_map_iff. clear u. split. - - intros [[e0 []]|H]. - + exists e0. split. right; tas. congruence. - + exists e'. split; tas. left; reflexivity. - - intros [xx [[H|H] ?]]. - + right. congruence. - + left. exists xx. split; tas; congruence. - Qed. - - Program Definition non_empty_union (u v : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := - {| t_set := LevelExprSet.union u v |}. - Next Obligation. - apply not_Empty_is_empty; intro H. - assert (HH: LevelExprSet.Empty u). { - intros x Hx. apply (H x). - eapply LevelExprSet.union_spec. now left. } - apply LevelExprSetFact.is_empty_1 in HH. - rewrite t_ne in HH; discriminate. - Qed. - - Lemma elements_not_empty (u : nonEmptyLevelExprSet) : LevelExprSet.elements u <> []. - Proof. - destruct u as [u1 u2]; cbn; intro e. - unfold LevelExprSet.is_empty, LevelExprSet.elements, - LevelExprSet.Raw.elements in *. - rewrite e in u2; discriminate. - Qed. - - - Lemma eq_univ (u v : nonEmptyLevelExprSet) : - u = v :> LevelExprSet.t -> u = v. - Proof. - destruct u as [u1 u2], v as [v1 v2]; cbn. intros X; destruct X. - now rewrite (uip_bool _ _ u2 v2). - Qed. - - Lemma eq_univ' (u v : nonEmptyLevelExprSet) : - LevelExprSet.Equal u v -> u = v. - Proof. - intro H. now apply eq_univ, LevelExprSet.eq_leibniz. - Qed. - - Lemma eq_univ'' (u v : nonEmptyLevelExprSet) : - LevelExprSet.elements u = LevelExprSet.elements v -> u = v. - Proof. - intro H. apply eq_univ. - destruct u as [u1 u2], v as [v1 v2]; cbn in *; clear u2 v2. - destruct u1 as [u1 u2], v1 as [v1 v2]; cbn in *. - destruct H. now rewrite (uip_bool _ _ u2 v2). - Qed. - - Lemma univ_expr_eqb_true_iff (u v : nonEmptyLevelExprSet) : - LevelExprSet.equal u v <-> u = v. - Proof. - split. - - intros. - apply eq_univ'. now apply LevelExprSet.equal_spec. - - intros ->. now apply LevelExprSet.equal_spec. - Qed. - - Lemma univ_expr_eqb_comm (u v : nonEmptyLevelExprSet) : - LevelExprSet.equal u v <-> LevelExprSet.equal v u. - Proof. - transitivity (u = v). 2: transitivity (v = u). - - apply univ_expr_eqb_true_iff. - - split; apply eq_sym. - - split; apply univ_expr_eqb_true_iff. - Qed. - - - Lemma LevelExprSet_for_all_false f u : - LevelExprSet.for_all f u = false -> LevelExprSet.exists_ (negb ∘ f) u. - Proof. - intro H. rewrite LevelExprSetFact.exists_b. - rewrite LevelExprSetFact.for_all_b in H. - all: try now intros x y []. - induction (LevelExprSet.elements u); cbn in *; [discriminate|]. - apply andb_false_iff in H; apply orb_true_iff; destruct H as [H|H]. - left; now rewrite H. - right; now rewrite IHl. - Qed. - - Lemma LevelExprSet_For_all_exprs (P : LevelExpr.t -> Prop) (u : nonEmptyLevelExprSet) - : LevelExprSet.For_all P u - <-> P (to_nonempty_list u).1 /\ Forall P (to_nonempty_list u).2. - Proof. - etransitivity. - - eapply iff_forall; intro e. eapply imp_iff_compat_r. - apply In_to_nonempty_list. - - cbn; split. - + intro H. split. apply H. now left. - apply Forall_forall. intros x H0. apply H; now right. - + intros [H1 H2] e [He|He]. subst e; tas. - eapply Forall_forall in H2; tea. - Qed. - - -End NonEmptySetFacts. -Import NonEmptySetFacts. - - Module Universe. (** A universe / an algebraic expression is a list of universe expressions which is: - sorted - without duplicate - non empty *) + Module Q <: Quantity. + Include OrdersEx.Nat_as_OT. + Definition reflect_eq : ReflectEq t := _. + Definition eq_leibniz x y : eq x y -> x = y := fun e => e. + End Q. - Definition t := nonEmptyLevelExprSet. - - (* We use uip on the is_empty condition *) - #[global, program] Instance levelexprset_reflect : ReflectEq t := - { eqb x y := eqb x.(t_set) y.(t_set) }. - Next Obligation. - destruct (eqb_spec (t_set x) (t_set y)); constructor. - destruct x, y; cbn in *. subst. - now rewrite (uip t_ne0 t_ne1). - intros e; subst x; apply H. - reflexivity. - Qed. + Module NES := NonEmptyLevelExprSet Level Q LevelSet LevelExpr LevelExprSet. + Include NES. #[global] Instance eq_dec_univ0 : EqDec t := eq_dec. @@ -633,9 +404,9 @@ Module Universe. components of the pair are the head and the tail of the (non empty) list *) Definition exprs : t -> LevelExpr.t * list LevelExpr.t := to_nonempty_list. - Global Instance Evaluable : Evaluable Universe.t + Global Instance Evaluable : Evaluable t := fun v u => - let '(e, u) := Universe.exprs u in + let '(e, u) := exprs u in List.fold_left (fun n e => Nat.max (val v e) n) u (val v e). (** Test if the universe is a lub of levels or contains +n's. *) @@ -648,8 +419,6 @@ Module Universe. Definition succ : t -> t := map LevelExpr.succ. - Definition add (k : nat) : t -> t := map (LevelExpr.add k). - Definition from_kernel_repr (e : Level.t * nat) (es : list (Level.t * nat)) : t := add_list es (Universe.make e). @@ -671,7 +440,7 @@ Module Universe. Definition lt : t -> t -> Prop := LevelExprSet.lt. Definition lt_compat : Proper (eq ==> eq ==> iff) lt. - Proof. repeat intro; subst; reflexivity. Qed. + Proof. unfold eq, lt. repeat intro; subst; try reflexivity. now rewrite H H0. Qed. #[global] Instance lt_strorder : StrictOrder lt. Proof. cbv [lt]; constructor. @@ -679,22 +448,27 @@ Module Universe. { intros ??? H1 H2; etransitivity; tea. } Qed. +End Universe. +#[export] Existing Instance Universe.reflect_eq. -End Universe. +Coercion Universe.t_set : Universe.t >-> LevelExprSet.t. Ltac u := change LevelSet.elt with Level.t in *; + change (prod Level.t nat) with LevelExpr.t in *; change LevelExprSet.elt with LevelExpr.t in *. - (* change ConstraintSet.elt with UnivConstraint.t in *. *) + (* change UnivConstraintSet.elt with UnivConstraint.t in *. *) +Section UniverseValuation. +Import Universe. Lemma val_fold_right (u : Universe.t) v : - val v u = fold_right (fun e x => Nat.max (val v e) x) (val v (Universe.exprs u).1) - (List.rev (Universe.exprs u).2). + val v u = fold_right (fun e x => Nat.max (val v e) x) (val v (exprs u).1) + (List.rev (exprs u).2). Proof. unfold val at 1, Universe.Evaluable. - destruct (Universe.exprs u). + destruct (exprs u). now rewrite fold_left_rev_right. Qed. @@ -702,8 +476,8 @@ Lemma val_In_le (u : Universe.t) v e : LevelExprSet.In e u -> val v e <= val v u. Proof. intro H. rewrite val_fold_right. - apply In_to_nonempty_list_rev in H. - fold Universe.exprs in H; destruct (Universe.exprs u); cbn in *. + apply Universe.In_to_nonempty_list_rev in H. u. + fold exprs in H; destruct (exprs u); cbn in *. destruct H as [H|H]. - subst. induction (List.rev l); cbnr. lia. - induction (List.rev l); cbn; invs H. @@ -715,9 +489,9 @@ Lemma val_In_max (u : Universe.t) v : exists e, LevelExprSet.In e u /\ val v e = val v u. Proof. eapply iff_ex. { - intro. eapply and_iff_compat_r. apply In_to_nonempty_list_rev. } - rewrite val_fold_right. fold Universe.exprs; destruct (Universe.exprs u) as [e l]; cbn in *. - clear. induction (List.rev l); cbn. + intro. eapply and_iff_compat_r. apply Universe.In_to_nonempty_list_rev. } + rewrite val_fold_right. fold exprs; destruct (exprs u) as [e l]; cbn in *. + clear. u; induction (List.rev l); cbn. - exists e. split; cbnr. left; reflexivity. - destruct IHl0 as [e' [H1 H2]]. destruct (Nat.max_dec (val v a) (fold_right (fun e0 x0 => Nat.max (val v e0) x0) @@ -734,10 +508,10 @@ Proof. split. - eapply imp_iff_compat_r. { eapply iff_forall; intro. eapply imp_iff_compat_r. - apply In_to_nonempty_list_rev. } + apply Universe.In_to_nonempty_list_rev. } rewrite val_fold_right. - fold Universe.exprs; destruct (Universe.exprs u) as [e l]; cbn; clear. - induction (List.rev l); cbn. + fold exprs; destruct (exprs u) as [e l]; cbn; clear. + u; induction (List.rev l); cbn. + intros H. apply H. left; reflexivity. + intros H. destruct (Nat.max_dec (val v a) (fold_right (fun e0 x => Nat.max (val v e0) x) @@ -754,10 +528,10 @@ Lemma val_le_caract (u : Universe.t) v k : Proof. split. - eapply imp_iff_compat_r. { - eapply iff_ex; intro. eapply and_iff_compat_r. apply In_to_nonempty_list_rev. } + eapply iff_ex; intro. eapply and_iff_compat_r. apply Universe.In_to_nonempty_list_rev. } rewrite val_fold_right. - fold Universe.exprs; destruct (Universe.exprs u) as [e l]; cbn; clear. - induction (List.rev l); cbn. + fold exprs; destruct (exprs u) as [e l]; cbn; clear. + u; induction (List.rev l); cbn. + intros H. destruct H as [e' [[H1|H1] H2]]. * now subst. * invs H1. @@ -789,7 +563,7 @@ Proof. Qed. Lemma val_add v e (s: Universe.t) - : val v (add e s) = Nat.max (val v e) (val v s). + : val v (Universe.add e s) = Nat.max (val v e) (val v s). Proof. apply val_caract. split. - intros e' H. apply LevelExprSet.add_spec in H. destruct H as [H|H]. @@ -815,6 +589,8 @@ Proof. exists e'. split; tas. apply LevelExprSet.union_spec. now right. Qed. +End UniverseValuation. + Ltac proper := let H := fresh in try (intros ? ? H; destruct H; reflexivity). Lemma for_all_elements (P : LevelExpr.t -> bool) u : @@ -832,32 +608,26 @@ Proof. destruct (LevelExprSet.elements u) as [|l0 L] eqn:Hu1; [discriminate |]. destruct l0, L; try discriminate. * destruct n; inversion H; subst. - apply eq_univ''; apply Hu1. + apply Universe.equal_elements; apply Hu1. * destruct n; discriminate. Qed. - Lemma sup0_comm x1 x2 : Universe.sup x1 x2 = Universe.sup x2 x1. Proof. - apply eq_univ'; simpl. unfold LevelExprSet.Equal. - intros H. rewrite !LevelExprSet.union_spec. intuition. + apply Universe.equal_exprsets; simpl. unfold LevelExprSet.Equal. + intros H. rewrite !LevelExprSet.union_spec. firstorder. Qed. -(* +Lemma val_singleton v le : val v (Universe.singleton le) = val v le. +Proof. reflexivity. Qed. + Lemma val_zero_exprs v (l : Universe.t) : 0 <= val v l. Proof. - rewrite val_fold_right. - destruct (Universe.exprs l) as [e u']; clear l; cbn. - induction (List.rev u'); simpl. - - destruct e as [npl_expr]. - destruct npl_expr as [t b]. - cbn. - assert (0 <= val v t) by apply Level.val_zero. - destruct b;lia. - - pose proof (LevelExpr.val_zero a v); lia. -Qed. *) - + revert l. apply: Universe.elim. + - intros le. rewrite val_singleton. lia. + - intros le x. rewrite val_add. lia. +Qed. Module ConstraintType. Inductive t_ : Set := Le | Eq. @@ -941,10 +711,9 @@ Module UnivConstraint. (compare_cont (ConstraintType.compare t t') (LevelExprSet.compare l2 l2')). - Lemma universe_eq (x y : Universe.t) : t_set x = t_set y -> x = y. + Lemma universe_eq (x y : Universe.t) : Universe.t_set x = Universe.t_set y -> x = y. Proof. - destruct x, y; cbn. intros ->. - now eapply NonEmptySetFacts.eq_univ; cbn. + apply Universe.eq_univ. Qed. Lemma compare_spec x y @@ -971,124 +740,51 @@ Module UnivConstraintSet := MSetAVL.Make UnivConstraint. Module UnivConstraintSetFact := WFactsOn UnivConstraint UnivConstraintSet. Module UnivConstraintSetOrdProp := MSetProperties.OrdProperties UnivConstraintSet. Module UnivConstraintSetProp := UnivConstraintSetOrdProp.P. -(* Module CS := UnivConstraintSet. *) +Module UCS := UnivConstraintSet. Module UnivConstraintSetDecide := UnivConstraintSetProp.Dec. Module UnivConstraintSetExtraOrdProp := MSets.ExtraOrdProperties UnivConstraintSet UnivConstraintSetOrdProp. Module UnivConstraintSetExtraDecide := MSetAVL.Decide UnivConstraint UnivConstraintSet. (* Ltac csets := UnivConstraintSetDecide.fsetdec. *) Ltac ucsets := UnivConstraintSetDecide.fsetdec. -Module LevelConstraint. - Definition t : Set := Level.t * ConstraintType.t * Level.t. - - Definition eq : t -> t -> Prop := eq. - Definition eq_equiv : Equivalence eq := _. - - Definition make l1 ct l2 : t := (l1, ct, l2). - - Inductive lt_ : t -> t -> Prop := - | lt_Level2 l1 t l2 l2' : Level.lt l2 l2' -> lt_ (l1, t, l2) (l1, t, l2') - | lt_Cstr l1 t t' l2 l2' : ConstraintType.lt t t' -> lt_ (l1, t, l2) (l1, t', l2') - | lt_Level1 l1 l1' t t' l2 l2' : Level.lt l1 l1' -> lt_ (l1, t, l2) (l1', t', l2'). - Derive Signature for lt_. - Definition lt := lt_. - - Lemma lt_strorder : StrictOrder lt. - Proof. - constructor. - - intros []; intro X; inversion X; subst; - try (eapply Level.lt_strorder; eassumption). - eapply ConstraintType.lt_strorder; eassumption. - - intros ? ? ? X Y; invs X; invs Y; constructor; tea. - etransitivity; eassumption. - 2: etransitivity; eassumption. - eapply ConstraintType.lt_strorder; eassumption. - Qed. - - Lemma lt_compat : Proper (eq ==> eq ==> iff) lt. - Proof. - intros ? ? X ? ? Y; invs X; invs Y. reflexivity. - Qed. - - Definition compare : t -> t -> comparison := - fun '(l1, t, l2) '(l1', t', l2') => - compare_cont (Level.compare l1 l1') - (compare_cont (ConstraintType.compare t t') - (Level.compare l2 l2')). - - Lemma compare_spec x y - : CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). - Proof. - destruct x as [[l1 t] l2], y as [[l1' t'] l2']; cbn. - destruct (Level.compare_spec l1 l1'); cbn; repeat constructor; tas. - invs H. - destruct (ConstraintType.compare_spec t t'); cbn; repeat constructor; tas. - invs H. - destruct (Level.compare_spec l2 l2'); cbn; repeat constructor; tas. - invs H. reflexivity. - Qed. - - Lemma eq_dec x y : {eq x y} + {~ eq x y}. - Proof. - unfold eq. decide equality; apply eq_dec. - Defined. - - Definition eq_leibniz (x y : t) : eq x y -> x = y := id. -End LevelConstraint. - -Module ConstraintSet := MSetAVL.Make LevelConstraint. -Module ConstraintSetFact := WFactsOn LevelConstraint ConstraintSet. -Module ConstraintSetProp := WPropertiesOn LevelConstraint ConstraintSet. -Module CS := ConstraintSet. -Module ConstraintSetDecide := WDecide (ConstraintSet). -Ltac csets := ConstraintSetDecide.fsetdec. - -Notation "(=_cset)" := ConstraintSet.Equal (at level 0). -Infix "=_cset" := ConstraintSet.Equal (at level 30). -Notation "(==_cset)" := ConstraintSet.equal (at level 0). -Infix "==_cset" := ConstraintSet.equal (at level 30). - -Definition declared_cstr_levels levels (cstr : LevelConstraint.t) := - let '(l1,_,l2) := cstr in - LevelSet.In l1 levels /\ LevelSet.In l2 levels. - -Definition is_declared_cstr_levels levels (cstr : LevelConstraint.t) : bool := - let '(l1,_,l2) := cstr in - LevelSet.mem l1 levels && LevelSet.mem l2 levels. +Notation "(=_ucset)" := UnivConstraintSet.Equal (at level 0). +Infix "=_ucset" := UnivConstraintSet.Equal (at level 30). +Notation "(==_ucset)" := UnivConstraintSet.equal (at level 0). +Infix "==_ucset" := UnivConstraintSet.equal (at level 30). Definition declared_univ_cstr_levels levels (cstr : UnivConstraint.t) := let '(l1,_,l2) := cstr in - LevelSet.Subset (LevelExprSet.levels l1) levels /\ LevelSet.Subset (LevelExprSet.levels l2) levels. + LevelSet.Subset (Universe.levels l1) levels /\ LevelSet.Subset (Universe.levels l2) levels. Definition is_declared_univ_cstr_levels levels (cstr : UnivConstraint.t) : bool := let '(l1,_,l2) := cstr in - LevelSet.subset (LevelExprSet.levels l1) levels && LevelSet.subset (LevelExprSet.levels l2) levels. + LevelSet.subset (Universe.levels l1) levels && LevelSet.subset (Universe.levels l2) levels. -Lemma CS_union_empty s : ConstraintSet.union ConstraintSet.empty s =_cset s. +Lemma CS_union_empty s : UnivConstraintSet.union UnivConstraintSet.empty s =_ucset s. Proof. - intros x; rewrite ConstraintSet.union_spec. lsets. + intros x; rewrite UnivConstraintSet.union_spec. lsets. Qed. -Lemma CS_For_all_union f cst cst' : ConstraintSet.For_all f (ConstraintSet.union cst cst') -> - ConstraintSet.For_all f cst. +Lemma CS_For_all_union f cst cst' : UnivConstraintSet.For_all f (UnivConstraintSet.union cst cst') -> + UnivConstraintSet.For_all f cst. Proof. - unfold CS.For_all. + unfold UCS.For_all. intros IH x inx. apply (IH x). - now eapply CS.union_spec; left. + now eapply UCS.union_spec; left. Qed. -Lemma CS_For_all_add P x s : CS.For_all P (CS.add x s) -> P x /\ CS.For_all P s. +Lemma CS_For_all_add P x s : UCS.For_all P (UCS.add x s) -> P x /\ UCS.For_all P s. Proof. intros. split. - * apply (H x), CS.add_spec; left => //. - * intros y iny. apply (H y), CS.add_spec; right => //. + * apply (H x), UCS.add_spec; left => //. + * intros y iny. apply (H y), UCS.add_spec; right => //. Qed. -#[global] Instance CS_For_all_proper P : Morphisms.Proper ((=_cset) ==> iff)%signature (ConstraintSet.For_all P). +#[global] Instance CS_For_all_proper P : Morphisms.Proper ((=_ucset) ==> iff)%signature (UnivConstraintSet.For_all P). Proof. intros s s' eqs. - unfold CS.For_all. split; intros IH x inxs; apply (IH x); + unfold UCS.For_all. split; intros IH x inxs; apply (IH x); now apply eqs. Qed. @@ -1115,23 +811,23 @@ Module Instance. End Instance. Module UContext. - Definition t := list name × (Instance.t × ConstraintSet.t). + Definition t := list name × (Instance.t × UnivConstraintSet.t). - Definition make' : Instance.t -> ConstraintSet.t -> Instance.t × ConstraintSet.t := pair. - Definition make (ids : list name) (inst_ctrs : Instance.t × ConstraintSet.t) : t := (ids, inst_ctrs). + Definition make' : Instance.t -> UnivConstraintSet.t -> Instance.t × UnivConstraintSet.t := pair. + Definition make (ids : list name) (inst_ctrs : Instance.t × UnivConstraintSet.t) : t := (ids, inst_ctrs). - Definition empty : t := ([], (Instance.empty, ConstraintSet.empty)). + Definition empty : t := ([], (Instance.empty, UnivConstraintSet.empty)). Definition instance : t -> Instance.t := fun x => fst (snd x). - Definition constraints : t -> ConstraintSet.t := fun x => snd (snd x). + Definition constraints : t -> UnivConstraintSet.t := fun x => snd (snd x). - Definition dest : t -> list name * (Instance.t * ConstraintSet.t) := fun x => x. + Definition dest : t -> list name * (Instance.t * UnivConstraintSet.t) := fun x => x. End UContext. Module AUContext. - Definition t := list name × ConstraintSet.t. + Definition t := list name × UnivConstraintSet.t. - Definition make (ids : list name) (ctrs : ConstraintSet.t) : t := (ids, ctrs). + Definition make (ids : list name) (ctrs : UnivConstraintSet.t) : t := (ids, ctrs). Definition repr (x : t) : UContext.t := let (u, cst) := x in (u, (mapi (fun i _ => Level.lvar i) u, cst)). @@ -1144,38 +840,38 @@ Module AUContext. Definition inter (au av : AUContext.t) : AUContext.t := let prefix := (split_prefix au.1 av.1).1.1 in let lvls := fold_left_i (fun s i _ => LevelSet.add (Level.lvar i) s) prefix LevelSet.empty in - let filter := ConstraintSet.filter (is_declared_cstr_levels lvls) in - make prefix (ConstraintSet.union (filter au.2) (filter av.2)). + let filter := UnivConstraintSet.filter (is_declared_univ_cstr_levels lvls) in + make prefix (UnivConstraintSet.union (filter au.2) (filter av.2)). End AUContext. Module ContextSet. - Definition t := LevelSet.t × ConstraintSet.t. + Definition t := LevelSet.t × UnivConstraintSet.t. Definition levels : t -> LevelSet.t := fst. - Definition constraints : t -> ConstraintSet.t := snd. + Definition constraints : t -> UnivConstraintSet.t := snd. - Definition empty : t := (LevelSet.empty, ConstraintSet.empty). + Definition empty : t := (LevelSet.empty, UnivConstraintSet.empty). Definition is_empty (uctx : t) - := LevelSet.is_empty (fst uctx) && ConstraintSet.is_empty (snd uctx). + := LevelSet.is_empty (fst uctx) && UnivConstraintSet.is_empty (snd uctx). Definition Equal (x y : t) : Prop := - x.1 =_lset y.1 /\ x.2 =_cset y.2. + x.1 =_lset y.1 /\ x.2 =_ucset y.2. Definition equal (x y : t) : bool := - x.1 ==_lset y.1 && x.2 ==_cset y.2. + x.1 ==_lset y.1 && x.2 ==_ucset y.2. Definition Subset (x y : t) : Prop := LevelSet.Subset (levels x) (levels y) /\ - ConstraintSet.Subset (constraints x) (constraints y). + UnivConstraintSet.Subset (constraints x) (constraints y). Definition subset (x y : t) : bool := LevelSet.subset (levels x) (levels y) && - ConstraintSet.subset (constraints x) (constraints y). + UnivConstraintSet.subset (constraints x) (constraints y). Definition inter (x y : t) : t := (LevelSet.inter (levels x) (levels y), - ConstraintSet.inter (constraints x) (constraints y)). + UnivConstraintSet.inter (constraints x) (constraints y)). Definition inter_spec (x y : t) : Subset (inter x y) x /\ @@ -1183,13 +879,13 @@ Module ContextSet. forall z, Subset z x -> Subset z y -> Subset z (inter x y). Proof. split; last split. - 1,2: split=> ?; [move=> /LevelSet.inter_spec [//]|move=> /ConstraintSet.inter_spec [//]]. + 1,2: split=> ?; [move=> /LevelSet.inter_spec [//]|move=> /UnivConstraintSet.inter_spec [//]]. move=> ? [??] [??]; split=> ??; - [apply/LevelSet.inter_spec|apply/ConstraintSet.inter_spec]; split; auto. + [apply/LevelSet.inter_spec|apply/UnivConstraintSet.inter_spec]; split; auto. Qed. Definition union (x y : t) : t := - (LevelSet.union (levels x) (levels y), ConstraintSet.union (constraints x) (constraints y)). + (LevelSet.union (levels x) (levels y), UnivConstraintSet.union (constraints x) (constraints y)). Definition union_spec (x y : t) : Subset x (union x y) /\ @@ -1197,20 +893,20 @@ Module ContextSet. forall z, Subset x z -> Subset y z -> Subset (union x y) z. Proof. split; last split. - 1,2: split=> ??; [apply/LevelSet.union_spec|apply/ConstraintSet.union_spec ]; by constructor. + 1,2: split=> ??; [apply/LevelSet.union_spec|apply/UnivConstraintSet.union_spec ]; by constructor. move=> ? [??] [??]; split=> ?; - [move=>/LevelSet.union_spec|move=>/ConstraintSet.union_spec]=>-[]; auto. + [move=>/LevelSet.union_spec|move=>/UnivConstraintSet.union_spec]=>-[]; auto. Qed. Lemma equal_spec s s' : equal s s' <-> Equal s s'. Proof. - rewrite /equal/Equal/is_true Bool.andb_true_iff LevelSet.equal_spec ConstraintSet.equal_spec. + rewrite /equal/Equal/is_true Bool.andb_true_iff LevelSet.equal_spec UnivConstraintSet.equal_spec. reflexivity. Qed. Lemma subset_spec s s' : subset s s' <-> Subset s s'. Proof. - rewrite /subset/Subset/is_true Bool.andb_true_iff LevelSet.subset_spec ConstraintSet.subset_spec. + rewrite /subset/Subset/is_true Bool.andb_true_iff LevelSet.subset_spec UnivConstraintSet.subset_spec. reflexivity. Qed. @@ -1234,17 +930,17 @@ Infix "⊂?_cs" := ContextSet.subset (at level 30). Lemma incl_cs_refl cs : cs ⊂_cs cs. Proof. - split; [lsets|csets]. + split; [lsets|ucsets]. Qed. Lemma incl_cs_trans cs1 cs2 cs3 : cs1 ⊂_cs cs2 -> cs2 ⊂_cs cs3 -> cs1 ⊂_cs cs3. Proof. - intros [? ?] [? ?]; split; [lsets|csets]. + intros [? ?] [? ?]; split; [lsets|ucsets]. Qed. Lemma empty_contextset_subset u : ContextSet.empty ⊂_cs u. Proof. - red. split; cbn; [lsets|csets]. + red. split; cbn; [lsets|ucsets]. Qed. (* Variance info is needed to do full universe polymorphism *) @@ -1281,7 +977,7 @@ Definition levels_of_udecl u := Definition constraints_of_udecl u := match u with - | Monomorphic_ctx => ConstraintSet.empty + | Monomorphic_ctx => UnivConstraintSet.empty | Polymorphic_ctx ctx => snd (snd (AUContext.repr ctx)) end. @@ -1301,16 +997,16 @@ Section Univ. UnivConstraintSet.For_all (satisfies0 v). Lemma satisfies_union v φ1 φ2 : - satisfies v (CS.union φ1 φ2) + satisfies v (UCS.union φ1 φ2) <-> (satisfies v φ1 /\ satisfies v φ2). Proof. unfold satisfies. split. - - intros H; split; intros c Hc; apply H; now apply CS.union_spec. - - intros [H1 H2] c Hc; apply CS.union_spec in Hc; destruct Hc; auto. + - intros H; split; intros c Hc; apply H; now apply UCS.union_spec. + - intros [H1 H2] c Hc; apply UCS.union_spec in Hc; destruct Hc; auto. Qed. Lemma satisfies_subset φ φ' val : - ConstraintSet.Subset φ φ' -> + UnivConstraintSet.Subset φ φ' -> satisfies val φ' -> satisfies val φ. Proof using Type. @@ -1326,9 +1022,9 @@ Section Univ. LevelSet.For_all (fun l => val v l = val v' l) (ContextSet.levels cs). Lemma consistent_extension_on_empty Σ : - consistent_extension_on Σ CS.empty. + consistent_extension_on Σ UCS.empty. Proof. - move=> v hv; exists v; split; [move=> ? /CS.empty_spec[]| move=> ??//]. + move=> v hv; exists v; split; [move=> ? /UCS.empty_spec[]| move=> ??//]. Qed. Lemma fold_right_ext {A B} (f g : B -> A -> A) acc acc' l l' : @@ -1346,13 +1042,13 @@ Section Univ. Qed. Lemma subset_levels_exprs {le levels} : - LevelSet.Subset (LevelExprSet.levels le) levels -> + LevelSet.Subset (Universe.levels le) levels -> forall e, LevelExprSet.In e le -> LevelSet.In e.1 levels. Proof. intros hs e hin. destruct e as [l k]. apply (hs l). clear hs. - unfold LevelExprSet.levels. + unfold Universe.levels. revert hin. eapply LevelExprSetProp.fold_rec. - intros s' emp hin. now specialize (emp _ hin). @@ -1389,7 +1085,7 @@ Section Univ. Qed. Lemma val_max (l : Universe.t) (v : valuation) : - val v l = let nel := to_nonempty_list l in + val v l = let nel := Universe.to_nonempty_list l in max_ne_list (val v nel.1) (List.map (val v) nel.2). Proof. cbn. @@ -1408,12 +1104,12 @@ Section Univ. Lemma val_eq_levels_alg v v' levels : LevelSet.For_all (fun l : LevelSet.elt => val v l = val v' l) levels -> forall le : Universe.t, - LevelSet.Subset (LevelExprSet.levels le) levels -> + LevelSet.Subset (Universe.levels le) levels -> val v le = val v' le. Proof. move=> hl le /subset_levels_exprs sub. rewrite !val_max. - move: (to_nonempty_list_spec le). destruct to_nonempty_list as [hd tl]. cbn. + move: (Universe.to_nonempty_list_spec le). destruct Universe.to_nonempty_list as [hd tl]. cbn. intros heq. f_equal. - cbn. eapply val_eq_level_expr; tea. eapply sub. @@ -1423,10 +1119,45 @@ Section Univ. apply sub, LevelExprSetFact.elements_2. rewrite -heq. now right. Qed. + Lemma succ_inj x y : LevelExpr.succ x = LevelExpr.succ y -> x = y. + Proof using Type. + unfold LevelExpr.succ. + destruct x as [l n], y as [l' n']. simpl. congruence. + Qed. + + Lemma spec_map_succ l x : + LevelExprSet.In x (Universe.succ l) <-> + exists x', LevelExprSet.In x' l /\ x = LevelExpr.succ x'. + Proof using Type. + rewrite Universe.map_spec. reflexivity. + Qed. + + Lemma val_succ v l : val v (LevelExpr.succ l) = val v l + 1. + Proof using Type. + destruct l as []; simpl. cbn. lia. + Qed. + + Lemma val_map_succ v l : val v (Universe.succ l) = val v l + 1. + Proof using Type. + pose proof (spec_map_succ l). + set (n := Universe.succ l) in *. + destruct (val_In_max l v) as [max [inmax eqv]]. rewrite <-eqv. + rewrite val_caract. split. + intros. + specialize (proj1 (H _) H0) as [x' [inx' eq]]. subst e. + rewrite val_succ. eapply (val_In_le _ v) in inx'. rewrite <- eqv in inx'. + simpl in *. unfold LevelExprSet.elt, LevelExpr.t in *. lia. + exists (LevelExpr.succ max). split. apply H. + exists max; split; auto. + now rewrite val_succ. + Qed. + + + (* Lemma consistent_extension_on_union X cstrs - (wfX : forall c, CS.In c X.2 -> LS.Subset (LevelExprSet.levels c.1.1) X.1 /\ LS.Subset (LevelExprSet.levels c.2) X.1) : + (wfX : forall c, UCS.In c X.2 -> LS.Subset (Universe.levels c.1.1) X.1 /\ LS.Subset (Universe.levels c.2) X.1) : consistent_extension_on X cstrs -> - consistent_extension_on X (CS.union cstrs X.2). + consistent_extension_on X (UCS.union cstrs X.2). Proof. move=> hext v /[dup] vsat /hext [v' [v'sat v'eq]]. exists v'; split=> //. @@ -1440,27 +1171,28 @@ Proof. Qed. *) Lemma consistent_extension_on_union X cstrs - (wfX : forall c, CS.In c X.2 -> LS.In c.1.1 X.1 /\ LS.In c.2 X.1) : + (wfX : forall c, UCS.In c X.2 -> LS.Subset (Universe.levels c.1.1) X.1 /\ LS.Subset (Universe.levels c.2) X.1) : consistent_extension_on X cstrs -> - consistent_extension_on X (CS.union cstrs X.2). + consistent_extension_on X (UCS.union cstrs X.2). Proof. move=> hext v /[dup] vsat /hext [v' [v'sat v'eq]]. exists v'; split=> //. apply/satisfies_union; split=> //. move=> c hc. destruct (wfX c hc). - (* destruct (vsat c hc); constructor; cbn in *. + destruct (vsat c hc); constructor; cbn in *. 2:{ rewrite -(val_eq_levels_alg v v' _ v'eq l) //. rewrite -(val_eq_levels_alg v v' _ v'eq l') //. } rewrite -(val_eq_levels_alg v v' _ v'eq l) //. - rewrite -(val_eq_levels_alg v v' _ v'eq l') //. *) - destruct (vsat c hc); constructor; rewrite -!v'eq //. + rewrite -(val_eq_levels_alg v v' _ v'eq l') //. Qed. - Definition leq0_universe_n n φ (u u' : Universe.t) := - forall v, satisfies v φ -> (Z.of_nat (val v u) <= Z.of_nat (val v u') - n)%Z. + Definition leq0_universe φ (u u' : Universe.t) := + forall v, satisfies v φ -> val v u <= val v u'%Z. + + Definition leq_universe φ (u u' : Universe.t) := + if check_univs then leq0_universe φ u u' else True. - Definition leq_universe_n n φ (u u' : Universe.t) := - if check_univs then leq0_universe_n n φ u u' else True. + Definition lt_universe ϕ l r := leq0_universe ϕ (Universe.succ l) r. Definition eq0_universe φ (u u' : Universe.t) := forall v, satisfies v φ -> val v u = val v u'. @@ -1468,13 +1200,6 @@ Qed. *) Definition eq_universe {cf} φ (u u' : Universe.t) := if check_univs then eq0_universe φ u u' else True. - Definition lt_universe := leq_universe_n 1. - Definition leq_universe := leq_universe_n 0. - - Lemma leq_universe_leq_universe_n (φ : ConstraintSet.t) u u' : - leq_universe φ u u' <-> leq_universe_n 0 φ u u'. - Proof. intros. reflexivity. Qed. - (* ctrs are "enforced" by φ *) Definition valid_constraints0 φ ctrs @@ -1490,7 +1215,7 @@ Qed. *) end. Ltac unfold_univ_rel0 := - unfold eq0_universe, leq0_universe_n, valid_constraints0 in *; + unfold eq0_universe, leq0_universe, valid_constraints0 in *; try ( match goal with |- forall v : valuation, _ -> _ => idtac end; intros v Hv; @@ -1499,11 +1224,11 @@ Qed. *) ). Ltac unfold_univ_rel := - unfold eq_universe, leq_universe, lt_universe, leq_universe_n, valid_constraints in *; + unfold eq_universe, leq_universe, lt_universe, valid_constraints in *; destruct check_univs; [unfold_univ_rel0 | trivial]. Lemma valid_subset φ φ' ctrs - : ConstraintSet.Subset φ φ' -> valid_constraints φ ctrs + : UnivConstraintSet.Subset φ φ' -> valid_constraints φ ctrs -> valid_constraints φ' ctrs. Proof using Type. unfold_univ_rel. @@ -1523,7 +1248,7 @@ Qed. *) Global Instance leq_universe_refl φ : Reflexive (leq_universe φ). Proof using Type. - intros u; unfold_univ_rel. lia. + intros u; unfold_univ_rel. Qed. Global Instance eq_universe_sym φ : Symmetric (eq_universe φ). @@ -1538,31 +1263,19 @@ Qed. *) lia. Qed. - Global Instance leq_universe_n_trans n φ : Transitive (leq_universe_n (Z.of_nat n) φ). + Global Instance leq_universe_trans φ : Transitive (leq_universe φ). Proof using Type. intros u u' u'' H1 H2; unfold_univ_rel. lia. Qed. - Global Instance leq_universe_trans φ : Transitive (leq_universe φ). - Proof using Type. apply (leq_universe_n_trans 0). Qed. - - Global Instance lt_universe_trans φ : Transitive (lt_universe φ). - Proof using Type. apply (leq_universe_n_trans 1). Qed. - - Lemma eq0_leq0_universe φ u u' : - eq0_universe φ u u' <-> leq0_universe_n 0 φ u u' /\ leq0_universe_n 0 φ u' u. - Proof using Type. - split. - - intros H. split; unfold_univ_rel0; lia. - - intros [H1 H2]. unfold_univ_rel0; lia. - Qed. - Lemma eq_universe_leq_universe φ u u' : eq_universe φ u u' <-> leq_universe φ u u' /\ leq_universe φ u' u. Proof using Type. unfold_univ_rel => //. - apply eq0_leq0_universe. + split. + - intros H. split; unfold_univ_rel0; lia. + - intros [H1 H2]. unfold_univ_rel0; lia. Qed. Lemma leq_universe_sup_l φ u1 u2 : leq_universe φ u1 (Universe.sup u1 u2). @@ -1591,13 +1304,25 @@ Qed. *) Proof using Type. intro u. unfold complement. unfold_univ_rel => //. - destruct H as [v Hv]; intros nH; specialize (nH v Hv); lia. + destruct H as [v Hv]; intros nH. specialize (nH v Hv). + rewrite val_map_succ in nH. lia. + Qed. + + Global Instance lt_universe_trans {c: check_univs} φ : Transitive (lt_universe φ). + Proof using Type. + intros x y z. + unfold_univ_rel => //. + move => v1 v2 v Hv. + specialize (v1 v Hv). + specialize (v2 v Hv). + rewrite !val_map_succ in v1, v2 |- *. lia. Qed. Global Instance lt_universe_str_order {c: check_univs} φ (H: consistent φ) : StrictOrder (lt_universe φ). Proof. refine (Build_StrictOrder _ _ _). now unshelve eapply lt_universe_irrefl. + now unshelve eapply lt_universe_trans. Qed. Global Instance leq_universe_antisym φ : Antisymmetric _ (eq_universe φ) (leq_universe φ). @@ -1639,7 +1364,7 @@ Qed. *) Lemma cmp_universe_subset φ φ' pb t u : - ConstraintSet.Subset φ φ' -> compare_universe φ pb t u -> compare_universe φ' pb t u. + UnivConstraintSet.Subset φ φ' -> compare_universe φ pb t u -> compare_universe φ' pb t u. Proof using Type. intros Hctrs. destruct pb, t, u; cbnr; trivial. @@ -1649,12 +1374,12 @@ Qed. *) Qed. Lemma eq_universe_subset φ φ' t u - : ConstraintSet.Subset φ φ' + : UnivConstraintSet.Subset φ φ' -> eq_universe φ t u -> eq_universe φ' t u. Proof using Type. apply cmp_universe_subset with (pb := Conv). Qed. Lemma leq_universe_subset φ φ' t u - : ConstraintSet.Subset φ φ' + : UnivConstraintSet.Subset φ φ' -> leq_universe φ t u -> leq_universe φ' t u. Proof using Type. apply cmp_universe_subset with (pb := Cumul). Qed. @@ -1662,7 +1387,7 @@ Qed. *) End Univ. Ltac unfold_univ_rel0 := - unfold eq0_universe, leq0_universe_n, valid_constraints0 in *; + unfold eq0_universe, leq0_universe, valid_constraints0 in *; try ( match goal with |- forall v : valuation, _ -> _ => idtac end; intros v Hv; @@ -1671,7 +1396,7 @@ Ltac unfold_univ_rel0 := ). Ltac unfold_univ_rel := - unfold eq_universe, leq_universe, lt_universe, leq_universe_n, valid_constraints in *; + unfold eq_universe, leq_universe, lt_universe, valid_constraints in *; destruct check_univs; [unfold_univ_rel0 | trivial]. @@ -2055,24 +1780,22 @@ Qed. Section SortCompare. Context {cf}. - Definition leq_sort_n_ {univ} (leq_universe_n : Z -> univ -> univ -> Prop) n s s' : Prop := + Definition leq_sort_ {univ} (leq_universe : univ -> univ -> Prop) s s' : Prop := match s, s' with | sProp, sProp - | sSProp, sSProp => (n = 0)%Z - | sType u, sType u' => leq_universe_n n u u' + | sSProp, sSProp => True + | sType u, sType u' => leq_universe u u' | sProp, sType u => prop_sub_type | _, _ => False end. - Definition leq_sort_n n φ := leq_sort_n_ (fun n => leq_universe_n n φ) n. - Definition lt_sort := leq_sort_n 1. - Definition leq_sort := leq_sort_n 0. + Definition leq_sort φ := leq_sort_ (leq_universe φ). - Definition leqb_sort_n_ {univ} (leqb_universe_n : bool -> univ -> univ -> bool) b s s' : bool := + Definition leqb_sort_ {univ} (leqb_universe : bool -> univ -> univ -> bool) b s s' : bool := match s, s' with | sProp, sProp | sSProp, sSProp => negb b - | sType u, sType u' => leqb_universe_n b u u' + | sType u, sType u' => leqb_universe b u u' | sProp, sType u => prop_sub_type | _, _ => false end. @@ -2101,26 +1824,17 @@ Section SortCompare. | Cumul => leq_sort φ end. - Lemma leq_sort_leq_sort_n (φ : ConstraintSet.t) s s' : - leq_sort φ s s' <-> leq_sort_n 0 φ s s'. - Proof using Type. intros. reflexivity. Qed. - Lemma compare_sort_type φ pb u u' : compare_sort φ pb (sType u) (sType u') = compare_universe φ pb u u'. Proof. now destruct pb. Qed. Section GeneralLemmas. - Context {univ} {leq_universe_n : Z -> univ -> univ -> Prop} {eq_universe : univ -> univ -> Prop}. + Context {univ} {leq_universe : univ -> univ -> Prop} {eq_universe : univ -> univ -> Prop}. - Let leq_sort_n := leq_sort_n_ leq_universe_n. - Let lt_sort := leq_sort_n_ leq_universe_n 1. - Let leq_sort := leq_sort_n_ leq_universe_n 0. + Let leq_sort := leq_sort_ leq_universe. Let eq_sort := eq_sort_ eq_universe. - Notation "x <_ n y" := (leq_sort_n n x y) (at level 10, n name). - Notation "x < y" := (lt_sort x y). Notation "x <= y" := (leq_sort x y). - Lemma sort_le_prop_inv s : s <= sProp -> s = sProp. Proof using Type. destruct s => //. Qed. @@ -2138,7 +1852,7 @@ Section SortCompare. Lemma sort_sprop_le_inv s : sSProp <= s -> s = sSProp. Proof using Type. destruct s => //. Qed. - Global Instance leq_sort_refl `{Reflexive univ (leq_universe_n 0)} : Reflexive leq_sort. + Global Instance leq_sort_refl `{Reflexive univ (leq_universe)} : Reflexive leq_sort. Proof using Type. intros []; cbnr. Qed. Global Instance eq_sort_refl `{Reflexive univ eq_universe} : Reflexive eq_sort. @@ -2147,51 +1861,45 @@ Section SortCompare. Global Instance eq_sort_sym `{Symmetric univ eq_universe} : Symmetric eq_sort. Proof using Type. intros [] [] => //=. apply H. Qed. - Global Instance leq_sort_n_trans n `{Transitive univ (leq_universe_n n)} : Transitive (leq_sort_n n). + Global Instance leq_sort_trans `{Transitive univ leq_universe} : Transitive leq_sort. Proof using Type. intros [] [] [] => //=. apply H. Qed. - Global Instance leq_sort_trans `{Transitive univ (leq_universe_n 0)} : Transitive leq_sort. - Proof using Type. apply (leq_sort_n_trans 0). Qed. - - Global Instance lt_sort_trans `{Transitive univ (leq_universe_n 1)} : Transitive lt_sort. - Proof using Type. apply (leq_sort_n_trans 1). Qed. - Global Instance eq_sort_trans `{Transitive univ eq_universe} : Transitive eq_sort. Proof using Type. intros [] [] [] => //=. apply H. Qed. - Global Instance leq_sort_preorder `{PreOrder univ (leq_universe_n 0)} : PreOrder leq_sort := + Global Instance leq_sort_preorder `{PreOrder univ (leq_universe)} : PreOrder leq_sort := Build_PreOrder _ _ _. (* Can't be a global instance since it can lead to infinite search *) - Lemma lt_sort_irrefl : Irreflexive (leq_universe_n 1) -> Irreflexive lt_sort. + (* Lemma lt_sort_irrefl : Irreflexive leq_universe -> Irreflexive lt_sort. Proof using Type. intros H []; unfold complement; cbnr. 1,2: lia. apply H. - Qed. + Qed. *) - Global Instance lt_sort_str_order `{StrictOrder univ (leq_universe_n 1)} : StrictOrder lt_sort := - Build_StrictOrder _ (lt_sort_irrefl _) _. + (* Global Instance lt_sort_str_order `{StrictOrder univ leq_universe} : StrictOrder lt_sort := + Build_StrictOrder _ (lt_sort_irrefl _) _. *) - Global Instance eq_leq_sort `{subrelation univ eq_universe (leq_universe_n 0)}: subrelation eq_sort leq_sort. + Global Instance eq_leq_sort `{subrelation univ eq_universe (leq_universe)}: subrelation eq_sort leq_sort. Proof using Type. intros [] [] => //=. apply H. Qed. Global Instance eq_sort_equivalence `{Equivalence univ eq_universe} : Equivalence eq_sort := Build_Equivalence _ _ _ _. - Global Instance leq_sort_antisym `{Antisymmetric _ eq_universe (leq_universe_n 0)} : Antisymmetric _ eq_sort leq_sort. + Global Instance leq_sort_antisym `{Antisymmetric _ eq_universe (leq_universe)} : Antisymmetric _ eq_sort leq_sort. Proof using Type. intros [] [] => //=. apply H. Qed. - Global Instance leq_sort_partial_order `{PartialOrder _ eq_universe (leq_universe_n 0)}: PartialOrder eq_sort leq_sort. + Global Instance leq_sort_partial_order `{PartialOrder _ eq_universe (leq_universe)}: PartialOrder eq_sort leq_sort. Proof. - assert (subrelation eq_universe (leq_universe_n 0)). + assert (subrelation eq_universe (leq_universe)). { intros u u' Hu. specialize (H u u'); cbn in H. apply H in Hu. apply Hu. } - assert (subrelation eq_universe (flip (leq_universe_n 0))). + assert (subrelation eq_universe (flip (leq_universe))). { intros u u' Hu. specialize (H u u'); cbn in H. apply H in Hu. apply Hu. } intros s s'. split. - intro Heq. split. @@ -2207,14 +1915,9 @@ Section SortCompare. Definition concrete_sort := Sort.t_ nat. (** u + n <= u' *) - Definition leq_csort_n : Z -> concrete_sort -> concrete_sort -> Prop := - leq_sort_n_ (fun n u u' => (Z.of_nat u <= Z.of_nat u' - n)%Z). - - Definition leq_csort := leq_csort_n 0. - Definition lt_csort := leq_csort_n 1. + Definition leq_csort : concrete_sort -> concrete_sort -> Prop := + leq_sort_ (fun u u' => (u <= u')%nat). - Notation "x <_ n y" := (leq_csort_n n x y) (at level 10, n name) : univ_scope. - Notation "x < y" := (lt_csort x y) : univ_scope. Notation "x <= y" := (leq_csort x y) : univ_scope. Definition is_propositional_or_set s := match s with sSProp | sProp | sType 0 => true | _ => false end. @@ -2278,7 +1981,7 @@ Section SortCompare. impredicativity. *) - Global Instance lt_sort_irrefl' {c: check_univs} φ (H: consistent φ) : Irreflexive (lt_sort φ). + (* Global Instance lt_sort_irrefl' {c: check_univs} φ (H: consistent φ) : Irreflexive (lt_sort φ). Proof. unshelve eapply lt_sort_irrefl. now unshelve eapply lt_universe_irrefl. @@ -2288,7 +1991,7 @@ Section SortCompare. Proof using Type. unshelve eapply lt_sort_str_order. now unshelve eapply lt_universe_str_order. - Qed. + Qed. *) Global Instance compare_sort_subrel φ pb : subrelation (eq_sort φ) (compare_sort φ pb). Proof using Type. @@ -2319,7 +2022,7 @@ Section SortCompare. Lemma cmp_sort_subset φ φ' pb t u - : ConstraintSet.Subset φ φ' + : UnivConstraintSet.Subset φ φ' -> compare_sort φ pb t u -> compare_sort φ' pb t u. Proof using Type. intros Hctrs. @@ -2330,12 +2033,12 @@ Section SortCompare. Qed. Lemma eq_sort_subset ctrs ctrs' t u - : ConstraintSet.Subset ctrs ctrs' + : UnivConstraintSet.Subset ctrs ctrs' -> eq_sort ctrs t u -> eq_sort ctrs' t u. Proof using Type. apply cmp_sort_subset with (pb := Conv). Qed. Lemma leq_sort_subset ctrs ctrs' t u - : ConstraintSet.Subset ctrs ctrs' + : UnivConstraintSet.Subset ctrs ctrs' -> leq_sort ctrs t u -> leq_sort ctrs' t u. Proof using Type. apply cmp_sort_subset with (pb := Cumul). Qed. End SortCompare. @@ -2440,7 +2143,7 @@ Section UnivCF2. : config.impl cf1 cf2 -> @compare_universe cf1 ctrs pb t u -> @compare_universe cf2 ctrs pb t u. Proof using Type. - unfold config.impl, compare_universe, leq_universe, eq_universe, leq_universe_n, is_true. + unfold config.impl, compare_universe, leq_universe, eq_universe, is_true. destruct pb; do 2 destruct check_univs => //=. Qed. @@ -2458,7 +2161,7 @@ Section UnivCF2. : config.impl cf1 cf2 -> @compare_sort cf1 ctrs pb t u -> @compare_sort cf2 ctrs pb t u. Proof using Type. - unfold compare_sort, leq_sort, eq_sort, eq_sort_, leq_sort_n, leq_sort_n_, is_true. + unfold compare_sort, leq_sort, eq_sort, eq_sort_, is_true. destruct pb, t, u => //=. - apply eq_universe_config_impl. - unfold config.impl. do 2 destruct check_univs, prop_sub_type; cbn => //=. @@ -2491,14 +2194,14 @@ End UnivCF2. Ltac unfold_univ_rel ::= unfold is_allowed_elimination, is_lSet, valid_constraints, - compare_sort, eq_sort, leq_sort, lt_sort, leq_sort_n, leq_sort_n_, eq_sort_, leqb_sort_n_, eqb_sort_, - compare_universe, leq_universe, eq_universe, leq_universe_n in *; + compare_sort, eq_sort, leq_sort, eq_sort_, eqb_sort_, + compare_universe, leq_universe, eq_universe in *; destruct check_univs; [unfold_univ_rel0 | trivial]. Tactic Notation "unfold_univ_rel" "eqn" ":"ident(H) := unfold is_allowed_elimination, is_lSet, valid_constraints, - compare_sort, eq_sort, leq_sort, lt_sort, leq_sort_n, leq_sort_n_, eq_sort_, leqb_sort_n_, eqb_sort_, - compare_universe, leq_universe, eq_universe, leq_universe_n in *; + compare_sort, eq_sort, leq_sort, eq_sort_, eqb_sort_, + compare_universe, leq_universe, eq_universe in *; destruct check_univs eqn:H; [unfold_univ_rel0 | trivial]. (* Ltac prop_non_prop := @@ -2563,7 +2266,7 @@ Section UniverseLemmas. Lemma univ_sup_idem s : Universe.sup s s = s. Proof using Type. - apply eq_univ'; cbn. + apply Universe.equal_exprsets; cbn. intro; rewrite !LevelExprSet.union_spec. intuition. Qed. @@ -2584,7 +2287,7 @@ Section UniverseLemmas. Lemma univ_sup_assoc s1 s2 s3 : Universe.sup s1 (Universe.sup s2 s3) = Universe.sup (Universe.sup s1 s2) s3. Proof using Type. - apply eq_univ'; cbn. symmetry; apply LevelExprSetProp.union_assoc. + apply Universe.equal_exprsets; cbn. symmetry; apply LevelExprSetProp.union_assoc. Qed. Instance proper_univ_sup_eq_univ φ : @@ -2614,40 +2317,7 @@ End UniverseLemmas. Section no_prop_leq_type. Context {cf: checker_flags}. - Context (ϕ : ConstraintSet.t). - - Lemma succ_inj x y : LevelExpr.succ x = LevelExpr.succ y -> x = y. - Proof using Type. - unfold LevelExpr.succ. - destruct x as [l n], y as [l' n']. simpl. congruence. - Qed. - - Lemma spec_map_succ l x : - LevelExprSet.In x (Universe.succ l) <-> - exists x', LevelExprSet.In x' l /\ x = LevelExpr.succ x'. - Proof using Type. - rewrite map_spec. reflexivity. - Qed. - - Lemma val_succ v l : val v (LevelExpr.succ l) = val v l + 1. - Proof using Type. - destruct l as []; simpl. cbn. lia. - Qed. - - Lemma val_map_succ v l : val v (Universe.succ l) = val v l + 1. - Proof using Type. - pose proof (spec_map_succ l). - set (n := Universe.succ l) in *. - destruct (val_In_max l v) as [max [inmax eqv]]. rewrite <-eqv. - rewrite val_caract. split. - intros. - specialize (proj1 (H _) H0) as [x' [inx' eq]]. subst e. - rewrite val_succ. eapply (val_In_le _ v) in inx'. rewrite <- eqv in inx'. - simpl in *. unfold LevelExprSet.elt, LevelExpr.t in *. lia. - exists (LevelExpr.succ max). split. apply H. - exists max; split; auto. - now rewrite val_succ. - Qed. + Context (ϕ : UnivConstraintSet.t). Lemma leq_sort_super s s' : leq_sort ϕ s s' -> @@ -2721,17 +2391,14 @@ fun u e => match e with end. #[global] Instance subst_instance_universe : UnivSubst Universe.t := - fun u => map (subst_instance_level_expr u). - -#[global] Instance subst_instance_cstr : UnivSubst LevelConstraint.t := - fun u c => (subst_instance_level u c.1.1, c.1.2, subst_instance_level u c.2). + fun u => Universe.map (subst_instance_level_expr u). #[global] Instance subst_instance_univ_cstr : UnivSubst UnivConstraint.t := fun u c => (subst_instance u c.1.1, c.1.2, subst_instance u c.2). -#[global] Instance subst_instance_cstrs : UnivSubst ConstraintSet.t := - fun u ctrs => ConstraintSet.fold (fun c => ConstraintSet.add (subst_instance_cstr u c)) - ctrs ConstraintSet.empty. +#[global] Instance subst_instance_cstrs : UnivSubst UnivConstraintSet.t := + fun u ctrs => UnivConstraintSet.fold (fun c => UnivConstraintSet.add (subst_instance_univ_cstr u c)) + ctrs UnivConstraintSet.empty. #[global] Instance subst_instance_sort : UnivSubst Sort.t := fun u e => match e with @@ -2813,16 +2480,17 @@ Section UniverseClosedSubst. Proof. intro H. destruct s as [| | t]; cbnr. - apply f_equal. apply eq_univ'. + apply f_equal. apply Universe.equal_exprsets. destruct t as [ts H1]. - unfold closedu_universe in *;cbn in *. + unfold closedu_sort, closedu_universe in *;cbn in *. intro e; split; intro He. - - apply map_spec in He. destruct He as [e' [He' X]]. - rewrite closedu_subst_instance_level_expr in X. + - apply Universe.map_levelexprset_spec in He as [e' [He' X]]. + subst e. + rewrite closedu_subst_instance_level_expr. apply LevelExprSet.for_all_spec in H; proper. exact (H _ He'). now subst. - - apply map_spec. exists e; split; tas. + - apply Universe.map_levelexprset_spec. exists e; split; tas. symmetry; apply closedu_subst_instance_level_expr. apply LevelExprSet.for_all_spec in H; proper. now apply H. Qed. @@ -2874,7 +2542,7 @@ Section SubstInstanceClosed. destruct s as [| |t]; cbnr. destruct t as [l Hl]. apply LevelExprSet.for_all_spec; proper. - intros e He. eapply map_spec in He. + intros e He. eapply Universe.map_levelexprset_spec in He. destruct He as [e' [He' X]]; subst. apply subst_instance_level_expr_closedu. apply LevelExprSet.for_all_spec in H; proper. @@ -2952,11 +2620,7 @@ Definition print_lset t := Definition print_constraint_type d := match d with - | ConstraintType.Le n => - if (n =? 0)%Z then "<=" else - if (n =? 1)%Z then "<" else - if (n "<=" | ConstraintType.Eq => "=" end. @@ -2964,10 +2628,6 @@ Definition print_level_constraint '(l1, d, l2) := string_of_level l1 ^ " " ^ print_constraint_type d ^ " " ^ string_of_level l2. -Definition print_level_constraint_set t := - print_list print_level_constraint - " /\ " (ConstraintSet.elements t). - Definition print_univ_constraint '(l1, d, l2) := string_of_universe (l1 : Universe.t) ^ " " ^ print_constraint_type d ^ " " ^ string_of_universe (l2 : Universe.t). diff --git a/common/theories/UniversesDec.v b/common/theories/UniversesDec.v index f17bc7315..1f858852e 100644 --- a/common/theories/UniversesDec.v +++ b/common/theories/UniversesDec.v @@ -4,13 +4,13 @@ From MetaRocq.Common Require Import uGraph. From MetaRocq.Common Require Import Universes. Import wGraph. -Definition levels_of_cs (cstr : ConstraintSet.t) : LevelSet.t - := ConstraintSet.fold (fun '(l1, _, l2) acc => LevelSet.add l1 (LevelSet.add l2 acc)) cstr (LevelSet.singleton Level.lzero). +Definition levels_of_cs (cstr : UnivConstraintSet.t) : LevelSet.t + := UnivConstraintSet.fold (fun '(l1, _, l2) acc => LevelSet.add l1 (LevelSet.add l2 acc)) cstr (LevelSet.singleton Level.lzero). Lemma levels_of_cs_spec cstr (lvls := levels_of_cs cstr) : uGraph.global_uctx_invariants (lvls, cstr). Proof. subst lvls; cbv [levels_of_cs]. - cbv [uGraph.global_uctx_invariants uGraph.uctx_invariants ConstraintSet.For_all declared_cstr_levels]; cbn [fst snd ContextSet.levels ContextSet.constraints]. + cbv [uGraph.global_uctx_invariants uGraph.uctx_invariants UnivConstraintSet.For_all declared_univ_cstr_levels]; cbn [fst snd ContextSet.levels ContextSet.constraints]. repeat first [ apply conj | progress intros | progress destruct ? @@ -20,14 +20,14 @@ Proof. left | lazymatch y with context[LevelSet.In ?l (LevelSet.singleton ?l)] => idtac end; right ] - | [ H : ConstraintSet.In ?l ?c |- ?x \/ ?y ] - => first [ lazymatch x with context[LevelSet.In _ (ConstraintSet.fold _ c _)] => idtac end; + | [ H : UnivConstraintSet.In ?l ?c |- ?x \/ ?y ] + => first [ lazymatch x with context[LevelSet.In _ (UnivConstraintSet.fold _ c _)] => idtac end; left - | lazymatch y with context[LevelSet.In _ (ConstraintSet.fold _ c _)] => idtac end; + | lazymatch y with context[LevelSet.In _ (UnivConstraintSet.fold _ c _)] => idtac end; right ] end | rewrite !LevelSet.union_spec - | progress rewrite <- ?ConstraintSet.elements_spec1, ?InA_In_eq in * + | progress rewrite <- ?UnivConstraintSet.elements_spec1, ?InA_In_eq in * | rewrite ConstraintSetProp.fold_spec_right ]. all: lazymatch goal with | [ |- LevelSet.In Level.lzero (List.fold_right ?f ?init ?ls) ] @@ -58,7 +58,7 @@ Proof. destruct uGraph.is_consistent; [ left; apply H | right; intro H'; apply H in H' ]; auto. Defined. -Definition levels_of_cs2 (cs1 cs2 : ConstraintSet.t) : LevelSet.t +Definition levels_of_cs2 (cs1 cs2 : UnivConstraintSet.t) : LevelSet.t := LevelSet.union (levels_of_cs cs1) (levels_of_cs cs2). Lemma levels_of_cs2_spec cs1 cs2 (lvls := levels_of_cs2 cs1 cs2) : uGraph.global_uctx_invariants (lvls, cs1) @@ -67,7 +67,7 @@ Proof. split; apply global_uctx_invariants_union_or; constructor; apply levels_of_cs_spec. Qed. -Definition levels_of_cscs (cs : ContextSet.t) (cstr : ConstraintSet.t) : LevelSet.t +Definition levels_of_cscs (cs : ContextSet.t) (cstr : UnivConstraintSet.t) : LevelSet.t := LevelSet.union (ContextSet.levels cs) (levels_of_cs2 cstr (ContextSet.constraints cs)). Lemma levels_of_cscs_spec cs cstr (lvls := levels_of_cscs cs cstr) : uGraph.global_uctx_invariants (lvls, ContextSet.constraints cs) @@ -148,11 +148,11 @@ Definition ununiquify_level (total_sets : nat) (lvl : Level.t) : Level.t | Level.level x => Level.level (ununiquify_level_level x) | Level.lvar x => Level.lvar (ununiquify_level_var total_sets x) end. -Definition uniquify_constraint (shared_levels : LevelSet.t) (shared_prefix : Byte.byte) (total_sets : nat) (prefix : Byte.byte) (offset : nat) (c : ConstraintSet.elt) : ConstraintSet.elt +Definition uniquify_constraint (shared_levels : LevelSet.t) (shared_prefix : Byte.byte) (total_sets : nat) (prefix : Byte.byte) (offset : nat) (c : UnivConstraintSet.elt) : UnivConstraintSet.elt := let '((l1, c), l2) := c in let u := uniquify_level shared_levels shared_prefix total_sets prefix offset in ((u l1, c), u l2). -Definition ununiquify_constraint (total_sets : nat) (c : ConstraintSet.elt) : ConstraintSet.elt +Definition ununiquify_constraint (total_sets : nat) (c : UnivConstraintSet.elt) : UnivConstraintSet.elt := let '((l1, c), l2) := c in let u := ununiquify_level total_sets in ((u l1, c), u l2). @@ -174,7 +174,7 @@ Definition uniquify_constraint_for lvls (side:bool) c := uniquify_constraint lvls "b"%byte 2 (if side then "l" else "r")%byte (if side then 0 else 1) c. Definition uniquify_valuation_for lvls (side:bool) v := uniquify_valuation lvls "b"%byte 2 (if side then "l" else "r")%byte (if side then 0 else 1) v. -Definition declare_and_uniquify_levels : ContextSet.t * ConstraintSet.t -> ContextSet.t * ConstraintSet.t +Definition declare_and_uniquify_levels : ContextSet.t * UnivConstraintSet.t -> ContextSet.t * UnivConstraintSet.t := fun '(cs, cstr) => let '(lvls, cs) := (ContextSet.levels cs, ContextSet.constraints cs) in let '(cs_all_lvls, cstr_all_lvls) := (levels_of_cs cs, levels_of_cs cstr) in @@ -185,20 +185,20 @@ Definition declare_and_uniquify_levels : ContextSet.t * ConstraintSet.t -> Conte (fun l => LevelSet.add (uniquify_level_for lvls true l)) lvls (LevelSet.singleton Level.lzero)), - ConstraintSet.fold - (fun c => ConstraintSet.add (uniquify_constraint_for lvls true c)) + UnivConstraintSet.fold + (fun c => UnivConstraintSet.add (uniquify_constraint_for lvls true c)) cs - ConstraintSet.empty), - ConstraintSet.fold - (fun c => ConstraintSet.add (uniquify_constraint_for lvls false c)) + UnivConstraintSet.empty), + UnivConstraintSet.fold + (fun c => UnivConstraintSet.add (uniquify_constraint_for lvls false c)) cstr - ConstraintSet.empty). + UnivConstraintSet.empty). -Definition declare_and_uniquify_and_combine_levels : ContextSet.t * ConstraintSet.t -> ContextSet.t * ConstraintSet.t +Definition declare_and_uniquify_and_combine_levels : ContextSet.t * UnivConstraintSet.t -> ContextSet.t * UnivConstraintSet.t := fun '(cs, cstr) => let cscstr := declare_and_uniquify_levels (cs, cstr) in let '(cs, cstr) := (cscstr.1, cscstr.2) in - (cs, ConstraintSet.union cstr (ContextSet.constraints cs)). + (cs, UnivConstraintSet.union cstr (ContextSet.constraints cs)). Definition combine_valuations (shared_prefix prefixl prefixr : Byte.byte) (total_sets : nat := 2) (vd vl vr : valuation) : valuation := let __ := reflectEq_Z in @@ -226,16 +226,16 @@ Definition combine_valuations (shared_prefix prefixl prefixr : Byte.byte) (total |}. Lemma ConstraintSet_In_fold_add c cs1 cs2 f - : ConstraintSet.In c (ConstraintSet.fold (fun c => ConstraintSet.add (f c)) cs1 cs2) - <-> (ConstraintSet.Exists (fun c' => c = f c') cs1 \/ ConstraintSet.In c cs2). + : UnivConstraintSet.In c (UnivConstraintSet.fold (fun c => UnivConstraintSet.add (f c)) cs1 cs2) + <-> (UnivConstraintSet.Exists (fun c' => c = f c') cs1 \/ UnivConstraintSet.In c cs2). Proof. - cbv [ConstraintSet.Exists]; rewrite ConstraintSetProp.fold_spec_right. + cbv [UnivConstraintSet.Exists]; rewrite ConstraintSetProp.fold_spec_right. setoid_rewrite (ConstraintSetFact.elements_iff cs1). setoid_rewrite InA_In_eq. - setoid_rewrite (@List.in_rev _ (ConstraintSet.elements cs1)). - induction (List.rev (ConstraintSet.elements cs1)) as [|x xs IH]; cbn [List.In List.fold_right]; + setoid_rewrite (@List.in_rev _ (UnivConstraintSet.elements cs1)). + induction (List.rev (UnivConstraintSet.elements cs1)) as [|x xs IH]; cbn [List.In List.fold_right]; [ now firstorder idtac | ]. - rewrite ConstraintSet.add_spec. + rewrite UnivConstraintSet.add_spec. repeat first [ progress destruct_head'_ex | progress destruct_head'_and | progress destruct_head'_or @@ -282,26 +282,26 @@ Proof. Qed. Lemma ConstraintSet_In__declare_and_uniquify_and_combine_levels_1__0 cs cstr c - : ConstraintSet.In c (ContextSet.constraints cs) - -> ConstraintSet.In (uniquify_constraint_for (ContextSet.levels cs) true c) (ContextSet.constraints (declare_and_uniquify_and_combine_levels (cs, cstr)).1). + : UnivConstraintSet.In c (ContextSet.constraints cs) + -> UnivConstraintSet.In (uniquify_constraint_for (ContextSet.levels cs) true c) (ContextSet.constraints (declare_and_uniquify_and_combine_levels (cs, cstr)).1). Proof. cbv [declare_and_uniquify_levels declare_and_uniquify_and_combine_levels uniquify_constraint_for uniquify_constraint]. repeat first [ progress subst | progress cbn [ContextSet.constraints fst snd] - | progress cbv [ConstraintSet.Exists] + | progress cbv [UnivConstraintSet.Exists] | destruct ? | rewrite ConstraintSet_In_fold_add | solve [ eauto ] ]. Qed. Lemma ConstraintSet_In__declare_and_uniquify_and_combine_levels_1__1 cs cstr c - : ConstraintSet.In c (ContextSet.constraints (declare_and_uniquify_and_combine_levels (cs, cstr)).1) - -> ConstraintSet.In (ununiquify_constraint 2 c) (ContextSet.constraints cs). + : UnivConstraintSet.In c (ContextSet.constraints (declare_and_uniquify_and_combine_levels (cs, cstr)).1) + -> UnivConstraintSet.In (ununiquify_constraint 2 c) (ContextSet.constraints cs). Proof. cbv [declare_and_uniquify_levels declare_and_uniquify_and_combine_levels ununiquify_constraint uniquify_constraint_for uniquify_constraint]. repeat first [ progress subst | progress cbn [ContextSet.constraints fst snd] - | progress cbv [ConstraintSet.Exists] + | progress cbv [UnivConstraintSet.Exists] | destruct ? | rewrite ConstraintSet_In_fold_add | rewrite ConstraintSetFact.empty_iff @@ -318,27 +318,27 @@ Proof. Qed. Lemma ConstraintSet_In__declare_and_uniquify_and_combine_levels_2__0 cs cstr c - : ConstraintSet.In c cstr - -> ConstraintSet.In (uniquify_constraint_for (ContextSet.levels cs) false c) (declare_and_uniquify_and_combine_levels (cs, cstr)).2. + : UnivConstraintSet.In c cstr + -> UnivConstraintSet.In (uniquify_constraint_for (ContextSet.levels cs) false c) (declare_and_uniquify_and_combine_levels (cs, cstr)).2. Proof. cbv [declare_and_uniquify_levels declare_and_uniquify_and_combine_levels uniquify_constraint_for uniquify_constraint]. repeat first [ progress subst | progress cbn [ContextSet.constraints fst snd] - | progress cbv [ConstraintSet.Exists] + | progress cbv [UnivConstraintSet.Exists] | destruct ? | rewrite ConstraintSet_In_fold_add - | rewrite ConstraintSet.union_spec + | rewrite UnivConstraintSet.union_spec | solve [ eauto ] ]. Qed. Lemma ConstraintSet_In__declare_and_uniquify_levels_2__1 cs cstr c - : ConstraintSet.In c (declare_and_uniquify_levels (cs, cstr)).2 - -> ConstraintSet.In (ununiquify_constraint 2 c) cstr. + : UnivConstraintSet.In c (declare_and_uniquify_levels (cs, cstr)).2 + -> UnivConstraintSet.In (ununiquify_constraint 2 c) cstr. Proof. cbv [declare_and_uniquify_levels ununiquify_constraint uniquify_constraint_for uniquify_constraint]. repeat first [ progress subst | progress cbn [ContextSet.constraints fst snd] - | progress cbv [ConstraintSet.Exists] + | progress cbv [UnivConstraintSet.Exists] | destruct ? | rewrite ConstraintSet_In_fold_add | rewrite ConstraintSetFact.empty_iff @@ -381,7 +381,7 @@ Lemma satisfies_declare_and_uniquify_and_combine_levels_1_0 {cs cstr v} : satisfies v (ContextSet.constraints (declare_and_uniquify_and_combine_levels (cs, cstr)).1) -> satisfies (uniquify_valuation_for (ContextSet.levels cs) true v) (ContextSet.constraints cs). Proof. - cbv [satisfies ConstraintSet.For_all uniquify_valuation_for]. + cbv [satisfies UnivConstraintSet.For_all uniquify_valuation_for]. intros H x Hi; specialize (H _ ltac:(eapply ConstraintSet_In__declare_and_uniquify_and_combine_levels_1__0, Hi)). destruct x as [[l []] r]; cbn in *; inversion H; clear H; subst; constructor. @@ -392,7 +392,7 @@ Lemma satisfies_declare_and_uniquify_and_combine_levels_1_1 {cs cstr v} : satisfies v (ContextSet.constraints cs) -> satisfies (ununiquify_valuation 2 v) (ContextSet.constraints (declare_and_uniquify_and_combine_levels (cs, cstr)).1). Proof. - cbv [satisfies ConstraintSet.For_all ununiquify_valuation]. + cbv [satisfies UnivConstraintSet.For_all ununiquify_valuation]. intros H x Hi; specialize (H _ ltac:(eapply ConstraintSet_In__declare_and_uniquify_and_combine_levels_1__1, Hi)). destruct x as [[l []] r]; cbn in *; inversion H; clear H; subst; constructor. @@ -403,7 +403,7 @@ Lemma satisfies_declare_and_uniquify_and_combine_levels_2_0 {cs cstr v} : satisfies v (declare_and_uniquify_and_combine_levels (cs, cstr)).2 -> satisfies (uniquify_valuation_for (ContextSet.levels cs) false v) cstr. Proof. - cbv [satisfies ConstraintSet.For_all uniquify_valuation_for]. + cbv [satisfies UnivConstraintSet.For_all uniquify_valuation_for]. intros H x Hi; specialize (H _ ltac:(eapply ConstraintSet_In__declare_and_uniquify_and_combine_levels_2__0, Hi)). destruct x as [[l []] r]; cbn in *; inversion H; clear H; subst; constructor. @@ -414,7 +414,7 @@ Lemma satisfies_declare_and_uniquify_levels_2_1 {cs cstr v} : satisfies v cstr -> satisfies (ununiquify_valuation 2 v) (declare_and_uniquify_levels (cs, cstr)).2. Proof. - cbv [satisfies ConstraintSet.For_all uniquify_valuation_for]. + cbv [satisfies UnivConstraintSet.For_all uniquify_valuation_for]. intros H x Hi; specialize (H _ ltac:(eapply ConstraintSet_In__declare_and_uniquify_levels_2__1, Hi)). destruct x as [[l []] r]; cbn in *; inversion H; clear H; subst; constructor. @@ -434,15 +434,15 @@ Lemma satisfies_combine_valuations {cs cstr v v'} /\ LevelSet.For_all (fun l => val v l = val vc l) (ContextSet.levels cs'). Proof. repeat match goal with H := _ |- _ => subst H end. - cbv [satisfies ConstraintSet.For_all LevelSet.For_all combine_valuations val Level.Evaluable ContextSet.constraints ContextSet.levels declare_and_uniquify_and_combine_levels declare_and_uniquify_levels] in *; + cbv [satisfies UnivConstraintSet.For_all LevelSet.For_all combine_valuations val Level.Evaluable ContextSet.constraints ContextSet.levels declare_and_uniquify_and_combine_levels declare_and_uniquify_levels] in *; cbn [fst snd valuation_poly valuation_mono] in *. revert Hv Hv' Hagree. - progress repeat setoid_rewrite ConstraintSet.union_spec. + progress repeat setoid_rewrite UnivConstraintSet.union_spec. progress repeat setoid_rewrite LevelSet_In_fold_add. progress repeat setoid_rewrite ConstraintSet_In_fold_add. progress repeat setoid_rewrite ConstraintSetFact.empty_iff. progress repeat setoid_rewrite LevelSet.singleton_spec. - cbv [LevelSet.Exists ConstraintSet.Exists uniquify_constraint_for uniquify_constraint uniquify_level_for uniquify_level]. + cbv [LevelSet.Exists UnivConstraintSet.Exists uniquify_constraint_for uniquify_constraint uniquify_level_for uniquify_level]. intros. split. 2: intro x; specialize (Hagree (ununiquify_level 2 x)). @@ -502,7 +502,7 @@ Proof. all: repeat match goal with | [ H : LevelSet.In _ _ |- _ ] => progress specialize_all_ways_under_binders_by exact H - | [ H : ConstraintSet.In _ _ |- _ ] + | [ H : UnivConstraintSet.In _ _ |- _ ] => progress specialize_all_ways_under_binders_by exact H end. all: repeat first [ progress subst @@ -585,9 +585,9 @@ Proof. pose proof (levels_of_cs_spec (ContextSet.constraints cs)). pose proof (levels_of_cs_spec cstr). cbv [declare_and_uniquify_levels]; cbn [fst snd]. - cbv [uGraph.global_uctx_invariants uGraph.uctx_invariants ConstraintSet.For_all declared_cstr_levels] in *; cbn [fst snd ContextSet.levels ContextSet.constraints] in *. + cbv [uGraph.global_uctx_invariants uGraph.uctx_invariants UnivConstraintSet.For_all declared_univ_cstr_levels] in *; cbn [fst snd ContextSet.levels ContextSet.constraints] in *. repeat first [ progress subst - | progress cbv [LevelSet.Exists ConstraintSet.Exists uniquify_constraint_for uniquify_constraint uniquify_level_for] in * + | progress cbv [LevelSet.Exists UnivConstraintSet.Exists uniquify_constraint_for uniquify_constraint uniquify_level_for] in * | rewrite !LevelSet_In_fold_add | rewrite !ConstraintSet_In_fold_add | rewrite !LevelSet.singleton_spec @@ -598,7 +598,7 @@ Proof. | setoid_rewrite ConstraintSetFact.empty_iff | match goal with | [ H : (_, _) = (_, _) |- _ ] => inv H - | [ H : forall x : ConstraintSet.elt, _ |- _ ] + | [ H : forall x : UnivConstraintSet.elt, _ |- _ ] => specialize (fun a b c => H ((a, b), c)) end | solve [ eauto ] @@ -645,7 +645,7 @@ Proof. | progress subst | exfalso; assumption | progress rewrite ?@gc_of_constraint_iff in * by eassumption - | progress cbv [ConstraintSet.Exists on_Some] in * + | progress cbv [UnivConstraintSet.Exists on_Some] in * | progress destruct ? | solve [ eauto 6 ] ]. all: [ > ]. @@ -657,7 +657,7 @@ Proof. | progress subst | exfalso; assumption | progress rewrite ?@gc_of_constraint_iff in * by eassumption - | progress cbv [ConstraintSet.Exists on_Some] in * + | progress cbv [UnivConstraintSet.Exists on_Some] in * | progress destruct ? | solve [ eauto 6 ] ]. eexists; split; diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index 80ac4a138..4ec8c6dbb 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -287,19 +287,19 @@ End GoodConstraint. Notation gc_satisfies0 := GoodConstraint.satisfies. Module GoodConstraintSet := Make GoodConstraint. -Module GoodConstraintSetFact := WFactsOn GoodConstraint GoodConstraintSet. -Module GoodConstraintSetProp := WPropertiesOn GoodConstraint GoodConstraintSet. +Module GoodConstraintSetFact := WFactsOn GoodConstraint GoodUnivConstraintSet. +Module GoodConstraintSetProp := WPropertiesOn GoodConstraint GoodUnivConstraintSet. Module GoodConstraintSetDecide := WDecide (GoodConstraintSet). -Module GCS := GoodConstraintSet. +Module GCS := GoodUnivConstraintSet. Ltac gcsets := GoodConstraintSetDecide.fsetdec. Definition gcs_equal x y : Prop := - LevelSet.Equal x.1 y.1 /\ GoodConstraintSet.Equal x.2 y.2. + LevelSet.Equal x.1 y.1 /\ GoodUnivConstraintSet.Equal x.2 y.2. Infix "=_gcs" := gcs_equal (at level 200). Notation "(=_gcs)" := gcs_equal (at level 0). -Global Instance proper_pair_levels_gcs : Proper ((=_lset) ==> GoodConstraintSet.Equal ==> (=_gcs)) (@pair LevelSet.t GoodConstraintSet.t). +Global Instance proper_pair_levels_gcs : Proper ((=_lset) ==> GoodUnivConstraintSet.Equal ==> (=_gcs)) (@pair LevelSet.t GoodUnivConstraintSet.t). Proof. intros l l' eq gcs gcs' eq'. split; cbn; auto. @@ -311,10 +311,10 @@ Proof. Qed. Definition GoodConstraintSet_pair x y - := GoodConstraintSet.add y (GoodConstraintSet.singleton x). + := GoodUnivConstraintSet.add y (GoodUnivConstraintSet.singleton x). Lemma GoodConstraintSet_pair_In x y z - : GoodConstraintSet.In x (GoodConstraintSet_pair y z) + : GoodUnivConstraintSet.In x (GoodConstraintSet_pair y z) -> x = y \/ x = z. Proof. intro H. apply GoodConstraintSetFact.add_iff in H. @@ -329,10 +329,10 @@ Proof. move=> [->|->]; apply/GCS.add_spec; by [right; apply/GCS.singleton_spec| left]. Qed. -Definition gc_satisfies v : GoodConstraintSet.t -> bool := - GoodConstraintSet.for_all (gc_satisfies0 v). +Definition gc_satisfies v : GoodUnivConstraintSet.t -> bool := + GoodUnivConstraintSet.for_all (gc_satisfies0 v). -Arguments GoodConstraintSet.for_all : simpl never. +Arguments GoodUnivConstraintSet.for_all : simpl never. Definition gc_consistent ctrs : Prop := exists v, gc_satisfies v ctrs. @@ -341,14 +341,14 @@ Lemma gc_satisfies_pair v gc1 gc2 : gc_satisfies v (GoodConstraintSet_pair gc1 gc2). Proof. unfold gc_satisfies, GoodConstraintSet_pair. - rewrite [is_true (GoodConstraintSet.for_all _ _)]GoodConstraintSet.for_all_spec. + rewrite [is_true (GoodUnivConstraintSet.for_all _ _)]GoodUnivConstraintSet.for_all_spec. split. - intros [sat1 sat2] x. - rewrite GoodConstraintSet.add_spec. move=> [->|] //. - rewrite GoodConstraintSet.singleton_spec => -> //. + rewrite GoodUnivConstraintSet.add_spec. move=> [->|] //. + rewrite GoodUnivConstraintSet.singleton_spec => -> //. - intros ha. split; apply ha; - rewrite GoodConstraintSet.add_spec; - rewrite GoodConstraintSet.singleton_spec; auto. + rewrite GoodUnivConstraintSet.add_spec; + rewrite GoodUnivConstraintSet.singleton_spec; auto. Qed. Section GcOfConstraint. @@ -358,9 +358,9 @@ Section GcOfConstraint. (* Some empty -> useless *) (* else: singleton or two elements set (l = l' -> {l<=l', l'<=l}) *) Definition gc_of_constraint `{checker_flags} (uc : LevelConstraint.t) - : option GoodConstraintSet.t - := let empty := Some GoodConstraintSet.empty in - let singleton := fun x => Some (GoodConstraintSet.singleton x) in + : option GoodUnivConstraintSet.t + := let empty := Some GoodUnivConstraintSet.empty in + let singleton := fun x => Some (GoodUnivConstraintSet.singleton x) in let pair := fun x y => Some (GoodConstraintSet_pair x y) in match uc with (* Set _ _ *) @@ -417,18 +417,18 @@ Context `{cf : checker_flags}. Lemma gc_satisfies_singleton v c : gc_satisfies0 v c <-> - gc_satisfies v (GoodConstraintSet.singleton c). + gc_satisfies v (GoodUnivConstraintSet.singleton c). Proof using Type. split. - intros H; unfold gc_satisfies. - eapply GoodConstraintSet.for_all_spec; auto. proper. - intros x xin. eapply GoodConstraintSet.singleton_spec in xin. + eapply GoodUnivConstraintSet.for_all_spec; auto. proper. + intros x xin. eapply GoodUnivConstraintSet.singleton_spec in xin. now subst. - unfold gc_satisfies. intros gc. - eapply GoodConstraintSet.for_all_spec in gc; auto. 2:proper. + eapply GoodUnivConstraintSet.for_all_spec in gc; auto. 2:proper. specialize (gc c). - rewrite -> GoodConstraintSet.singleton_spec in gc. + rewrite -> GoodUnivConstraintSet.singleton_spec in gc. now apply gc. Qed. @@ -468,27 +468,27 @@ Proof using Type. repeat toProp; try lia. Qed. -Definition add_gc_of_constraint uc (S : option GoodConstraintSet.t) +Definition add_gc_of_constraint uc (S : option GoodUnivConstraintSet.t) := S1 <- S ;; S2 <- gc_of_constraint uc ;; - ret (GoodConstraintSet.union S1 S2). + ret (GoodUnivConstraintSet.union S1 S2). -Definition gc_of_constraints (ctrs : ConstraintSet.t) : option GoodConstraintSet.t - := ConstraintSet.fold add_gc_of_constraint - ctrs (Some GoodConstraintSet.empty). +Definition gc_of_constraints (ctrs : UnivConstraintSet.t) : option GoodUnivConstraintSet.t + := UnivConstraintSet.fold add_gc_of_constraint + ctrs (Some GoodUnivConstraintSet.empty). Lemma gc_of_constraints_spec v ctrs : satisfies v ctrs <-> on_Some (gc_satisfies v) (gc_of_constraints ctrs). Proof using Type. - unfold gc_satisfies, satisfies, ConstraintSet.For_all, gc_of_constraints. - set (S := GoodConstraintSet.empty). - rewrite ConstraintSet.fold_spec. + unfold gc_satisfies, satisfies, UnivConstraintSet.For_all, gc_of_constraints. + set (S := GoodUnivConstraintSet.empty). + rewrite UnivConstraintSet.fold_spec. etransitivity. eapply iff_forall. intro; eapply imp_iff_compat_r. eapply ConstraintSetFact.elements_iff. - set (l := ConstraintSet.elements ctrs). simpl. + set (l := UnivConstraintSet.elements ctrs). simpl. transitivity ((forall uc, InA Logic.eq uc l -> satisfies0 v uc) /\ - (forall gc, GoodConstraintSet.In gc S -> gc_satisfies0 v gc)). { + (forall gc, GoodUnivConstraintSet.In gc S -> gc_satisfies0 v gc)). { intuition. inversion H0. } clearbody S; revert S; induction l; intro S; cbn. - split. @@ -676,13 +676,13 @@ Defined. Definition declared : Level.t -> LevelSet.t -> Prop := LevelSet.In. Definition uctx_invariants (uctx : ContextSet.t) - := ConstraintSet.For_all (declared_cstr_levels uctx.1) uctx.2. + := UnivConstraintSet.For_all (declared_univ_cstr_levels uctx.1) uctx.2. Definition global_uctx_invariants (uctx : ContextSet.t) := LevelSet.In Level.lzero uctx.1 /\ uctx_invariants uctx. -Definition global_gc_uctx_invariants (uctx : VSet.t * GoodConstraintSet.t) - := VSet.In lzero uctx.1 /\ GoodConstraintSet.For_all (fun gc => match gc with +Definition global_gc_uctx_invariants (uctx : VSet.t * GoodUnivConstraintSet.t) + := VSet.In lzero uctx.1 /\ GoodUnivConstraintSet.For_all (fun gc => match gc with | GoodConstraint.gc_le l z l' => VSet.In (vtn l) uctx.1 /\ VSet.In (vtn l') uctx.1 | GoodConstraint.gc_lt_set_level _ n @@ -692,7 +692,7 @@ Definition global_gc_uctx_invariants (uctx : VSet.t * GoodConstraintSet.t) end) uctx.2. Definition gc_of_uctx `{checker_flags} (uctx : ContextSet.t) - : option (VSet.t * GoodConstraintSet.t) + : option (VSet.t * GoodUnivConstraintSet.t) := ctrs <- gc_of_constraints uctx.2 ;; ret (uctx.1, ctrs). @@ -711,22 +711,22 @@ Proof. rewrite /gc_of_uctx=> -> //=. Qed. Lemma gc_of_constraint_iff `{cf:checker_flags} ctrs0 ctrs gc (HH : gc_of_constraints ctrs0 = Some ctrs) -: GoodConstraintSet.In gc ctrs - <-> ConstraintSet.Exists - (fun e => on_Some (GoodConstraintSet.In gc) (gc_of_constraint e)) ctrs0. +: GoodUnivConstraintSet.In gc ctrs + <-> UnivConstraintSet.Exists + (fun e => on_Some (GoodUnivConstraintSet.In gc) (gc_of_constraint e)) ctrs0. Proof. - unfold gc_of_constraints in HH. rewrite ConstraintSet.fold_spec in HH. - transitivity ((exists ctr, In ctr (ConstraintSet.elements ctrs0) /\ - on_Some (GoodConstraintSet.In gc) (gc_of_constraint ctr)) - \/ GoodConstraintSet.In gc GoodConstraintSet.empty). + unfold gc_of_constraints in HH. rewrite UnivConstraintSet.fold_spec in HH. + transitivity ((exists ctr, In ctr (UnivConstraintSet.elements ctrs0) /\ + on_Some (GoodUnivConstraintSet.In gc) (gc_of_constraint ctr)) + \/ GoodUnivConstraintSet.In gc GoodUnivConstraintSet.empty). 2:{ split. - intros [[ctr [H1 H2]]|H]. exists ctr. split. apply ConstraintSetFact.elements_iff, InA_In_eq; tas. tas. now apply GoodConstraintSetFact.empty_iff in H. - intros [ctr H]. left. exists ctr. split. apply InA_In_eq, ConstraintSetFact.elements_1, H. apply H. } - revert HH; generalize GoodConstraintSet.empty. - induction (ConstraintSet.elements ctrs0). + revert HH; generalize GoodUnivConstraintSet.empty. + induction (UnivConstraintSet.elements ctrs0). - cbn. intros X HH. apply some_inj in HH; subst. firstorder. - intros X HH. simpl in HH. unfold add_gc_of_constraint at 2 in HH. @@ -734,7 +734,7 @@ Proof. + intros Y HY. rewrite HY in HH. apply IHl in HH. etransitivity. exact HH. etransitivity. - apply or_iff_compat_l. apply GoodConstraintSet.union_spec. + apply or_iff_compat_l. apply GoodUnivConstraintSet.union_spec. split. * intros [[ctr H]|[H|H]]. left. exists ctr. intuition. intuition. left. exists a. intuition. rewrite HY; tas. @@ -777,11 +777,11 @@ Proof. | HH : context [ (?z <=? 0)%Z ] |- _ => destruct (Z.leb_spec z 0); simpl in HH; auto | HH : False |- _ => contradiction HH - | HH : GoodConstraintSet.In ?A GoodConstraintSet.empty |- _ + | HH : GoodUnivConstraintSet.In ?A GoodUnivConstraintSet.empty |- _ => apply GoodConstraintSetFact.empty_iff in HH; contradiction HH - | HH : GoodConstraintSet.In ?A (GoodConstraintSet.singleton ?B) |- _ + | HH : GoodUnivConstraintSet.In ?A (GoodUnivConstraintSet.singleton ?B) |- _ => apply GoodConstraintSetFact.singleton_1 in HH; subst gc - | HH : GoodConstraintSet.In ?A (GoodConstraintSet_pair ?B _) |- _ + | HH : GoodUnivConstraintSet.In ?A (GoodConstraintSet_pair ?B _) |- _ => apply GoodConstraintSet_pair_In in HH; destruct HH as [HH|HH]; subst gc end. all: try split; try apply Hi; @@ -840,16 +840,16 @@ Definition add_level_edges := end). Definition add_cstrs ctrs := - GoodConstraintSet.fold (fun ctr => EdgeSet.add (edge_of_constraint ctr)) ctrs. + GoodUnivConstraintSet.fold (fun ctr => EdgeSet.add (edge_of_constraint ctr)) ctrs. Lemma add_cstrs_spec e x g : EdgeSet.In e (add_cstrs x g) <-> - (exists c, edge_of_constraint c = e /\ GoodConstraintSet.In c x) \/ EdgeSet.In e g. + (exists c, edge_of_constraint c = e /\ GoodUnivConstraintSet.In c x) \/ EdgeSet.In e g. Proof. - rewrite /add_cstrs GoodConstraintSet.fold_spec. + rewrite /add_cstrs GoodUnivConstraintSet.fold_spec. transitivity - ((exists c, edge_of_constraint c = e /\ In c (GoodConstraintSet.elements x)) \/ EdgeSet.In e g). - - induction (GoodConstraintSet.elements x) in g |- *; simpl. + ((exists c, edge_of_constraint c = e /\ In c (GoodUnivConstraintSet.elements x)) \/ EdgeSet.In e g). + - induction (GoodUnivConstraintSet.elements x) in g |- *; simpl. intuition auto. now destruct H0 as [c [_ F]]. rewrite IHl. rewrite EdgeSet.add_spec. @@ -869,12 +869,12 @@ Proof. intros s s' eq x y H. intros e. rewrite /add_cstrs. - rewrite !GoodConstraintSet.fold_spec. subst s'. - induction (GoodConstraintSet.elements s) in x, y, H, e |- *; cbn; auto. + rewrite !GoodUnivConstraintSet.fold_spec. subst s'. + induction (GoodUnivConstraintSet.elements s) in x, y, H, e |- *; cbn; auto. apply IHl. now rewrite H. Qed. -#[global] Instance add_cstrs_proper' : Proper (GoodConstraintSet.Equal ==> EdgeSet.Equal ==> EdgeSet.Equal)%signature add_cstrs. +#[global] Instance add_cstrs_proper' : Proper (GoodUnivConstraintSet.Equal ==> EdgeSet.Equal ==> EdgeSet.Equal)%signature add_cstrs. Proof. intros s s' eq x y H. red in H. intros e. @@ -884,7 +884,7 @@ Qed. (** This introduces both Set (exists l, VSet.In (vtn l) uctx.1 /\ e = edge_of_level l) - \/ (GoodConstraintSet.Exists (fun gc => e = edge_of_constraint gc) uctx.2). + \/ (GoodUnivConstraintSet.Exists (fun gc => e = edge_of_constraint gc) uctx.2). Proof. unfold make_graph. unfold wGraph.E. simpl. - assert (XX: forall E, EdgeSet.In e (GoodConstraintSet.fold + assert (XX: forall E, EdgeSet.In e (GoodUnivConstraintSet.fold (fun ctr => EdgeSet.add (edge_of_constraint ctr)) uctx.2 E) - <-> (exists gc, In gc (GoodConstraintSet.elements uctx.2) /\ e = edge_of_constraint gc) + <-> (exists gc, In gc (GoodUnivConstraintSet.elements uctx.2) /\ e = edge_of_constraint gc) \/ EdgeSet.In e E). { - intro E. rewrite GoodConstraintSet.fold_spec. - induction (GoodConstraintSet.elements uctx.2) in E |- *. + intro E. rewrite GoodUnivConstraintSet.fold_spec. + induction (GoodUnivConstraintSet.elements uctx.2) in E |- *. - cbn. firstorder. - simpl. etransitivity. apply IHl. clear IHl. split. + intros [[gc H]|H]. left. exists gc. intuition. @@ -1060,12 +1060,12 @@ Section MakeGraph. destruct He as [[l [Hl He]]|[ctr [Hc He]]]; cbn. + subst e; cbn. destruct l; cbn; lia. + subst e. - apply GoodConstraintSet.for_all_spec in H. + apply GoodUnivConstraintSet.for_all_spec in H. 2: intros x y []; reflexivity. specialize (H _ Hc). cbn in *. destruct ctr as [[] z []|[] []| |n|n]; cbn in *; toProp H; try lia. all:try destruct t0; cbn in *; try lia. - - apply GoodConstraintSet.for_all_spec. + - apply GoodUnivConstraintSet.for_all_spec. intros x y []; reflexivity. intros gc Hgc. pose proof (XX := proj2 (make_graph_E uctx (edge_of_constraint gc))). @@ -1242,7 +1242,7 @@ Section CheckLeqProcedure. end. Definition check_gc_constraints_gen := - GoodConstraintSet.for_all check_gc_constraint_gen. + GoodUnivConstraintSet.for_all check_gc_constraint_gen. Definition check_constraints_gen ctrs := match gc_of_constraints ctrs with @@ -2012,7 +2012,7 @@ Section CheckLeq. end. Definition gcs_levels_declared (vset : VSet.t) gcs := - GoodConstraintSet.For_all (gc_levels_declared' vset) gcs. + GoodUnivConstraintSet.For_all (gc_levels_declared' vset) gcs. Lemma check_gc_constraint_spec_gen leqb_level_n_gen @@ -2057,8 +2057,8 @@ Section CheckLeq. rewrite /gcs_levels_declared in Hu1. pose proof check_gc_constraint_spec_gen as XX. unfold check_gc_constraints_gen. destruct check_univs; [cbn|trivial]. intros HH v Hv. - apply GoodConstraintSet.for_all_spec. now intros x y []. - apply GoodConstraintSet.for_all_spec in HH. 2: now intros x y []. + apply GoodUnivConstraintSet.for_all_spec. now intros x y []. + apply GoodUnivConstraintSet.for_all_spec in HH. 2: now intros x y []. intros gc Hgc. specialize (HH gc Hgc). eapply XX; try eassumption. now apply Hu1. Qed. @@ -2137,7 +2137,7 @@ Section CheckLeq2. uctx (Huctx: global_uctx_invariants uctx) (HC : consistent uctx.2) (HG : is_graph_of_uctx G uctx). - Definition uctx' : VSet.t × GoodConstraintSet.t. + Definition uctx' : VSet.t × GoodUnivConstraintSet.t. unfold is_graph_of_uctx, gc_of_uctx in HG. destruct (gc_of_constraints uctx.2) as [ctrs|]. exact (uctx.1, ctrs). @@ -2329,8 +2329,8 @@ Section CheckLeq2. | GoodConstraint.gc_le_var_set n k => leq0_level_n (- Z.of_nat k)%Z (Level.lvar n) lzero end. - Definition valid_gc_constraints (gcs : GoodConstraintSet.t) := - GoodConstraintSet.For_all valid_gc_constraint gcs. + Definition valid_gc_constraints (gcs : GoodUnivConstraintSet.t) := + GoodUnivConstraintSet.For_all valid_gc_constraint gcs. Lemma leq0_level_n_complete_gen leqb_level_n_gen (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) z l l' : @@ -2570,7 +2570,7 @@ End CheckLeq2. Section AddLevelsCstrs. - Definition add_uctx (uctx : VSet.t × GoodConstraintSet.t) + Definition add_uctx (uctx : VSet.t × GoodUnivConstraintSet.t) (G : universes_graph) : universes_graph := let levels := VSet.union uctx.1 G.1.1 in let edges := add_level_edges uctx.1 G.1.2 in @@ -2580,8 +2580,8 @@ Section AddLevelsCstrs. Definition uctx_of_udecl u : ContextSet.t := (levels_of_udecl u, constraints_of_udecl u). - Lemma gcs_elements_union s s' : GoodConstraintSet.Empty s' -> - GoodConstraintSet.Equal (GoodConstraintSet.union s s') s. + Lemma gcs_elements_union s s' : GoodUnivConstraintSet.Empty s' -> + GoodUnivConstraintSet.Equal (GoodUnivConstraintSet.union s s') s. Proof. gcsets. Qed. Lemma add_level_edges_spec e x g : @@ -2608,11 +2608,11 @@ Section AddLevelsCstrs. Qed. Lemma add_cstrs_union g ctrs1 ctrs2 : - EdgeSet.Equal (add_cstrs (GoodConstraintSet.union ctrs1 ctrs2) g) (add_cstrs ctrs1 (add_cstrs ctrs2 g)). + EdgeSet.Equal (add_cstrs (GoodUnivConstraintSet.union ctrs1 ctrs2) g) (add_cstrs ctrs1 (add_cstrs ctrs2 g)). Proof. intros e. rewrite !add_cstrs_spec. - setoid_rewrite GoodConstraintSet.union_spec. + setoid_rewrite GoodUnivConstraintSet.union_spec. firstorder eauto. Qed. @@ -2841,7 +2841,7 @@ Section AddLevelsCstrs. Lemma add_uctx_make_graph levels1 levels2 ctrs1 ctrs2 : Equal_graph (add_uctx (levels1, ctrs1) (make_graph (levels2, ctrs2))) (make_graph (VSet.union levels1 levels2, - GoodConstraintSet.union ctrs1 ctrs2)). + GoodUnivConstraintSet.union ctrs1 ctrs2)). Proof. rewrite /make_graph /= /add_uctx /=. unfold Equal_graph. split => //. split => //. @@ -2864,9 +2864,9 @@ Section AddLevelsCstrs. apply: wGraph.subgraph_acyclic ; apply: add_uctx_subgraph. Qed. - Definition gc_result_eq (x y : option GoodConstraintSet.t) := + Definition gc_result_eq (x y : option GoodUnivConstraintSet.t) := match x, y with - | Some x, Some y => GoodConstraintSet.eq x y + | Some x, Some y => GoodUnivConstraintSet.eq x y | None, None => True | _, _ => False end. @@ -2903,32 +2903,32 @@ Section AddLevelsCstrs. now rewrite fold_left_add_gc_None. Qed. - Variant gc_of_constraints_view {cf:checker_flags} (s : ConstraintSet.t) : option GoodConstraintSet.t -> Type := + Variant gc_of_constraints_view {cf:checker_flags} (s : UnivConstraintSet.t) : option GoodUnivConstraintSet.t -> Type := | gc_of_constraints_ok l : - (forall gc, GoodConstraintSet.In gc l <-> - (exists c gcs, gc_of_constraint c = Some gcs /\ ConstraintSet.In c s /\ GoodConstraintSet.In gc gcs)) -> - (forall c, ConstraintSet.In c s -> - exists gcs, gc_of_constraint c = Some gcs /\ GoodConstraintSet.Subset gcs l) -> + (forall gc, GoodUnivConstraintSet.In gc l <-> + (exists c gcs, gc_of_constraint c = Some gcs /\ UnivConstraintSet.In c s /\ GoodUnivConstraintSet.In gc gcs)) -> + (forall c, UnivConstraintSet.In c s -> + exists gcs, gc_of_constraint c = Some gcs /\ GoodUnivConstraintSet.Subset gcs l) -> gc_of_constraints_view s (Some l) | gc_of_constraints_none : - (exists c, ConstraintSet.In c s /\ gc_of_constraint c = None) -> + (exists c, UnivConstraintSet.In c s /\ gc_of_constraint c = None) -> gc_of_constraints_view s None. Lemma gc_of_constraintsP {cf:checker_flags} s : gc_of_constraints_view s (gc_of_constraints s). Proof. unfold gc_of_constraints. - rewrite ConstraintSet.fold_spec. + rewrite UnivConstraintSet.fold_spec. destruct fold_left eqn:eq. - constructor. + intros. setoid_rewrite ConstraintSetFact.elements_iff. setoid_rewrite InA_In_eq. - transitivity ((exists (c : LevelConstraint.t) (gcs : GoodConstraintSet.t), + transitivity ((exists (c : LevelConstraint.t) (gcs : GoodUnivConstraintSet.t), gc_of_constraint c = Some gcs /\ - In c (ConstraintSet.elements s) /\ GoodConstraintSet.In gc gcs) \/ GCS.In gc GCS.empty). + In c (UnivConstraintSet.elements s) /\ GoodUnivConstraintSet.In gc gcs) \/ GCS.In gc GCS.empty). 2:gcsets. revert eq. generalize (GCS.empty). - induction (ConstraintSet.elements s) in t0 |- *; simpl in *. + induction (UnivConstraintSet.elements s) in t0 |- *; simpl in *. intros ? [= ->]. firstorder auto. intros t' Ht'. pose proof (add_gc_of_constraint_spec a t'). @@ -2950,7 +2950,7 @@ Section AddLevelsCstrs. setoid_rewrite ConstraintSetFact.elements_iff; setoid_rewrite InA_In_eq at 1. revert eq. generalize (GCS.empty). - induction (ConstraintSet.elements s) in t0 |- *; simpl in *. + induction (UnivConstraintSet.elements s) in t0 |- *; simpl in *. intros ? [= ->]. firstorder auto. intros t' Ht'. pose proof (add_gc_of_constraint_spec a t'). @@ -2967,7 +2967,7 @@ Section AddLevelsCstrs. setoid_rewrite ConstraintSetFact.elements_iff; setoid_rewrite InA_In_eq at 1. revert eq. generalize GCS.empty. - induction (ConstraintSet.elements s); simpl in * => //. + induction (UnivConstraintSet.elements s); simpl in * => //. intros t' eq. pose proof (add_gc_of_constraint_spec a t'). destruct add_gc_of_constraint eqn:addgc. @@ -2979,38 +2979,38 @@ Section AddLevelsCstrs. Qed. Lemma gc_of_constraints_union {cf:checker_flags} S S' : - gc_result_eq (gc_of_constraints (ConstraintSet.union S S')) + gc_result_eq (gc_of_constraints (UnivConstraintSet.union S S')) (S1 <- gc_of_constraints S ;; S2 <- gc_of_constraints S' ;; - ret (GoodConstraintSet.union S1 S2)). + ret (GoodUnivConstraintSet.union S1 S2)). Proof. case: (gc_of_constraintsP S) => [GS HS HS0|[c [incs gcn]]]; simpl. case: (gc_of_constraintsP S') => [GS' HS' HS'0|GS']; simpl. - case: (gc_of_constraintsP (ConstraintSet.union S S')) => [GSS' HSS' HSS'0|[c [inc gcn]]]. + case: (gc_of_constraintsP (UnivConstraintSet.union S S')) => [GSS' HSS' HSS'0|[c [inc gcn]]]. simpl. - intros gc. rewrite HSS' GCS.union_spec HS HS'. - setoid_rewrite ConstraintSet.union_spec. + setoid_rewrite UnivConstraintSet.union_spec. split. intros [c [gcs ?]]. intuition auto. left; firstorder auto. right; firstorder auto. intros [[c [gcs ?]]|[c [gcs ?]]]; exists c, gcs; intuition auto. - - cbn. apply ConstraintSet.union_spec in inc. + - cbn. apply UnivConstraintSet.union_spec in inc. destruct inc. specialize (HS0 _ H). rewrite gcn in HS0. now destruct HS0. specialize (HS'0 _ H). rewrite gcn in HS'0. now destruct HS'0. - destruct GS' as [c [inc gcn]]. - case: (gc_of_constraintsP (ConstraintSet.union S S')) => [GSS' HSS' HSS'0|[c' [inc' gcn']]]. + case: (gc_of_constraintsP (UnivConstraintSet.union S S')) => [GSS' HSS' HSS'0|[c' [inc' gcn']]]. cbn. specialize (HSS'0 c). - rewrite -> ConstraintSet.union_spec in HSS'0. + rewrite -> UnivConstraintSet.union_spec in HSS'0. specialize (HSS'0 (or_intror inc)) as [gcs [eq _]]. now congruence. split. - - case: (gc_of_constraintsP (ConstraintSet.union S S')) => [GSS' HSS' HSS'0|[c' [inc' gcn']]]. + - case: (gc_of_constraintsP (UnivConstraintSet.union S S')) => [GSS' HSS' HSS'0|[c' [inc' gcn']]]. cbn. specialize (HSS'0 c). - rewrite -> ConstraintSet.union_spec in HSS'0. + rewrite -> UnivConstraintSet.union_spec in HSS'0. specialize (HSS'0 (or_introl incs)) as [gcs [eq _]]. now congruence. split. @@ -3050,7 +3050,7 @@ Proof. apply eq. Qed. -#[global] Instance gc_of_constraints_proper {cf : checker_flags} : Proper ((=_cset) ==> R_opt GoodConstraintSet.Equal) gc_of_constraints. +#[global] Instance gc_of_constraints_proper {cf : checker_flags} : Proper ((=_ucset) ==> R_opt GoodUnivConstraintSet.Equal) gc_of_constraints. Proof. intros c c' eqc; cbn. destruct (gc_of_constraintsP c); @@ -3253,7 +3253,7 @@ Lemma global_uctx_invariants_union_or lvls1 lvls2 cs : global_uctx_invariants (lvls1, cs) \/ global_uctx_invariants (lvls2, cs) -> global_uctx_invariants (LevelSet.union lvls1 lvls2, cs). Proof. - cbv [global_uctx_invariants uctx_invariants ConstraintSet.For_all declared_cstr_levels]; cbn [fst snd ContextSet.levels ContextSet.constraints]. + cbv [global_uctx_invariants uctx_invariants UnivConstraintSet.For_all declared_univ_cstr_levels]; cbn [fst snd ContextSet.levels ContextSet.constraints]. repeat first [ apply conj | progress intros | progress cbv beta iota in * @@ -3270,7 +3270,7 @@ Lemma global_gc_uctx_invariants_union_or lvls1 lvls2 cs : global_gc_uctx_invariants (lvls1, cs) \/ global_gc_uctx_invariants (lvls2, cs) -> global_gc_uctx_invariants (VSet.union lvls1 lvls2, cs). Proof. - cbv [global_gc_uctx_invariants uctx_invariants GoodConstraintSet.For_all declared_cstr_levels]; cbn [fst snd ContextSet.levels ContextSet.constraints]. + cbv [global_gc_uctx_invariants uctx_invariants GoodUnivConstraintSet.For_all declared_univ_cstr_levels]; cbn [fst snd ContextSet.levels ContextSet.constraints]. repeat first [ apply conj | progress intros | progress cbv beta iota in * diff --git a/erasure/theories/EArities.v b/erasure/theories/EArities.v index acc0b4e01..f51e843e3 100644 --- a/erasure/theories/EArities.v +++ b/erasure/theories/EArities.v @@ -513,13 +513,13 @@ Proof. now apply PCUICValidity.validity in t2. Qed. -Lemma leq_sort_propositional_r {cf : checker_flags} (ϕ : ConstraintSet.t) (u1 u2 : sort) : +Lemma leq_sort_propositional_r {cf : checker_flags} (ϕ : UnivConstraintSet.t) (u1 u2 : sort) : leq_sort ϕ u1 u2 -> Sort.is_propositional u2 -> Sort.is_propositional u1. Proof. destruct u1, u2 => //. Qed. -Lemma leq_sort_propositional_l {cf : checker_flags} (ϕ : ConstraintSet.t) (u1 u2 : sort) : +Lemma leq_sort_propositional_l {cf : checker_flags} (ϕ : UnivConstraintSet.t) (u1 u2 : sort) : prop_sub_type = false -> leq_sort ϕ u1 u2 -> Sort.is_propositional u1 -> Sort.is_propositional u2. Proof. diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index 20c93e754..64f7f0d86 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -1469,7 +1469,7 @@ Proof. Qed. From Stdlib Require Import Morphisms. -Global Instance proper_pair_levels_gcs : Proper ((=_lset) ==> GoodConstraintSet.Equal ==> (=_gcs)) (@pair LevelSet.t GoodConstraintSet.t). +Global Instance proper_pair_levels_gcs : Proper ((=_lset) ==> GoodUnivConstraintSet.Equal ==> (=_gcs)) (@pair LevelSet.t GoodUnivConstraintSet.t). Proof. intros l l' eq gcs gcs' eq'. split; cbn; auto. diff --git a/examples/demo.v b/examples/demo.v index da6939013..5a21f0220 100644 --- a/examples/demo.v +++ b/examples/demo.v @@ -137,7 +137,7 @@ Definition mut_i : mutual_inductive_entry := mind_entry_finite := Finite; mind_entry_params := []; mind_entry_inds := [one_i; one_i2]; - mind_entry_universes := Monomorphic_entry (LevelSet.empty, ConstraintSet.empty); + mind_entry_universes := Monomorphic_entry (LevelSet.empty, UnivConstraintSet.empty); mind_entry_template := false; mind_entry_variance := None; mind_entry_private := None; @@ -168,7 +168,7 @@ Definition mut_list_i : mutual_inductive_entry := mind_entry_params := [{| decl_name := bnamed "A"; decl_body := None; decl_type := (tSort Sort.type0) |}]; mind_entry_inds := [one_list_i]; - mind_entry_universes := Monomorphic_entry (LevelSet.empty, ConstraintSet.empty); + mind_entry_universes := Monomorphic_entry (LevelSet.empty, UnivConstraintSet.empty); mind_entry_template := false; mind_entry_variance := None; mind_entry_private := None; diff --git a/examples/metarocq_tour_prelude.v b/examples/metarocq_tour_prelude.v index 8630a8ec6..c30f6f0b3 100644 --- a/examples/metarocq_tour_prelude.v +++ b/examples/metarocq_tour_prelude.v @@ -25,7 +25,7 @@ Definition univ := Level.level "s". (* TODO move to SafeChecker *) Definition gctx : global_env_ext := - ({| universes := (LS.union (LevelSet.singleton Level.lzero) (LevelSet.singleton univ), ConstraintSet.empty); + ({| universes := (LS.union (LevelSet.singleton Level.lzero) (LevelSet.singleton univ), UnivConstraintSet.empty); declarations := []; retroknowledge := Retroknowledge.empty |}, Monomorphic_ctx). (** We use the environment checker to produce the proof that gctx, which is a singleton with only diff --git a/examples/typing_correctness.v b/examples/typing_correctness.v index 5ce32eea2..233d084cc 100644 --- a/examples/typing_correctness.v +++ b/examples/typing_correctness.v @@ -91,7 +91,7 @@ Definition univ := Level.level "s". (* TODO move to SafeChecker *) Definition gctx : global_env_ext := - ({| universes := (LS.union (LevelSet.singleton Level.lzero) (LevelSet.singleton univ), ConstraintSet.empty); declarations := [] + ({| universes := (LS.union (LevelSet.singleton Level.lzero) (LevelSet.singleton univ), UnivConstraintSet.empty); declarations := [] ; retroknowledge := Retroknowledge.empty |}, Monomorphic_ctx). (** We use the environment checker to produce the proof that gctx, which is a singleton with only @@ -163,7 +163,7 @@ Lemma identity_typing (s := sType (Universe.make' univ)): ({| universes := (LS.union (LevelSet.singleton Level.lzero) - (LevelSet.singleton univ), ConstraintSet.empty); + (LevelSet.singleton univ), UnivConstraintSet.empty); declarations := []; retroknowledge := Retroknowledge.empty |}, Monomorphic_ctx) -> diff --git a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v index ee9456ac6..bd64de51a 100644 --- a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v +++ b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v @@ -372,49 +372,49 @@ Proof. Qed. Lemma In_subst_instance_cstrs u c ctrs : - CS.In c (subst_instance_cstrs u ctrs) - <-> exists c', c = subst_instance_cstr u c' /\ CS.In c' ctrs. + UCS.In c (subst_instance_cstrs u ctrs) + <-> exists c', c = subst_instance_cstr u c' /\ UCS.In c' ctrs. Proof. unfold subst_instance_cstrs. - rewrite CS.fold_spec. - transitivity (CS.In c CS.empty \/ + rewrite UCS.fold_spec. + transitivity (UCS.In c UCS.empty \/ exists c', c = subst_instance_cstr u c' - /\ In c' (CS.elements ctrs)). - - generalize (CS.elements ctrs), CS.empty. + /\ In c' (UCS.elements ctrs)). + - generalize (UCS.elements ctrs), UCS.empty. induction l; cbn. + pcuicfo. now destruct H0 as [? ?]. + intros t. etransitivity. 1: eapply IHl. split; intros [HH|HH]. - * destruct a as [[l1 a] l2]. apply CS.add_spec in HH. + * destruct a as [[l1 a] l2]. apply UCS.add_spec in HH. destruct HH as [HH|HH]. 2: now left. right; eexists. split; [|left; reflexivity]. assumption. * destruct HH as [c' ?]. right; exists c'; intuition. - * left. destruct a as [[l1 a] l2]. apply CS.add_spec. + * left. destruct a as [[l1 a] l2]. apply UCS.add_spec. now right. * destruct HH as [c' [HH1 [?|?]]]; subst. -- left. destruct c' as [[l1 c'] l2]; - apply CS.add_spec; now left. + apply UCS.add_spec; now left. -- right. exists c'. intuition. - rewrite ConstraintSetFact.empty_iff. transitivity (exists c', c = subst_instance_cstr u c' - /\ In c' (CS.elements ctrs)). + /\ In c' (UCS.elements ctrs)). 1: intuition. apply iff_ex; intro. apply and_iff_compat_l. symmetry. - etransitivity. 1: symmetry; apply CS.elements_spec1. + etransitivity. 1: symmetry; apply UCS.elements_spec1. etransitivity. 1: eapply SetoidList.InA_alt. split; intro; eauto. now destruct H as [? [[] ?]]. Qed. Lemma In_subst_instance_cstrs' u c ctrs : - CS.In c ctrs -> - CS.In (subst_instance_cstr u c) (subst_instance_cstrs u ctrs). + UCS.In c ctrs -> + UCS.In (subst_instance_cstr u c) (subst_instance_cstrs u ctrs). Proof. intro H. apply In_subst_instance_cstrs. now eexists. Qed. Lemma subst_instance_cstrs_two u1 u2 ctrs : - CS.Equal + UCS.Equal (subst_instance_cstrs u1 (subst_instance_cstrs u2 ctrs)) (subst_instance_cstrs (subst_instance u1 u2) ctrs). Proof. @@ -500,13 +500,13 @@ Proof. Qed. Global Instance satisfies_equal_sets v : - Morphisms.Proper (Morphisms.respectful CS.Equal iff) (satisfies v). + Morphisms.Proper (Morphisms.respectful UCS.Equal iff) (satisfies v). Proof. intros φ1 φ2 H; split; intros HH c Hc; now apply HH, H. Qed. Global Instance satisfies_subsets v : - Morphisms.Proper (Morphisms.respectful CS.Subset (fun A B : Prop => B -> A)) + Morphisms.Proper (Morphisms.respectful UCS.Subset (fun A B : Prop => B -> A)) (satisfies v). Proof. intros φ1 φ2 H H2 c Hc; now apply H2, H. @@ -559,7 +559,7 @@ Lemma not_var_global_ext_levels {cf : checker_flags} Σ (hΣ : wf_ext_wk (Σ, Mo Proof. apply hΣ. Qed. Lemma levels_global_constraint {cf : checker_flags} Σ (hΣ : wf Σ) c : - CS.In c (global_constraints Σ) + UCS.In c (global_constraints Σ) -> LS.In c.1.1 (global_levels Σ) /\ LS.In c.2 (global_levels Σ). Proof. @@ -569,11 +569,11 @@ Proof. Qed. Lemma levels_global_ext_constraint {cf : checker_flags} Σ φ (hΣ : wf_ext_wk (Σ, φ)) c : - CS.In c (global_ext_constraints (Σ, φ)) + UCS.In c (global_ext_constraints (Σ, φ)) -> LS.In c.1.1 (global_ext_levels (Σ, φ)) /\ LS.In c.2 (global_ext_levels (Σ, φ)). Proof. - intro H. apply CS.union_spec in H; simpl in H. + intro H. apply UCS.union_spec in H; simpl in H. destruct hΣ as [hΣ Hφ], H as [Hc|H]; simpl in *. - red in Hφ. unfold global_ext_levels. simpl. destruct c as [[l1 c] l2]; exact (Hφ _ Hc). @@ -585,7 +585,7 @@ Definition is_monomorphic_cstr (c : LevelConstraint.t) := negb (Level.is_var c.1.1) && negb (Level.is_var c.2). Lemma monomorphic_global_constraint {cf : checker_flags} Σ (hΣ : wf Σ) c : - CS.In c (global_constraints Σ) + UCS.In c (global_constraints Σ) -> is_monomorphic_cstr c. Proof. intros H. apply levels_global_constraint in H; tas. @@ -596,7 +596,7 @@ Qed. Lemma monomorphic_global_constraint_ext {cf : checker_flags} Σ (hΣ : wf_ext_wk (Σ, Monomorphic_ctx)) c : - CS.In c (global_ext_constraints (Σ, Monomorphic_ctx)) + UCS.In c (global_ext_constraints (Σ, Monomorphic_ctx)) -> is_monomorphic_cstr c. Proof. intros H. apply levels_global_ext_constraint in H; tas. @@ -617,8 +617,8 @@ Proof. Qed. Lemma equal_subst_instance_cstrs_mono u cstrs : - CS.For_all is_monomorphic_cstr cstrs -> - CS.Equal (subst_instance_cstrs u cstrs) cstrs. + UCS.For_all is_monomorphic_cstr cstrs -> + UCS.Equal (subst_instance_cstrs u cstrs) cstrs. Proof. intros HH c. etransitivity. - eapply In_subst_instance_cstrs. @@ -628,25 +628,25 @@ Proof. Qed. Lemma subst_instance_cstrs_union u φ φ' : - CS.Equal (subst_instance_cstrs u (CS.union φ φ')) - (CS.union (subst_instance_cstrs u φ) (subst_instance_cstrs u φ')). + UCS.Equal (subst_instance_cstrs u (UCS.union φ φ')) + (UCS.union (subst_instance_cstrs u φ) (subst_instance_cstrs u φ')). Proof. intro c; split; intro Hc. - apply In_subst_instance_cstrs in Hc. destruct Hc as [c' [eq Hc]]; subst. - apply CS.union_spec in Hc. apply CS.union_spec. + apply UCS.union_spec in Hc. apply UCS.union_spec. destruct Hc; [left|right]; now apply In_subst_instance_cstrs'. - apply In_subst_instance_cstrs. - apply CS.union_spec in Hc. + apply UCS.union_spec in Hc. destruct Hc as [Hc|Hc]; apply In_subst_instance_cstrs in Hc; - destruct Hc as [c'[eq Hc]]; exists c'; aa; apply CS.union_spec; + destruct Hc as [c'[eq Hc]]; exists c'; aa; apply UCS.union_spec; [left|right]; aa. Qed. -#[global] Hint Unfold CS.For_all : univ_subst. +#[global] Hint Unfold UCS.For_all : univ_subst. Definition sub_context_set (φ φ' : ContextSet.t) - := LS.Subset φ.1 φ'.1 /\ CS.Subset φ.2 φ'.2. + := LS.Subset φ.1 φ'.1 /\ UCS.Subset φ.2 φ'.2. Definition global_ext_context_set Σ : ContextSet.t := (global_ext_levels Σ, global_ext_constraints Σ). @@ -759,7 +759,7 @@ Qed. #[global] Hint Resolve consistent_instance_valid_constraints : univ_subst. -Class SubstUnivPreserved {cf : checker_flags} {A} `{UnivSubst A} (R : ConstraintSet.t -> crelation A) +Class SubstUnivPreserved {cf : checker_flags} {A} `{UnivSubst A} (R : UnivConstraintSet.t -> crelation A) := Build_SubstUnivPreserved : forall φ φ' (u : Instance.t), valid_constraints φ' (subst_instance_cstrs u φ) -> @@ -1827,8 +1827,8 @@ Section SubstIdentity. * left; apply IHn; lia. - now rewrite mapi_length. - simpl. rewrite (mapi_unfold Level.lvar). - assert(CS.Equal (subst_instance_cstrs (unfold #|univs| Level.lvar) cst) cst). - { unfold CS.Equal; intros a. + assert(UCS.Equal (subst_instance_cstrs (unfold #|univs| Level.lvar) cst) cst). + { unfold UCS.Equal; intros a. unfold subst_instance_cstrs. red in wf_glob_ext. destruct wf_glob_ext as [_ wfext]. @@ -1853,7 +1853,7 @@ Section SubstIdentity. eapply subst_instance_level_abs in inl; auto. eapply subst_instance_level_abs in inr; auto. rewrite inl inr. - rewrite !CS.add_spec. + rewrite !UCS.add_spec. intuition auto. } unfold valid_constraints. destruct check_univs; auto. unfold valid_constraints0. simpl. diff --git a/pcuic/theories/Conversion/PCUICWeakeningEnvConv.v b/pcuic/theories/Conversion/PCUICWeakeningEnvConv.v index 6b08a88fe..3a01e5bfd 100644 --- a/pcuic/theories/Conversion/PCUICWeakeningEnvConv.v +++ b/pcuic/theories/Conversion/PCUICWeakeningEnvConv.v @@ -13,7 +13,7 @@ Set Default Goal Selector "!". Implicit Types (cf : checker_flags). Lemma compare_term_subset {cf} pb Σ φ φ' t t' - : ConstraintSet.Subset φ φ' + : UnivConstraintSet.Subset φ φ' -> compare_term Σ φ pb t t' -> compare_term Σ φ' pb t t'. Proof. intro H. apply eq_term_upto_univ_impl; auto. @@ -22,22 +22,22 @@ Proof. Qed. Lemma eq_term_subset {cf} Σ φ φ' t t' - : ConstraintSet.Subset φ φ' -> eq_term Σ φ t t' -> eq_term Σ φ' t t'. + : UnivConstraintSet.Subset φ φ' -> eq_term Σ φ t t' -> eq_term Σ φ' t t'. Proof. apply compare_term_subset with (pb := Conv). Qed. Lemma leq_term_subset {cf:checker_flags} Σ ctrs ctrs' t u - : ConstraintSet.Subset ctrs ctrs' -> leq_term Σ ctrs t u -> leq_term Σ ctrs' t u. + : UnivConstraintSet.Subset ctrs ctrs' -> leq_term Σ ctrs t u -> leq_term Σ ctrs' t u. Proof. apply compare_term_subset with (pb := Cumul). Qed. Lemma compare_decl_subset {cf} pb Σ φ φ' d d' - : ConstraintSet.Subset φ φ' + : UnivConstraintSet.Subset φ φ' -> compare_decl Σ φ pb d d' -> compare_decl Σ φ' pb d d'. Proof. intros Hφ []; constructor; eauto using compare_term_subset. Qed. Lemma compare_context_subset {cf} pb Σ φ φ' Γ Γ' - : ConstraintSet.Subset φ φ' + : UnivConstraintSet.Subset φ φ' -> compare_context Σ φ pb Γ Γ' -> compare_context Σ φ' pb Γ Γ'. Proof. intros Hφ. induction 1; constructor; auto; eapply compare_decl_subset; eassumption. diff --git a/pcuic/theories/PCUICConfluence.v b/pcuic/theories/PCUICConfluence.v index 0b55e1340..b393dde2a 100644 --- a/pcuic/theories/PCUICConfluence.v +++ b/pcuic/theories/PCUICConfluence.v @@ -716,7 +716,7 @@ Proof. intros. eapply eq_term_upto_univ_trans with (subst_instance u2 x); tc. now eapply eq_term_upto_univ_subst_instance. - eapply (eq_term_upto_univ_subst_preserved Σ (fun _ => cmp_universe) (fun _ => cmp_sort) pb napp ConstraintSet.empty ConstraintSet.empty u2). + eapply (eq_term_upto_univ_subst_preserved Σ (fun _ => cmp_universe) (fun _ => cmp_sort) pb napp UnivConstraintSet.empty UnivConstraintSet.empty u2). red. destruct check_univs => //. assumption. Qed. @@ -762,7 +762,7 @@ Proof. eapply eq_context_upto_univ_subst_instance; tc. tea. eapply eq_context_upto_univ_subst_preserved with (cmp_universe := fun _ => cmp_universe) (cmp_sort := fun _ => cmp_sort); tea; tc. unfold_univ_rel eqn:He. - instantiate (1 := CS.empty). instantiate (1 := CS.empty) in Hv. + instantiate (1 := UCS.empty). instantiate (1 := UCS.empty) in Hv. apply Hv. Qed. diff --git a/pcuic/theories/PCUICExpandLetsCorrectness.v b/pcuic/theories/PCUICExpandLetsCorrectness.v index 12ad1d217..b893ca03d 100644 --- a/pcuic/theories/PCUICExpandLetsCorrectness.v +++ b/pcuic/theories/PCUICExpandLetsCorrectness.v @@ -304,8 +304,8 @@ Proof. Qed. Lemma trans_constraintSet_in x Σ: - ConstraintSet.In x (S.global_ext_constraints Σ) -> - ConstraintSet.In x (T.global_ext_constraints (trans_global Σ)). + UnivConstraintSet.In x (S.global_ext_constraints Σ) -> + UnivConstraintSet.In x (T.global_ext_constraints (trans_global Σ)). Proof. rewrite trans_global_ext_constraints. trivial. diff --git a/pcuic/theories/PCUICGlobalEnv.v b/pcuic/theories/PCUICGlobalEnv.v index 04ddceffc..db9f27c14 100644 --- a/pcuic/theories/PCUICGlobalEnv.v +++ b/pcuic/theories/PCUICGlobalEnv.v @@ -136,7 +136,7 @@ Proof. - destruct Σ as [Σ φ]. destruct HΣ as [HΣ Hφ]. destruct (wf_global_uctx_invariants _ HΣ) as [_ XX]. unfold global_ext_uctx, global_ext_levels, global_ext_constraints. - simpl. intros [[l ct] l'] Hctr. simpl in *. apply ConstraintSet.union_spec in Hctr. + simpl. intros [[l ct] l'] Hctr. simpl in *. apply UnivConstraintSet.union_spec in Hctr. destruct Hctr as [Hctr|Hctr]. + destruct Hφ as [_ [HH _]]. specialize (HH _ Hctr). cbn in HH. intuition auto using LevelSet_in_union_global. diff --git a/pcuic/theories/PCUICInductiveInversion.v b/pcuic/theories/PCUICInductiveInversion.v index fc1fadd5e..0c66b9369 100644 --- a/pcuic/theories/PCUICInductiveInversion.v +++ b/pcuic/theories/PCUICInductiveInversion.v @@ -1802,7 +1802,7 @@ Lemma variance_universes_insts {cf} {Σ mdecl l} : match ind_universes mdecl with | Monomorphic_ctx => False | Polymorphic_ctx (inst, cstrs) => - let cstrs := ConstraintSet.union (ConstraintSet.union cstrs (lift_constraints #|i| cstrs)) (variance_cstrs l i i') + let cstrs := UnivConstraintSet.union (UnivConstraintSet.union cstrs (lift_constraints #|i| cstrs)) (variance_cstrs l i i') in v = Polymorphic_ctx (inst ++ inst, cstrs) end, consistent_instance_ext (Σ.1, v) (ind_universes mdecl) i, @@ -1846,8 +1846,8 @@ Definition closedu_cstr k (cstr : (Level.t * ConstraintType.t * Level.t)) := let '(l1, p, l2) := cstr in closedu_level k l1 && closedu_level k l2. -Definition closedu_cstrs k (cstrs : CS.t) := - CS.For_all (closedu_cstr k) cstrs. +Definition closedu_cstrs k (cstrs : UCS.t) := + UCS.For_all (closedu_cstr k) cstrs. Lemma LSet_in_poly_bounded l inst cstrs : LevelSet.In l (levels_of_udecl (Polymorphic_ctx (inst, cstrs))) -> closedu_level #|inst| l. @@ -1901,7 +1901,7 @@ Qed. Lemma closedu_subst_instance_cstrs_app u u' cstrs : closedu_cstrs #|u| cstrs -> - CS.Equal (subst_instance_cstrs (u ++ u') cstrs) (subst_instance_cstrs u cstrs). + UCS.Equal (subst_instance_cstrs (u ++ u') cstrs) (subst_instance_cstrs u cstrs). Proof. intros clcstra. intros c. @@ -1924,35 +1924,35 @@ Qed. Lemma In_lift_constraints u c ctrs : - CS.In c (lift_constraints u ctrs) - <-> exists c', c = lift_constraint u c' /\ CS.In c' ctrs. + UCS.In c (lift_constraints u ctrs) + <-> exists c', c = lift_constraint u c' /\ UCS.In c' ctrs. Proof. unfold lift_constraints. - rewrite CS.fold_spec. - transitivity (CS.In c CS.empty \/ + rewrite UCS.fold_spec. + transitivity (UCS.In c UCS.empty \/ exists c', c = lift_constraint u c' - /\ In c' (CS.elements ctrs)). - - generalize (CS.elements ctrs), CS.empty. + /\ In c' (UCS.elements ctrs)). + - generalize (UCS.elements ctrs), UCS.empty. induction l; cbn. + firstorder. + intros t. etransitivity. 1: eapply IHl. split; intros [HH|HH]. - * destruct a as [[l1 a] l2]. apply CS.add_spec in HH. + * destruct a as [[l1 a] l2]. apply UCS.add_spec in HH. destruct HH as [HH|HH]. 2: now left. right; eexists. split; [|left; reflexivity]. assumption. * destruct HH as [c' ?]. right; exists c'; intuition auto. - * left. destruct a as [[l1 a] l2]. apply CS.add_spec. + * left. destruct a as [[l1 a] l2]. apply UCS.add_spec. now right. * destruct HH as [c' [HH1 [?|?]]]; subst. -- left. destruct c' as [[l1 c'] l2]; - apply CS.add_spec; now left. + apply UCS.add_spec; now left. -- right. exists c'. intuition. - rewrite ConstraintSetFact.empty_iff. transitivity (exists c', c = lift_constraint u c' - /\ In c' (CS.elements ctrs)). + /\ In c' (UCS.elements ctrs)). 1: intuition. apply iff_ex; intro. apply and_iff_compat_l. symmetry. - etransitivity. 1: symmetry; eapply CS.elements_spec1. + etransitivity. 1: symmetry; eapply UCS.elements_spec1. etransitivity. 1: eapply SetoidList.InA_alt. split; intro; eauto. now destruct H as [? [[] ?]]. @@ -1961,7 +1961,7 @@ Qed. Lemma closedu_subst_instance_cstrs_lift u u' cstrs : closedu_cstrs #|u'| cstrs -> - CS.Equal (subst_instance_cstrs (u ++ u') (lift_constraints #|u| cstrs)) (subst_instance_cstrs u' cstrs). + UCS.Equal (subst_instance_cstrs (u ++ u') (lift_constraints #|u| cstrs)) (subst_instance_cstrs u' cstrs). Proof. intros clcstra. intros c. @@ -1989,8 +1989,8 @@ Proof. Qed. Lemma subst_instance_cstrs_add u x c : - CS.Equal (subst_instance_cstrs u (ConstraintSet.add x c)) - (ConstraintSet.add (subst_instance_cstr u x) (subst_instance_cstrs u c)). + UCS.Equal (subst_instance_cstrs u (UnivConstraintSet.add x c)) + (UnivConstraintSet.add (subst_instance_cstr u x) (subst_instance_cstrs u c)). Proof. intros cc. rewrite ConstraintSetFact.add_iff. @@ -2009,7 +2009,7 @@ Proof. Qed. Lemma subst_instance_variance_cstrs l u i i' : - CS.Equal (subst_instance_cstrs u (variance_cstrs l i i')) + UCS.Equal (subst_instance_cstrs u (variance_cstrs l i i')) (variance_cstrs l (subst_instance u i) (subst_instance u i')). Proof. induction l in u, i, i' |- *; simpl; auto; @@ -2086,14 +2086,14 @@ Proof. len in len1. intuition auto. - rewrite -satisfies_subst_instance_ctr //. - assert(ConstraintSet.Equal (subst_instance_cstrs u' cstrs') + assert(UnivConstraintSet.Equal (subst_instance_cstrs u' cstrs') (subst_instance_cstrs (u' ++ u) cstrs')) as <-. { rewrite closedu_subst_instance_cstrs_app //. rewrite (consistent_instance_poly_length cu'). eapply on_udecl_prop_poly_bounded; eauto. } eapply consistent_instance_valid in cu'; eauto. - rewrite -satisfies_subst_instance_ctr // -H0. - assert(ConstraintSet.Equal (subst_instance_cstrs u cstrs') + assert(UnivConstraintSet.Equal (subst_instance_cstrs u cstrs') (subst_instance_cstrs (u' ++ u) (lift_constraints #|u'| cstrs'))) as <-. { rewrite closedu_subst_instance_cstrs_lift //. rewrite H -H0 (consistent_instance_poly_length cu'). diff --git a/pcuic/theories/PCUICSubstitution.v b/pcuic/theories/PCUICSubstitution.v index 09991947d..9d0c87243 100644 --- a/pcuic/theories/PCUICSubstitution.v +++ b/pcuic/theories/PCUICSubstitution.v @@ -1202,7 +1202,7 @@ Proof. rewrite -{3}H. now rewrite simpl_subst_k. Qed. -Lemma subst_compare_term {cf:checker_flags} Σ (φ : ConstraintSet.t) pb (l : list term) (k : nat) (T U : term) : +Lemma subst_compare_term {cf:checker_flags} Σ (φ : UnivConstraintSet.t) pb (l : list term) (k : nat) (T U : term) : compare_term Σ φ pb T U -> compare_term Σ φ pb (subst l k T) (subst l k U). Proof. destruct pb; simpl. diff --git a/pcuic/theories/PCUICUnivLevels.v b/pcuic/theories/PCUICUnivLevels.v index a13f96b96..0fb5d14e2 100644 --- a/pcuic/theories/PCUICUnivLevels.v +++ b/pcuic/theories/PCUICUnivLevels.v @@ -3,12 +3,12 @@ Definition fresh_levels global_levels levels := LevelSet.For_all (fun l => ~ LevelSet.In l global_levels) levels. Definition declared_constraints_levels levels cstrs := - ConstraintSet.For_all (declared_cstr_levels levels) cstrs. + UnivConstraintSet.For_all (declared_univ_cstr_levels levels) cstrs. Definition declared_constraints_levels_union levels cstrs cstrs' : declared_constraints_levels levels cstrs -> declared_constraints_levels levels cstrs' -> - declared_constraints_levels levels (ConstraintSet.union cstrs cstrs'). + declared_constraints_levels levels (UnivConstraintSet.union cstrs cstrs'). Proof. intros decl decl'. rewrite /declared_constraints_levels. @@ -197,20 +197,20 @@ Definition fresh_levels global_levels levels := + right. apply not_var_lift => //. Qed. - Definition levels_of_cstr (c : ConstraintSet.elt) := + Definition levels_of_cstr (c : UnivConstraintSet.elt) := let '(l, d, r) := c in LevelSet.add l (LevelSet.add r LevelSet.empty). Definition levels_of_cstrs cstrs := - ConstraintSet.fold (fun c acc => LevelSet.union (levels_of_cstr c) acc) cstrs. + UnivConstraintSet.fold (fun c acc => LevelSet.union (levels_of_cstr c) acc) cstrs. Lemma levels_of_cstrs_acc l cstrs acc : LevelSet.In l acc \/ LevelSet.In l (levels_of_cstrs cstrs LevelSet.empty) <-> LevelSet.In l (levels_of_cstrs cstrs acc). Proof. rewrite /levels_of_cstrs. - rewrite !ConstraintSet.fold_spec. - induction (ConstraintSet.elements cstrs) in acc |- * => /=. + rewrite !UnivConstraintSet.fold_spec. + induction (UnivConstraintSet.elements cstrs) in acc |- * => /=. split. intros []; auto. inversion H. firstorder. split. intros []. apply IHl0. left. now eapply LevelSetFact.union_3. @@ -227,7 +227,7 @@ Definition fresh_levels global_levels levels := Lemma levels_of_cstrs_spec l cstrs : LevelSet.In l (levels_of_cstrs cstrs LevelSet.empty) <-> - exists d r, ConstraintSet.In (l, d, r) cstrs \/ ConstraintSet.In (r, d, l) cstrs. + exists d r, UnivConstraintSet.In (l, d, r) cstrs \/ UnivConstraintSet.In (r, d, l) cstrs. Proof. rewrite -levels_of_cstrs_acc. split. @@ -278,15 +278,15 @@ Definition fresh_levels global_levels levels := Qed. Lemma In_variance_cstrs l d r v i i' : - ConstraintSet.In (l, d, r) (variance_cstrs v i i') -> + UnivConstraintSet.In (l, d, r) (variance_cstrs v i i') -> (In l i \/ In l i') /\ (In r i \/ In r i'). Proof. induction v in i, i' |- *; destruct i, i'; intros; try solve [inversion H]. cbn in H. destruct a. apply IHv in H. cbn. firstorder auto. - eapply ConstraintSet.add_spec in H as []. noconf H. cbn; firstorder. + eapply UnivConstraintSet.add_spec in H as []. noconf H. cbn; firstorder. eapply IHv in H; firstorder. - eapply ConstraintSet.add_spec in H as []. noconf H. cbn; firstorder. + eapply UnivConstraintSet.add_spec in H as []. noconf H. cbn; firstorder. eapply IHv in H; firstorder. Qed. diff --git a/pcuic/theories/PCUICWeakeningEnv.v b/pcuic/theories/PCUICWeakeningEnv.v index 19fa4f1aa..4133507ba 100644 --- a/pcuic/theories/PCUICWeakeningEnv.v +++ b/pcuic/theories/PCUICWeakeningEnv.v @@ -11,13 +11,13 @@ Set Default Goal Selector "!". Implicit Types (cf : checker_flags). Lemma global_ext_constraints_app Σ Σ' φ - : ConstraintSet.Subset (universes Σ).2 (universes Σ').2 -> - ConstraintSet.Subset (global_ext_constraints (Σ, φ)) + : UnivConstraintSet.Subset (universes Σ).2 (universes Σ').2 -> + UnivConstraintSet.Subset (global_ext_constraints (Σ, φ)) (global_ext_constraints (Σ', φ)). Proof. unfold global_ext_constraints; simpl. - intros sub ctr Hc. apply ConstraintSet.union_spec in Hc. - apply ConstraintSet.union_spec. + intros sub ctr Hc. apply UnivConstraintSet.union_spec in Hc. + apply UnivConstraintSet.union_spec. destruct Hc as [Hc|Hc]; [now left|right]. clear φ. unfold global_constraints in Hc. apply (sub _ Hc). @@ -60,7 +60,7 @@ Proof. Qed. Lemma weakening_env_global_ext_constraints Σ Σ' φ (H : extends Σ Σ') - : ConstraintSet.Subset (global_ext_constraints (Σ, φ)) + : UnivConstraintSet.Subset (global_ext_constraints (Σ, φ)) (global_ext_constraints (Σ', φ)). Proof. destruct H as [sub _]. @@ -216,11 +216,11 @@ Definition on_udecl_prop (Σ : global_env) (udecl : universes_decl) := let levels := levels_of_udecl udecl in let global_levels := global_levels Σ.(universes) in let all_levels := LevelSet.union levels global_levels in - ConstraintSet.For_all (declared_cstr_levels all_levels) (constraints_of_udecl udecl). + UnivConstraintSet.For_all (declared_univ_cstr_levels all_levels) (constraints_of_udecl udecl). (* /\ match udecl with | Monomorphic_ctx ctx => LevelSet.for_all (negb ∘ Level.is_var) ctx.1 /\ LevelSet.Subset ctx.1 global_levels - /\ ConstraintSet.Subset ctx.2 (global_constraints Σ) + /\ UnivConstraintSet.Subset ctx.2 (global_constraints Σ) /\ satisfiable_udecl Σ.(universes) udecl | _ => True end. *) @@ -234,9 +234,9 @@ Qed. Lemma declared_cstr_levels_sub l l' c : LevelSet.Subset l l' -> - declared_cstr_levels l c -> declared_cstr_levels l' c. + declared_univ_cstr_levels l c -> declared_univ_cstr_levels l' c. Proof. - intros sub; unfold declared_cstr_levels. + intros sub; unfold declared_univ_cstr_levels. destruct c as [[l1 eq] l2]. intuition auto. Qed. @@ -398,18 +398,18 @@ Proof using P Pcmp cf. -- clear -eq. destruct d as [c|c]; cbn in *. all: destruct c; cbn in *; now rewrite eq. * simpl. replace (monomorphic_constraints_decl d) with ctx.2. - -- intros c Hc; apply ConstraintSet.union_spec; now left. + -- intros c Hc; apply UnivConstraintSet.union_spec; now left. -- clear -eq. destruct d as [c|c]; cbn in *. all: destruct c; cbn in *; now rewrite eq. * clear -eq H4. destruct H4 as [v Hv]. exists v. intros c Hc; apply (Hv c). - apply ConstraintSet.union_spec in Hc; destruct Hc as [Hc|Hc]. - 2: apply ConstraintSet.union_spec in Hc; destruct Hc as [Hc|Hc]. - -- apply ConstraintSet.union_spec. simpl in *. left; now rewrite eq. - -- apply ConstraintSet.union_spec; left. simpl. + apply UnivConstraintSet.union_spec in Hc; destruct Hc as [Hc|Hc]. + 2: apply UnivConstraintSet.union_spec in Hc; destruct Hc as [Hc|Hc]. + -- apply UnivConstraintSet.union_spec. simpl in *. left; now rewrite eq. + -- apply UnivConstraintSet.union_spec; left. simpl. destruct d as [[? ? []]|[? ? ? ? []]]; simpl in *; tas; - now apply ConstraintSet.empty_spec in Hc. - -- apply ConstraintSet.union_spec; now right.*) + now apply UnivConstraintSet.empty_spec in Hc. + -- apply UnivConstraintSet.union_spec; now right.*) - specialize (IHwfΣ HH). revert IHwfΣ o; clear. generalize (universes_decl_of_decl decl); intros d' HH Hd. unfold on_udecl_prop in *. @@ -425,17 +425,17 @@ Proof using P Pcmp cf. * intros l Hl. apply H2 in Hl. apply LevelSet.union_spec; now right. * intros c Hc. apply H2 in Hc. - apply ConstraintSet.union_spec; now right. + apply UnivConstraintSet.union_spec; now right. * destruct Hd as [_ [_ [_ Hd]]]; cbn in Hd. destruct Hd as [v Hv]. exists v. intros c Hc; apply Hv; clear v Hv. - apply ConstraintSet.union_spec in Hc; destruct Hc as [Hc|Hc]; simpl in *. - 2: apply ConstraintSet.union_spec in Hc; destruct Hc as [Hc|Hc]; + apply UnivConstraintSet.union_spec in Hc; destruct Hc as [Hc|Hc]; simpl in *. + 2: apply UnivConstraintSet.union_spec in Hc; destruct Hc as [Hc|Hc]; simpl in *. - -- apply H2 in Hc. apply ConstraintSet.union_spec; now right. + -- apply H2 in Hc. apply UnivConstraintSet.union_spec; now right. -- clear -Hc. destruct d as [[? ? []]|[? ? ? ? []]]; cbn in *. - all: try (apply ConstraintSet.empty_spec in Hc; contradiction). - all: apply ConstraintSet.union_spec; now left. - -- apply ConstraintSet.union_spec; now right.*) + all: try (apply UnivConstraintSet.empty_spec in Hc; contradiction). + all: apply UnivConstraintSet.union_spec; now left. + -- apply UnivConstraintSet.union_spec; now right.*) Qed. diff --git a/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v b/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v index 9b74bfd94..5065e6250 100644 --- a/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v +++ b/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v @@ -210,7 +210,7 @@ Qed. Hint Resolve subst_instance_cstrs_two satisfies_equal_sets satisfies_subsets : univ_subst. Hint Resolve monomorphic_global_constraint monomorphic_global_constraint_ext : univ_subst. -Hint Unfold CS.For_all : univ_subst. +Hint Unfold UCS.For_all : univ_subst. Hint Resolve consistent_ext_trans : univ_subst. Hint Resolve consistent_instance_valid_constraints : univ_subst. Hint Rewrite subst_instance_extended_subst : substu. diff --git a/quotation/theories/ToPCUIC/Common/Universes.v b/quotation/theories/ToPCUIC/Common/Universes.v index d12097a97..418fcff0d 100644 --- a/quotation/theories/ToPCUIC/Common/Universes.v +++ b/quotation/theories/ToPCUIC/Common/Universes.v @@ -18,7 +18,7 @@ Export (hints) QuoteLevelSet. Module QuoteLevelExprSet := MSets.QuoteMSetListWithLeibniz LevelExpr LevelExprSet LevelExprSetOrdProp LevelExprSetExtraOrdProp qLevelExpr qLevelExprSet qLevelExprSetOrdProp qLevelExprSetExtraOrdProp. Export (hints) QuoteLevelExprSet. Module QuoteConstraintSet := MSets.QuoteMSetAVL UnivConstraint ConstraintSet ConstraintSetOrdProp ConstraintSetExtraOrdProp ConstraintSetExtraDecide qUnivConstraint qConstraintSet qConstraintSetOrdProp qConstraintSetExtraOrdProp qConstraintSetExtraDecide. -Export (hints) QuoteConstraintSet. +Export (hints) QuoteUnivConstraintSet. Module QuoteUniverses1. Module Import Level. @@ -103,7 +103,7 @@ Module QuoteUniverses2. #[export] Hint Unfold UnivConstraint.t : quotation. #[export] Typeclasses Transparent UnivConstraint.t. #[export] Instance quote_lt_ {x y} : ground_quotable (UnivConstraint.lt_ x y) - := ground_quotable_of_dec (@ConstraintSet.Raw.MX.lt_dec x y). + := ground_quotable_of_dec (@UnivConstraintSet.Raw.MX.lt_dec x y). #[export] Hint Unfold UnivConstraint.lt : quotation. End UnivConstraint. Export (hints) UnivConstraint. @@ -123,7 +123,7 @@ Import StrongerInstances. #[export] Instance quote_allowed_eliminations : ground_quotable allowed_eliminations := ltac:(destruct 1; exact _). -#[export] Instance quote_declared_cstr_levels {levels cstr} : ground_quotable (declared_cstr_levels levels cstr) := ltac:(cbv [declared_cstr_levels]; exact _). +#[export] Instance quote_declared_cstr_levels {levels cstr} : ground_quotable (declared_univ_cstr_levels levels cstr) := ltac:(cbv [declared_univ_cstr_levels]; exact _). #[export] Instance quote_universes_decl : ground_quotable universes_decl := ltac:(destruct 1; exact _). #[export] Instance quote_satisfies0 {v s} {qv : quotation_of v} : ground_quotable (@satisfies0 v s) := ground_quotable_of_iff (iff_sym (@uGraph.gc_of_constraint_spec config.default_checker_flags v s)). diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSet/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSet/Instances.v index 10199900c..eef5f7f90 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSet/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSet/Instances.v @@ -2,6 +2,6 @@ From MetaRocq.Common Require Import Universes. From MetaRocq.Quotation.ToPCUIC Require Import Init. From MetaRocq.Quotation.ToPCUIC.QuotationOf.Stdlib.MSets Require Import MSetAVL.Sig. -Module qConstraintSet <: MSetAVL.QuotationOfMake UnivConstraint ConstraintSet. +Module qConstraintSet <: MSetAVL.QuotationOfMake UnivConstraint UnivConstraintSet. MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSet"). -End qConstraintSet. +End qUnivConstraintSet. diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v index 685944dba..b9ce4c2a0 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v @@ -2,6 +2,6 @@ From MetaRocq.Common Require Import Universes. From MetaRocq.Quotation.ToPCUIC Require Import Init. From MetaRocq.Quotation.ToPCUIC.QuotationOf.Utils Require Import MRMSets.Sig. -Module qConstraintSetExtraDecide <: MSetAVL.QuotationOfDecide ConstraintSet.E ConstraintSet ConstraintSetExtraDecide. +Module qConstraintSetExtraDecide <: MSetAVL.QuotationOfDecide UnivConstraintSet.E ConstraintSet ConstraintSetExtraDecide. MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetExtraDecide"). End qConstraintSetExtraDecide. diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v index 748f13b1e..5e60770e2 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v @@ -5,7 +5,7 @@ Import List.ListNotations. Local Open Scope list_scope. Module qConstraintSetExtraOrdProp <: QuotationOfExtraOrdProperties ConstraintSet ConstraintSetOrdProp ConstraintSetExtraOrdProp. - Module qP <: QuotationOfWExtraPropertiesOn ConstraintSet.E ConstraintSet ConstraintSetOrdProp.P ConstraintSetExtraOrdProp.P. + Module qP <: QuotationOfWExtraPropertiesOn UnivConstraintSet.E ConstraintSet ConstraintSetOrdProp.P ConstraintSetExtraOrdProp.P. MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetExtraOrdProp.P"). End qP. MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["P"]]%bs) None "ConstraintSetExtraOrdProp"). diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v index abd0c2823..cd00e5c4b 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v @@ -6,7 +6,7 @@ Import List.ListNotations. Local Open Scope list_scope. Module qConstraintSetOrdProp <: QuotationOfOrdProperties ConstraintSet ConstraintSetOrdProp. - Module qME <: QuotationOfOrderedTypeFacts ConstraintSet.E ConstraintSetOrdProp.ME. + Module qME <: QuotationOfOrderedTypeFacts UnivConstraintSet.E ConstraintSetOrdProp.ME. MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetOrdProp.ME"). End qME. Module qML. (* OrderedTypeLists(M.E). *) diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/Instances.v index ee6003a06..89d08b540 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/Instances.v @@ -10,7 +10,7 @@ From MetaRocq.Quotation.ToPCUIC.QuotationOf.Common.Universes Require Export LevelExprSetOrdProp.Instances LevelExprSetExtraOrdProp.Instances UnivConstraint.Instances - ConstraintSet.Instances + UnivConstraintSet.Instances ConstraintSetOrdProp.Instances ConstraintSetExtraOrdProp.Instances ConstraintSetExtraDecide.Instances diff --git a/quotation/theories/ToTemplate/Common/Universes.v b/quotation/theories/ToTemplate/Common/Universes.v index eeacee94b..deff4ef80 100644 --- a/quotation/theories/ToTemplate/Common/Universes.v +++ b/quotation/theories/ToTemplate/Common/Universes.v @@ -18,7 +18,7 @@ Export (hints) QuoteLevelSet. Module QuoteLevelExprSet := MSets.QuoteMSetListWithLeibniz LevelExpr LevelExprSet LevelExprSetOrdProp LevelExprSetExtraOrdProp qLevelExpr qLevelExprSet qLevelExprSetOrdProp qLevelExprSetExtraOrdProp. Export (hints) QuoteLevelExprSet. Module QuoteConstraintSet := MSets.QuoteMSetAVL UnivConstraint ConstraintSet ConstraintSetOrdProp ConstraintSetExtraOrdProp ConstraintSetExtraDecide qUnivConstraint qConstraintSet qConstraintSetOrdProp qConstraintSetExtraOrdProp qConstraintSetExtraDecide. -Export (hints) QuoteConstraintSet. +Export (hints) QuoteUnivConstraintSet. Module QuoteUniverses1. Module Import Level. @@ -103,7 +103,7 @@ Module QuoteUniverses2. #[export] Hint Unfold UnivConstraint.t : quotation. #[export] Typeclasses Transparent UnivConstraint.t. #[export] Instance quote_lt_ {x y} : ground_quotable (UnivConstraint.lt_ x y) - := ground_quotable_of_dec (@ConstraintSet.Raw.MX.lt_dec x y). + := ground_quotable_of_dec (@UnivConstraintSet.Raw.MX.lt_dec x y). #[export] Hint Unfold UnivConstraint.lt : quotation. End UnivConstraint. Export (hints) UnivConstraint. @@ -123,7 +123,7 @@ Import StrongerInstances. #[export] Instance quote_allowed_eliminations : ground_quotable allowed_eliminations := ltac:(destruct 1; exact _). -#[export] Instance quote_declared_cstr_levels {levels cstr} : ground_quotable (declared_cstr_levels levels cstr) := ltac:(cbv [declared_cstr_levels]; exact _). +#[export] Instance quote_declared_cstr_levels {levels cstr} : ground_quotable (declared_univ_cstr_levels levels cstr) := ltac:(cbv [declared_univ_cstr_levels]; exact _). #[export] Instance quote_universes_decl : ground_quotable universes_decl := ltac:(destruct 1; exact _). #[export] Instance quote_satisfies0 {v s} {qv : quotation_of v} : ground_quotable (@satisfies0 v s) := ground_quotable_of_iff (iff_sym (@uGraph.gc_of_constraint_spec config.default_checker_flags v s)). diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v index 760597d3e..96557073f 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v @@ -2,6 +2,6 @@ From MetaRocq.Common Require Import Universes. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Stdlib.MSets Require Import MSetAVL.Sig. -Module qConstraintSet <: MSetAVL.QuotationOfMake UnivConstraint ConstraintSet. +Module qConstraintSet <: MSetAVL.QuotationOfMake UnivConstraint UnivConstraintSet. MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSet"). -End qConstraintSet. +End qUnivConstraintSet. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v index 4776ece70..140938120 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v @@ -2,6 +2,6 @@ From MetaRocq.Common Require Import Universes. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Utils Require Import MRMSets.Sig. -Module qConstraintSetExtraDecide <: MSetAVL.QuotationOfDecide ConstraintSet.E ConstraintSet ConstraintSetExtraDecide. +Module qConstraintSetExtraDecide <: MSetAVL.QuotationOfDecide UnivConstraintSet.E ConstraintSet ConstraintSetExtraDecide. MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetExtraDecide"). End qConstraintSetExtraDecide. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v index a1edda3eb..35eecfe3f 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v @@ -5,7 +5,7 @@ Import List.ListNotations. Local Open Scope list_scope. Module qConstraintSetExtraOrdProp <: QuotationOfExtraOrdProperties ConstraintSet ConstraintSetOrdProp ConstraintSetExtraOrdProp. - Module qP <: QuotationOfWExtraPropertiesOn ConstraintSet.E ConstraintSet ConstraintSetOrdProp.P ConstraintSetExtraOrdProp.P. + Module qP <: QuotationOfWExtraPropertiesOn UnivConstraintSet.E ConstraintSet ConstraintSetOrdProp.P ConstraintSetExtraOrdProp.P. MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetExtraOrdProp.P"). End qP. MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["P"]]%bs) None "ConstraintSetExtraOrdProp"). diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v index fdff67498..d3412374d 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v @@ -6,7 +6,7 @@ Import List.ListNotations. Local Open Scope list_scope. Module qConstraintSetOrdProp <: QuotationOfOrdProperties ConstraintSet ConstraintSetOrdProp. - Module qME <: QuotationOfOrderedTypeFacts ConstraintSet.E ConstraintSetOrdProp.ME. + Module qME <: QuotationOfOrderedTypeFacts UnivConstraintSet.E ConstraintSetOrdProp.ME. MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetOrdProp.ME"). End qME. Module qML. (* OrderedTypeLists(M.E). *) diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/Instances.v index 15151968c..53e1d603b 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/Instances.v @@ -10,7 +10,7 @@ From MetaRocq.Quotation.ToTemplate.QuotationOf.Common.Universes Require Export LevelExprSetOrdProp.Instances LevelExprSetExtraOrdProp.Instances UnivConstraint.Instances - ConstraintSet.Instances + UnivConstraintSet.Instances ConstraintSetOrdProp.Instances ConstraintSetExtraOrdProp.Instances ConstraintSetExtraDecide.Instances diff --git a/safechecker/theories/PCUICEqualityDec.v b/safechecker/theories/PCUICEqualityDec.v index 2c6f1ff58..e7e171dd8 100644 --- a/safechecker/theories/PCUICEqualityDec.v +++ b/safechecker/theories/PCUICEqualityDec.v @@ -865,7 +865,7 @@ Section EqualityDecGen. Let HG := (graph_of_wf_ext hΣ).π2. - Let uctx' : VSet.t × GoodConstraintSet.t. + Let uctx' : VSet.t × GoodUnivConstraintSet.t. fold G uctx in HG. clearbody G HG. cbn in *. unfold is_graph_of_uctx, gc_of_uctx in HG. destruct (gc_of_constraints uctx.2) as [ctrs|]. diff --git a/safechecker/theories/PCUICErrors.v b/safechecker/theories/PCUICErrors.v index da75609b2..3835ab166 100644 --- a/safechecker/theories/PCUICErrors.v +++ b/safechecker/theories/PCUICErrors.v @@ -156,7 +156,7 @@ Inductive type_error := | NotAnInductive (t : term) | NotAnArity (t : term) | IllFormedFix (m : mfixpoint term) (i : nat) -| UnsatisfiedConstraints (c : ConstraintSet.t) +| UnsatisfiedConstraints (c : UnivConstraintSet.t) | Msg (s : string). Derive NoConfusion for type_error. diff --git a/safechecker/theories/PCUICSafeChecker.v b/safechecker/theories/PCUICSafeChecker.v index da107c59a..02b5fa3a7 100644 --- a/safechecker/theories/PCUICSafeChecker.v +++ b/safechecker/theories/PCUICSafeChecker.v @@ -52,10 +52,10 @@ Qed. Definition cs_equal (x y : ContextSet.t) : Prop := - LevelSet.Equal x.1 y.1 /\ ConstraintSet.Equal x.2 y.2. + LevelSet.Equal x.1 y.1 /\ UnivConstraintSet.Equal x.2 y.2. Definition gcs_equal x y : Prop := - LevelSet.Equal x.1 y.1 /\ GoodConstraintSet.Equal x.2 y.2. + LevelSet.Equal x.1 y.1 /\ GoodUnivConstraintSet.Equal x.2 y.2. Require Import Relation_Definitions. Definition R_opt {A} (R : relation A) : relation (option A) := @@ -65,7 +65,7 @@ Definition gcs_equal x y : Prop := | _, _ => False end. - Global Instance gc_of_constraints_proper {cf} : Proper (ConstraintSet.Equal ==> R_opt GoodConstraintSet.Equal) gc_of_constraints. + Global Instance gc_of_constraints_proper {cf} : Proper (UnivConstraintSet.Equal ==> R_opt GoodUnivConstraintSet.Equal) gc_of_constraints. Proof. intros c c' eqc; cbn. destruct (gc_of_constraintsP c); @@ -202,7 +202,7 @@ Section OnUdecl. intros wfctx wfext. unfold variance_universes. destruct ctx as [|[inst cstrs]] => //. intros [= eq]. - set (vcstrs := ConstraintSet.union _ _) in *. + set (vcstrs := UnivConstraintSet.union _ _) in *. subst univs. simpl. subst u u'. autorewrite with len. repeat (split; auto). @@ -221,8 +221,8 @@ Section OnUdecl. intro. red in vsat. specialize (vsat x). intros hin. apply vsat. unfold global_ext_constraints. simpl. - rewrite ConstraintSet.union_spec; left. - rewrite /vcstrs !ConstraintSet.union_spec. + rewrite UnivConstraintSet.union_spec; left. + rewrite /vcstrs !UnivConstraintSet.union_spec. left. right. rewrite In_lift_constraints. rewrite -> In_subst_instance_cstrs in hin. @@ -250,8 +250,8 @@ Section OnUdecl. intro. red in vsat. specialize (vsat x). intros hin. apply vsat. unfold global_ext_constraints. simpl. - rewrite ConstraintSet.union_spec; left. - rewrite /vcstrs !ConstraintSet.union_spec. + rewrite UnivConstraintSet.union_spec; left. + rewrite /vcstrs !UnivConstraintSet.union_spec. left. left. rewrite -> In_subst_instance_cstrs in hin. destruct hin as [c' [eqx inc']]. clear vsat. @@ -338,7 +338,7 @@ Section CheckEnv. let levels := levels_of_udecl udecl in check_eq_true_lazy (LevelSet.for_all (fun l => Level.is_var l) levels) (fun _ => (abstract_env_empty_ext X, IllFormedDecl id (Msg ("non fresh level in " ^ print_lset levels))));; - check_eq_true_lazy (ConstraintSet.for_all (fun '(l1, _, l2) => abstract_env_level_mem' (abstract_env_empty_ext X) levels l1 && abstract_env_level_mem' (abstract_env_empty_ext X) levels l2) (constraints_of_udecl udecl)) + check_eq_true_lazy (UnivConstraintSet.for_all (fun '(l1, _, l2) => abstract_env_level_mem' (abstract_env_empty_ext X) levels l1 && abstract_env_level_mem' (abstract_env_empty_ext X) levels l2) (constraints_of_udecl udecl)) (fun _ => (abstract_env_empty_ext X, IllFormedDecl id (Msg ("non declared level in " ^ print_lset levels ^ " |= " ^ print_constraint_set (constraints_of_udecl udecl)))));; match gc_of_uctx (uctx_of_udecl udecl) as X' return (X' = _ -> EnvCheck X_env_ext_type _) with @@ -354,11 +354,11 @@ Section CheckEnv. rewrite <- Huctx. split; auto. intros Σ wfΣ. - assert (HH: ConstraintSet.For_all - (declared_cstr_levels (LS.union (levels_of_udecl udecl) (global_levels Σ))) + assert (HH: UnivConstraintSet.For_all + (declared_univ_cstr_levels (LS.union (levels_of_udecl udecl) (global_levels Σ))) (constraints_of_udecl udecl)). { - clear -H0 wfΣ. apply ConstraintSet.for_all_spec in H0. + clear -H0 wfΣ. apply UnivConstraintSet.for_all_spec in H0. 2: now intros x y []. intros [[l ct] l'] Hl. specialize (H0 _ Hl). simpl in H0. apply andb_true_iff in H0. destruct H0 as [H H0]. @@ -1401,7 +1401,7 @@ Section CheckEnv. Proof using Type. split; simpl. intros x hin. now eapply LS.empty_spec in hin. - intros x hin. now eapply CS.empty_spec in hin. + intros x hin. now eapply UCS.empty_spec in hin. Qed. Lemma cumul_ctx_rel_close' Σ Γ Δ Δ' : @@ -2283,7 +2283,7 @@ End monad_Alli_nth_forall. (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("Set not in the global levels " ^ print_lset levels))));; check_eq_true_lazy (LevelSet.for_all (fun l => negb (Level.is_var l)) levels) (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("variable level in the global levels " ^ print_lset levels))));; - check_eq_true_lazy (ConstraintSet.for_all (fun c => LevelSet.mem c.1.1 levels && LevelSet.mem c.2 levels) (ContextSet.constraints univs)) + check_eq_true_lazy (UnivConstraintSet.for_all (fun c => LevelSet.mem c.1.1 levels && LevelSet.mem c.2 levels) (ContextSet.constraints univs)) (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("non declared level in " ^ print_lset levels ^ " |= " ^ print_constraint_set (ContextSet.constraints univs)))));; match gc_of_uctx univs as X' return (X' = _ -> EnvCheck X_env_ext_type _) with @@ -2293,8 +2293,8 @@ End monad_Alli_nth_forall. ret (let Hunivs := _ in exist (abstract_env_init univs retro Hunivs) _) end eq_refl . Next Obligation. intros. have decll : - ConstraintSet.For_all (declared_cstr_levels (ContextSet.levels univs)) (ContextSet.constraints univs). - { clear -i1. apply ConstraintSet.for_all_spec in i1. + UnivConstraintSet.For_all (declared_univ_cstr_levels (ContextSet.levels univs)) (ContextSet.constraints univs). + { clear -i1. apply UnivConstraintSet.for_all_spec in i1. 2: now intros x y []. intros [[l ct] l'] Hl. specialize (i1 _ Hl). simpl in i1. apply andb_true_iff in i1. destruct i1 as [H H1]. @@ -2302,7 +2302,7 @@ End monad_Alli_nth_forall. now split. } intros. split; eauto. { intros l Hl. specialize (decll l Hl). red. destruct l, p. now rewrite levels_global_levels_declared. } - split; eauto. unfold declared_cstr_levels. cbn. + split; eauto. unfold declared_univ_cstr_levels. cbn. repeat split => //. + clear - i i0. apply LevelSet.for_all_spec in i0. 2: now intros x y []. @@ -2313,7 +2313,7 @@ End monad_Alli_nth_forall. intros Σctrs HΣctrs. unfold abstract_env_is_consistent_empty in i2. pose proof (abs_init := abstract_env_init_correct (abstract_env_impl := X_env_type) - (LS.singleton Level.lzero, CS.empty) Retroknowledge.empty PCUICWfEnv.abstract_env_empty_obligation_1). + (LS.singleton Level.lzero, UCS.empty) Retroknowledge.empty PCUICWfEnv.abstract_env_empty_obligation_1). pose proof (abs_consist := abstract_env_is_consistent_correct (@abstract_env_empty cf X_impl) _ uctx univs abs_init); cbn in *. rewrite HΣctrs in abs_consist, Huctx. pose (abstract_env_wf _ abs_init). sq. diff --git a/safechecker/theories/PCUICSafeConversion.v b/safechecker/theories/PCUICSafeConversion.v index 78239f413..558b35f8c 100644 --- a/safechecker/theories/PCUICSafeConversion.v +++ b/safechecker/theories/PCUICSafeConversion.v @@ -6221,7 +6221,7 @@ match referenced_impl_env_ext := ({| universes := - (LevelSet.add Level.lzero LevelSet.empty, ConstraintSet.empty); + (LevelSet.add Level.lzero LevelSet.empty, UnivConstraintSet.empty); declarations := [] |}, Monomorphic_ctx); referenced_impl_ext_wf := TODO "foo" diff --git a/safechecker/theories/PCUICTypeChecker.v b/safechecker/theories/PCUICTypeChecker.v index 7dffaa960..6a1338403 100644 --- a/safechecker/theories/PCUICTypeChecker.v +++ b/safechecker/theories/PCUICTypeChecker.v @@ -59,7 +59,7 @@ Proof. intros [[l ct] l'] Hctr. rewrite /subst_instance_cstrs /= in Hctr. rewrite ConstraintSetProp.fold_spec_right in Hctr. - set cstrs' := (List.rev (CS.elements cstrs)) in Hctr. + set cstrs' := (List.rev (UCS.elements cstrs)) in Hctr. set Σ'' := (Σ.1,Polymorphic_ctx (inst, cstrs)) in Hcs. assert ((exists ct' l'', SetoidList.InA eq (l,ct',l'') cstrs') -> declared l (global_ext_levels Σ'')) as Hcs'. @@ -67,7 +67,7 @@ Proof. intros [ct' [l'' in']]. specialize (Hcs (l,ct',l'')). apply Hcs. - eapply ConstraintSet.union_spec. left. + eapply UnivConstraintSet.union_spec. left. now apply ConstraintSetFact.elements_2, SetoidList.InA_rev. } assert ((exists ct' l'', SetoidList.InA eq (l'',ct',l') cstrs') -> @@ -76,13 +76,13 @@ Proof. intros [ct' [l'' in']]. specialize (Hcs (l'',ct',l')). apply Hcs. - eapply ConstraintSet.union_spec. left. + eapply UnivConstraintSet.union_spec. left. now apply ConstraintSetFact.elements_2, SetoidList.InA_rev. } clear Hcs. induction cstrs' ; cbn in Hctr. + now apply ConstraintSetFact.empty_iff in Hctr. - + apply CS.add_spec in Hctr as []. + + apply UCS.add_spec in Hctr as []. 2:{ apply IHcstrs' ; tea. all: intros [? []]. @@ -153,7 +153,7 @@ Proof. - eapply LevelSet.union_spec. right. apply Hs. - intros x hx. cbn in hx. unfold global_ext_constraints in hx. - eapply ConstraintSet.union_spec in hx. + eapply UnivConstraintSet.union_spec in hx. destruct hx. cbn in H. * now apply ond. * specialize (Hc x H). diff --git a/safechecker/theories/PCUICWfEnv.v b/safechecker/theories/PCUICWfEnv.v index 1131b2d08..c9b54ad8a 100644 --- a/safechecker/theories/PCUICWfEnv.v +++ b/safechecker/theories/PCUICWfEnv.v @@ -38,7 +38,7 @@ Class abstract_env_struct {cf:checker_flags} (abstract_env_impl abstract_env_ext abstract_env_level_mem : abstract_env_ext_impl -> Level.t -> bool; abstract_env_leqb_level_n : abstract_env_ext_impl -> Z -> Level.t -> Level.t -> bool; abstract_env_guard : abstract_env_ext_impl -> FixCoFix -> context -> mfixpoint term -> bool; - abstract_env_is_consistent : abstract_env_impl -> LevelSet.t * GoodConstraintSet.t -> bool ; + abstract_env_is_consistent : abstract_env_impl -> LevelSet.t * GoodUnivConstraintSet.t -> bool ; }. @@ -57,7 +57,7 @@ Definition abstract_env_compare_sort {cf:checker_flags} {abstract_env_impl abstr check_cmpb_sort_gen (abstract_env_leqb_level_n X). Definition abstract_env_check_constraints {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} - (X:abstract_env_ext_impl) : ConstraintSet.t -> bool := + (X:abstract_env_ext_impl) : UnivConstraintSet.t -> bool := check_constraints_gen (abstract_env_leqb_level_n X). Definition abstract_env_ext_wf_universeb {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} @@ -110,7 +110,7 @@ Class abstract_env_prop {cf:checker_flags} (abstract_env_impl abstract_env_ext_i LevelSet.In l (global_ext_levels Σ) <-> abstract_env_level_mem X l; abstract_env_is_consistent_correct X Σ uctx udecl : abstract_env_rel X Σ -> - ConstraintSet.For_all (declared_cstr_levels (LevelSet.union udecl.1 (global_levels Σ))) udecl.2 -> + UnivConstraintSet.For_all (declared_univ_cstr_levels (LevelSet.union udecl.1 (global_levels Σ))) udecl.2 -> gc_of_uctx udecl = Some uctx -> consistent_extension_on (global_uctx Σ) udecl.2 <-> abstract_env_is_consistent X uctx ; @@ -166,7 +166,7 @@ From Stdlib Require Import MSetFacts. From Stdlib Require Import Morphisms. -Global Instance consistent_proper : Proper (CS.Equal ==> iff) consistent. +Global Instance consistent_proper : Proper (UCS.Equal ==> iff) consistent. Proof. intros c c' eq. rewrite /consistent. now setoid_rewrite eq. @@ -200,7 +200,7 @@ Proof. Defined. Program Definition abstract_env_empty {cf:checker_flags} {X_type : abstract_env_impl} : X_type.π1 - := abstract_env_init (LS.singleton Level.lzero , CS.empty) Retroknowledge.empty _. + := abstract_env_init (LS.singleton Level.lzero , UCS.empty) Retroknowledge.empty _. Next Obligation. repeat split. - intros x Hx; cbn in *. inversion Hx. @@ -211,7 +211,7 @@ Next Obligation. Defined. Definition abstract_env_is_consistent_empty {cf:checker_flags} {X_type : abstract_env_impl} - : VSet.t * GoodConstraintSet.t -> bool := + : VSet.t * GoodUnivConstraintSet.t -> bool := fun uctx => abstract_env_is_consistent (@abstract_env_empty cf X_type) uctx. Lemma abstract_env_compare_universe_correct {cf:checker_flags} {X_type : abstract_env_impl} @@ -322,12 +322,12 @@ Qed. Lemma wf_consistent_extension_on_consistent {cf:checker_flags} {Σ} udecl : wf Σ -> consistent_extension_on (global_uctx Σ) udecl -> - consistent (ConstraintSet.union udecl (global_constraints Σ)). + consistent (UnivConstraintSet.union udecl (global_constraints Σ)). Proof. intros s Hext. pose proof (wf_consistent _ s). destruct H as [val Hval]. destruct (Hext val Hval) as [val' [Hval' Hval'']]. exists val'. - intros [[l ct] l'] [Hl|Hl]%CS.union_spec; eauto. + intros [[l ct] l'] [Hl|Hl]%UCS.union_spec; eauto. destruct (Hval _ Hl); cbn; econstructor. - erewrite <- (Hval'' l0). erewrite <- (Hval'' l'0) => //. + destruct s as [[Hs _] _]. now destruct (Hs _ Hl). diff --git a/safechecker/theories/PCUICWfEnvImpl.v b/safechecker/theories/PCUICWfEnvImpl.v index 50dc549fc..333b1f727 100644 --- a/safechecker/theories/PCUICWfEnvImpl.v +++ b/safechecker/theories/PCUICWfEnvImpl.v @@ -318,7 +318,7 @@ Next Obligation. assert (H1 : global_uctx_invariants (ContextSet.union udecl (global_uctx X))). { split => //. - apply LevelSet.union_spec; right ; now destruct H0. - - intros [[l ct] l'] [Hl|Hl]%CS.union_spec. + - intros [[l ct] l'] [Hl|Hl]%UCS.union_spec. + now specialize (Hudecl _ Hl). + destruct H0 as [_ H0]. specialize (H0 _ Hl). split; apply LevelSet.union_spec; right; @@ -337,7 +337,7 @@ Next Obligation. 1:{ pose proof (reference_impl_wf X); sq. apply: PCUICUnivSubstitutionConv.levels_global_constraint. } cbn. - change (CS.union _ _) with global_ext_uctx.2. + change (UCS.union _ _) with global_ext_uctx.2. apply: consistent_ext_on_full_ext=> //. apply: add_uctx_subgraph. Qed. diff --git a/template-pcuic/theories/PCUICToTemplateCorrectness.v b/template-pcuic/theories/PCUICToTemplateCorrectness.v index b0624190c..b4085f17e 100644 --- a/template-pcuic/theories/PCUICToTemplateCorrectness.v +++ b/template-pcuic/theories/PCUICToTemplateCorrectness.v @@ -165,8 +165,8 @@ Proof. Qed. Lemma trans_constraintSet_in x Σ: - ConstraintSet.In x (S.global_ext_constraints Σ) -> - ConstraintSet.In x (T.global_ext_constraints (trans_global Σ)). + UnivConstraintSet.In x (S.global_ext_constraints Σ) -> + UnivConstraintSet.In x (T.global_ext_constraints (trans_global Σ)). Proof. rewrite trans_global_ext_constraints. trivial. diff --git a/template-rocq/src/ast_denoter.ml b/template-rocq/src/ast_denoter.ml index 8717a68d3..846f72b2f 100644 --- a/template-rocq/src/ast_denoter.ml +++ b/template-rocq/src/ast_denoter.ml @@ -28,7 +28,7 @@ struct type quoted_sort_family = Universes0.allowed_eliminations type quoted_constraint_type = Universes0.ConstraintType.t type quoted_univ_constraint = Universes0.LevelConstraint.t - type quoted_univ_constraints = Universes0.ConstraintSet.t + type quoted_univ_constraints = Universes0.UnivConstraintSet.t type quoted_univ_level = Universes0.Level.t type quoted_univ_instance = Universes0.Instance.t type quoted_univ_context = Universes0.UContext.t diff --git a/template-rocq/src/ast_quoter.ml b/template-rocq/src/ast_quoter.ml index 5226cc9f1..7eea95cc9 100644 --- a/template-rocq/src/ast_quoter.ml +++ b/template-rocq/src/ast_quoter.ml @@ -29,7 +29,7 @@ struct type quoted_sort_family = Universes0.allowed_eliminations type quoted_constraint_type = Universes0.ConstraintType.t type quoted_univ_constraint = Universes0.LevelConstraint.t - type quoted_univ_constraints = Universes0.ConstraintSet.t + type quoted_univ_constraints = Universes0.UnivConstraintSet.t type quoted_univ_level = Universes0.Level.t type quoted_univ_instance = Universes0.Instance.t type quoted_univ_context = Universes0.UContext.t @@ -177,7 +177,7 @@ struct let quote_univ_constraints (c : Univ.Constraints.t) : quoted_univ_constraints = let l = constraints_ (Univ.Constraints.elements c) in - Universes0.ConstraintSet.(List.fold_right add l empty) + Universes0.UnivConstraintSet.(List.fold_right add l empty) let quote_variance (v : UVars.Variance.t) = match v with diff --git a/template-rocq/src/constr_reification.ml b/template-rocq/src/constr_reification.ml index b8daf1eb1..5cd3f26fe 100644 --- a/template-rocq/src/constr_reification.ml +++ b/template-rocq/src/constr_reification.ml @@ -198,10 +198,10 @@ struct let tAUContext = ast "AUContext.t" let tUContextmake = ast "UContext.make" let tAUContextmake = ast "AUContext.make" - let tConstraintSet = ast "ConstraintSet.t_" - let tConstraintSetempty = ast "ConstraintSet.empty" - let tConstraintSetadd = ast "ConstraintSet.add" - let tConstraintSet_elements = ast "ConstraintSet.elements" + let tConstraintSet = ast "UnivConstraintSet.t_" + let tConstraintSetempty = ast "UnivConstraintSet.empty" + let tConstraintSetadd = ast "UnivConstraintSet.add" + let tConstraintSet_elements = ast "UnivConstraintSet.elements" let tLevelSet = ast "LevelSet.t" let tLevelSet_elements = ast "LevelSet.elements" let tmake_univ_constraint = ast "make_univ_constraint" diff --git a/template-rocq/theories/AstUtils.v b/template-rocq/theories/AstUtils.v index 00d98bff2..dab13eeb7 100644 --- a/template-rocq/theories/AstUtils.v +++ b/template-rocq/theories/AstUtils.v @@ -732,7 +732,7 @@ Section Lookups. Definition polymorphic_constraints u := match u with - | Monomorphic_ctx => ConstraintSet.empty + | Monomorphic_ctx => UnivConstraintSet.empty | Polymorphic_ctx ctx => (AUContext.repr ctx).2.2 end. diff --git a/template-rocq/theories/Checker.v b/template-rocq/theories/Checker.v index cbf7cc44c..a54de87c5 100644 --- a/template-rocq/theories/Checker.v +++ b/template-rocq/theories/Checker.v @@ -45,8 +45,8 @@ Inductive type_error := | NotAProduct (t t' : term) | NotAnInductive (t : term) | IllFormedFix (m : mfixpoint term) (i : nat) -| UnsatisfiedConstraints (c : ConstraintSet.t) -| UnsatisfiableConstraints (c : ConstraintSet.t) +| UnsatisfiedConstraints (c : UnivConstraintSet.t) +| UnsatisfiableConstraints (c : UnivConstraintSet.t) | NotEnoughFuel (n : nat) | NotSupported (s : string). @@ -103,7 +103,7 @@ Section Lookups. Definition polymorphic_constraints u := match u with - | Monomorphic_ctx => ConstraintSet.empty + | Monomorphic_ctx => UnivConstraintSet.empty | Polymorphic_ctx ctx => (AUContext.repr ctx).2.2 end. @@ -822,7 +822,7 @@ Section Checker. end. Definition add_gc_constraints ctrs (G : universes_graph) : universes_graph - := (G.1.1, GoodConstraintSet.fold + := (G.1.1, GoodUnivConstraintSet.fold (fun ctr => wGraph.EdgeSet.add (edge_of_constraint ctr)) ctrs G.1.2, G.2). diff --git a/template-rocq/theories/Constants.v b/template-rocq/theories/Constants.v index 33e0b1be3..28f18505e 100644 --- a/template-rocq/theories/Constants.v +++ b/template-rocq/theories/Constants.v @@ -134,10 +134,10 @@ Register MetaRocq.Common.Universes.universes_decl as metarocq.ast.universes_decl Register MetaRocq.Common.Universes.Monomorphic_ctx as metarocq.ast.Monomorphic_ctx. Register MetaRocq.Common.Universes.Polymorphic_ctx as metarocq.ast.Polymorphic_ctx. -Register MetaRocq.Common.Universes.ConstraintSet.t_ as metarocq.ast.ConstraintSet.t_. -Register MetaRocq.Common.Universes.ConstraintSet.empty as metarocq.ast.ConstraintSet.empty. -Register MetaRocq.Common.Universes.ConstraintSet.add as metarocq.ast.ConstraintSet.add. -Register MetaRocq.Common.Universes.ConstraintSet.elements as metarocq.ast.ConstraintSet.elements. +Register MetaRocq.Common.Universes.UnivConstraintSet.t_ as metarocq.ast.UnivConstraintSet.t_. +Register MetaRocq.Common.Universes.UnivConstraintSet.empty as metarocq.ast.UnivConstraintSet.empty. +Register MetaRocq.Common.Universes.UnivConstraintSet.add as metarocq.ast.UnivConstraintSet.add. +Register MetaRocq.Common.Universes.UnivConstraintSet.elements as metarocq.ast.UnivConstraintSet.elements. Register MetaRocq.Common.Universes.UContext.t as metarocq.ast.UContext.t. Register MetaRocq.Common.Universes.UContext.make as metarocq.ast.UContext.make. diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v index 2189af6d8..410bcb15c 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -244,23 +244,6 @@ Module UnivLoopChecking. - now move/to_levelexprzset_spec_1. Qed. - Lemma univ_levels_spec l u : - Universes.LevelSet.In l (Universes.LevelExprSet.levels u) <-> - exists k, Universes.LevelExprSet.In (l, k) u. - Proof. - rewrite /Universes.LevelExprSet.levels. - eapply Universes.LevelExprSetProp.fold_rec. - - move=> s' he; split. lsets. - move=> [k hin]. firstorder. - - move=> x a s' s'' hin hnin hadd. - rewrite Universes.LevelSet.add_spec. - split. - rewrite H. firstorder. - subst l. exists x.2. apply hadd. left. now destruct x. - intros [k' hin']. apply hadd in hin' as []; subst. - now left. now right; firstorder. - Qed. - Lemma levels_in_to_atoms l u : LevelSet.In l (levels (to_atoms u)) <-> Universes.LevelSet.In l (Universes.LevelExprSet.levels u). Proof. @@ -296,16 +279,6 @@ Module UnivLoopChecking. rewrite Nat2Z.id //. Qed. - Definition choose (u : Universe.t) : Universes.LevelExpr.t := (Universes.NonEmptySetFacts.to_nonempty_list u).1. - Lemma choose_spec u : Universes.LevelExprSet.In (choose u) u. - Proof. - rewrite /choose. - have hs := Universes.NonEmptySetFacts.to_nonempty_list_spec u. - destruct Universes.NonEmptySetFacts.to_nonempty_list. cbn. - rewrite -Universes.LevelExprSet.elements_spec1 InA_In_eq -hs. - now constructor. - Qed. - Definition choose_prems (u : premises) : LevelExpr.t := (NonEmptySetFacts.to_nonempty_list u).1. Lemma choose_prems_spec u : LevelExprSet.In (choose_prems u) u. Proof. @@ -561,8 +534,8 @@ Module UnivLoopChecking. Lemma model_satisfies m : exists V, satisfies - (* Definition enforce_level_constraints (m : univ_model) (l : ConstraintSet.t) := - ConstraintSet.fold (fun c m => + (* Definition enforce_level_constraints (m : univ_model) (l : UnivConstraintSet.t) := + UnivConstraintSet.fold (fun c m => match m with | inl m => let c := (level_constraint_to_constraint c) in diff --git a/template-rocq/theories/PartialLoopChecking.v b/template-rocq/theories/PartialLoopChecking.v index e093398e6..b0ddf43c6 100644 --- a/template-rocq/theories/PartialLoopChecking.v +++ b/template-rocq/theories/PartialLoopChecking.v @@ -1798,11 +1798,6 @@ Local Open Scope Z_scope. Section MoreNonEmpty. Import LevelExprSet. - Lemma In_elements {x} {s : LevelExprSet.t} : In x s <-> List.In x (elements s). - Proof. - split. now move/LevelExprSetFact.elements_1/InA_In_eq. - now move/InA_In_eq/LevelExprSetFact.elements_2. - Qed. Import NonEmptySetFacts. Notation min_opt := (option_map2 Z.min). @@ -2287,14 +2282,6 @@ Proof. setoid_rewrite eqcl. now setoid_rewrite eqm; setoid_rewrite eqs. Qed. -#[local] Instance proper_levelexprset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) - levels. -Proof. - intros s s' eq l. - rewrite !levelexprset_levels_spec. - firstorder eauto. -Qed. - Lemma min_premise_spec' {m prems z} : min_premise m prems = Some z -> (forall l k, LevelExprSet.In (l, k) prems -> exists v, level_value m l = Some v /\ z <= (Z.of_nat v - Z.of_nat k))%Z. diff --git a/template-rocq/theories/TemplateLoopChecking.v b/template-rocq/theories/TemplateLoopChecking.v index a527667b0..bd8795a9f 100644 --- a/template-rocq/theories/TemplateLoopChecking.v +++ b/template-rocq/theories/TemplateLoopChecking.v @@ -64,7 +64,7 @@ Definition test : TemplateMonad unit := tmMsg (print_result m') ;; (* tmMsg (print_clauses clauses) ;; *) (* tmMsg (string_of_nat (LevelSet.cardinal (fst ctx)));; *) - (* ++ " universes and " ++ string_of_nat (ConstraintSet.cardinal (snd ctx)) ++ " constraints") ;; *) + (* ++ " universes and " ++ string_of_nat (UnivConstraintSet.cardinal (snd ctx)) ++ " constraints") ;; *) tmMsg "done". (* MetaRocq Run test. *) diff --git a/template-rocq/theories/Typing.v b/template-rocq/theories/Typing.v index 3cd0e8141..bc3b36370 100644 --- a/template-rocq/theories/Typing.v +++ b/template-rocq/theories/Typing.v @@ -504,10 +504,10 @@ Inductive red Σ Γ M : term -> Type := We hence implement first an equality which considers casts and do a stripping phase of casts before checking equality. *) -Definition eq_term_nocast `{checker_flags} (Σ : global_env) (φ : ConstraintSet.t) (t u : term) := +Definition eq_term_nocast `{checker_flags} (Σ : global_env) (φ : UnivConstraintSet.t) (t u : term) := eq_term Σ φ (strip_casts t) (strip_casts u). -Definition leq_term_nocast `{checker_flags} (Σ : global_env) (φ : ConstraintSet.t) (t u : term) := +Definition leq_term_nocast `{checker_flags} (Σ : global_env) (φ : UnivConstraintSet.t) (t u : term) := leq_term Σ φ (strip_casts t) (strip_casts u). Reserved Notation " Σ ;;; Γ |- t : T " (at level 50, Γ, t, T at next level). diff --git a/test-suite/loop-checking/theories/LoopCheckingPlugin.v b/test-suite/loop-checking/theories/LoopCheckingPlugin.v index 67ad002c6..2e043dbf3 100644 --- a/test-suite/loop-checking/theories/LoopCheckingPlugin.v +++ b/test-suite/loop-checking/theories/LoopCheckingPlugin.v @@ -24,6 +24,6 @@ Global Instance TemplateMonad_Monad@{t u} : Monad@{t u} TM@{t} := Definition check_universes : TM unit := tmQuoteUniverses >>= fun ctx => let clauses := time "building clauses" enforce_level_constraints (snd ctx) in - tmMsg (string_of_nat (LevelSet.cardinal (fst ctx)) ++ " universes and " ++ string_of_nat (ConstraintSet.cardinal (snd ctx)) ++ " constraints") ;; + tmMsg (string_of_nat (LevelSet.cardinal (fst ctx)) ++ " universes and " ++ string_of_nat (UnivConstraintSet.cardinal (snd ctx)) ++ " constraints") ;; let result := time "loop-checking" TemplateLoopChecking.UnivLoopChecking.infer clauses in tmMsg (TemplateLoopChecking.UnivLoopChecking.print_result result). diff --git a/test-suite/univ.v b/test-suite/univ.v index ddb3ac454..61f5709f4 100644 --- a/test-suite/univ.v +++ b/test-suite/univ.v @@ -174,8 +174,8 @@ Module toto. (* tProd nAnon (tSort ((Level.lvar 0, false) :: nil)%list) (tRel 1), *) (* 1) :: nil; *) (* ind_projs := nil |}] (UContext.make (Level.lvar 0 :: Level.lvar 1 :: nil)%list *) - (* (ConstraintSet.add (make_univ_constraint (Level.lvar 0) Lt (Level.lvar 1)) *) - (* ConstraintSet.empty)))) ;; *) + (* (UnivConstraintSet.add (make_univ_constraint (Level.lvar 0) Lt (Level.lvar 1)) *) + (* UnivConstraintSet.empty)))) ;; *) End toto. diff --git a/utils/_RocqProject b/utils/_RocqProject index fdaab1e6c..d86f3b3f5 100644 --- a/utils/_RocqProject +++ b/utils/_RocqProject @@ -34,6 +34,8 @@ theories/monad_utils.v theories/Show.v theories/utils.v +theories/NonEmptyLevelExprSet.v + # extra tactics theories/MRTactics/DestructHead.v theories/MRTactics/DestructHyps.v diff --git a/utils/theories/All_Forall.v b/utils/theories/All_Forall.v index 4b8959e75..483caf4c0 100644 --- a/utils/theories/All_Forall.v +++ b/utils/theories/All_Forall.v @@ -1892,7 +1892,7 @@ Proof. Qed. Lemma All_safe_nth {A} {P : A -> Type} {Γ n} (isdecl : n < length Γ) : All P Γ -> - P (safe_nth Γ (exist _ n isdecl)). + P (safe_nth Γ (exist n isdecl)). Proof. induction 1 in n, isdecl |- *. exfalso. inversion isdecl. diff --git a/utils/theories/MRList.v b/utils/theories/MRList.v index 13c8d3ae3..580b8b0be 100644 --- a/utils/theories/MRList.v +++ b/utils/theories/MRList.v @@ -4,6 +4,8 @@ From MetaRocq.Utils Require Import MRPrelude MRRelations. Set Equations Transparent. +Derive Signature for InA. + Export ListNotations. Arguments firstn : simpl nomatch. @@ -78,7 +80,7 @@ Proof. Qed. Lemma nth_error_safe_nth {A} n (l : list A) (isdecl : n < Datatypes.length l) : - nth_error l n = Some (safe_nth l (exist _ n isdecl)). + nth_error l n = Some (safe_nth l (exist n isdecl)). Proof. revert n isdecl; induction l; intros. - inversion isdecl. diff --git a/utils/theories/MRMSets.v b/utils/theories/MRMSets.v index 08099e27d..3b75a79f3 100644 --- a/utils/theories/MRMSets.v +++ b/utils/theories/MRMSets.v @@ -207,7 +207,7 @@ Module MSetAVL. => { bl : _ | { br : _ | { ltl : _ | { gtr : _ | M.Raw.BSNode c x l r bl br ltl gtr = b }}}} end x with | M.Raw.BSLeaf => eq_refl - | M.Raw.BSNode c x l r bl br ltl gtr => exist _ bl (exist _ br (exist _ ltl (exist _ gtr eq_refl))) + | M.Raw.BSNode c x l r bl br ltl gtr => exist bl (exist br (exist ltl (exist gtr eq_refl))) end. Lemma bst_irrel t (x y : M.Raw.bst t) : x = y. Proof. diff --git a/utils/theories/MRPrelude.v b/utils/theories/MRPrelude.v index cd5a47f08..c5c86a72e 100644 --- a/utils/theories/MRPrelude.v +++ b/utils/theories/MRPrelude.v @@ -1,3 +1,4 @@ +From Corelib Require Import ssreflect ssrfun. From Stdlib Require Import Ascii String ZArith Lia Morphisms. From Equations Require Import Equations. Set Equations Transparent. @@ -46,7 +47,7 @@ Infix "=2" := (pointwise_relation _ (pointwise_relation _ Logic.eq)) (at level 7 Proof. intros f f' Hff' g g' Hgg'. split; intros. - intros x. now rewrite <- Hff', <- Hgg'. - - intros x. now rewrite Hff', Hgg'. + - intros x. now rewrite Hff' Hgg'. Qed. #[global] Instance id_proper_proxy {A} : ProperProxy (`=1`) (@id A). @@ -132,3 +133,25 @@ Tactic Notation "relativize" open_constr(c) := Record sigP {A : Prop} {B : A -> Prop} := existP { projP1 : A ; projP2 : B projP1 }. Arguments sigP {A} B. Arguments existP {A} B _ _. + +Notation fwd := (ltac:(move=> /(_ _)/Wrap[])). + +Arguments exist {A P}. +Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. + +Arguments symmetry {A R Symmetric} {x y}. + +Lemma uip_bool (b1 b2 : bool) (p q : b1 = b2) : p = q. +Proof. + destruct q. apply Eqdep_dec.UIP_refl_bool. +Qed. + +Lemma iff_forall {A} B C (H : forall x : A, B x <-> C x) + : (forall x, B x) <-> (forall x, C x). + firstorder. +Defined. + +Lemma iff_ex {A} B C (H : forall x : A, B x <-> C x) + : (ex B) <-> (ex C). + firstorder. +Defined. diff --git a/utils/theories/MRUtils.v b/utils/theories/MRUtils.v index a5c2eed6d..d30b00ff8 100644 --- a/utils/theories/MRUtils.v +++ b/utils/theories/MRUtils.v @@ -171,17 +171,6 @@ Ltac invs H := inversion H; subst; clear H. Ltac generalize_eq x t := set (x := t) in *; cut (x = t); [|reflexivity]; clearbody x. - -Lemma iff_forall {A} B C (H : forall x : A, B x <-> C x) - : (forall x, B x) <-> (forall x, C x). - firstorder. -Defined. - -Lemma iff_ex {A} B C (H : forall x : A, B x <-> C x) - : (ex B) <-> (ex C). - firstorder. -Defined. - Lemma if_true_false (b : bool) : (if b then true else false) = b. destruct b; reflexivity. Qed. @@ -194,11 +183,6 @@ Proof. discriminate. Qed. -Lemma uip_bool (b1 b2 : bool) (p q : b1 = b2) : p = q. -Proof. - destruct q. apply Eqdep_dec.UIP_refl_bool. -Qed. - Axiom todo : string -> forall {A}, A. Ltac todo s := exact (todo s). diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v new file mode 100644 index 000000000..2ec15e124 --- /dev/null +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -0,0 +1,478 @@ +From Corelib Require Program.Tactics. +From Equations Require Import Equations. +Set Equations Transparent. +From Corelib Require Import ssreflect ssrfun ssrbool. +From Stdlib Require Import SetoidList Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import MRPrelude ReflectEq MRString MRList. + +Module Type OrderedTypeWithLeibniz. + Include UsualOrderedType. + Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. +End OrderedTypeWithLeibniz. + +Module Type OrderedTypeWithLeibnizWithReflect. + Include OrderedTypeWithLeibniz. + + Parameter reflect_eq : ReflectEq t. + Parameter to_string : t -> string. +End OrderedTypeWithLeibnizWithReflect. + +Module Type Quantity. + Include OrderedTypeWithLeibniz. + Parameter zero : t. + Parameter add : t -> t -> t. +End Quantity. + +Module Type LevelExprT (Level : OrderedTypeWithLeibniz) (Q : Quantity). + Include UsualOrderedType with Definition t := (Level.t * Q.t)%type. + Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. +End LevelExprT. + +Module Type LevelSet_fun (Level : UsualOrderedType). + Include S with Module E := Level. +End LevelSet_fun. + +Module Type LevelExprSet_fun (Level : OrderedTypeWithLeibniz) (Q : Quantity) + (LevelExpr : LevelExprT Level Q). + Include SWithLeibniz with Module E := LevelExpr. + + Parameter reflect_eq : ReflectEq t. +End LevelExprSet_fun. + +Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) + (LevelSet : LevelSet_fun Level) + (LevelExpr : LevelExprT Level Q) + (LevelExprSet : LevelExprSet_fun Level Q LevelExpr). + Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. + Module LevelExprSetOrdProp := MSetProperties.OrdProperties LevelExprSet. + Module LevelExprSetProp := LevelExprSetOrdProp.P. + Module UCS := LevelExprSet. + + Module LevelSetOrdProp := MSetProperties.OrdProperties LevelSet. + Module LevelSetProp := LevelSetOrdProp.P. + Module LevelSetDecide := LevelSetProp.Dec. + Ltac lsets := LevelSetDecide.fsetdec. + + Module LevelExprSetDecide := LevelExprSetProp.Dec. + (* Module LevelExprSetExtraOrdProp := MSets.ExtraOrdProperties LevelExprSet LevelExprSetOrdProp. *) + Module LevelExprSetExtraDecide := MSetDecide.Decide LevelExprSet. + Ltac lesets := LevelExprSetDecide.fsetdec. + + Import LevelExprSet. + + Definition level : LevelExpr.t -> Level.t := fst. + + Definition levels (e : t) := + fold (fun le => LevelSet.add (level le)) e LevelSet.empty. + + Lemma In_elements {x} {s : LevelExprSet.t} : LevelExprSet.In x s <-> List.In x (LevelExprSet.elements s). + Proof. + split. now move/LevelExprSetFact.elements_1/InA_In_eq. + now move/InA_In_eq/LevelExprSetFact.elements_2. + Qed. + + Record t := { t_set :> LevelExprSet.t ; t_ne : is_empty t_set = false }. + + Existing Instance LevelExprSet.reflect_eq. + + (* We use uip on the is_empty condition *) + #[export, program] Instance reflect_eq : ReflectEq t := + { eqb x y := eqb x.(t_set) y.(t_set) }. + Next Obligation. + destruct (eqb_spec (t_set x) (t_set y)); constructor. + destruct x, y; cbn in *. subst. + now rewrite (uip t_ne0 t_ne1). + intros e; subst x; apply H. + reflexivity. + Qed. + + Lemma nis_empty s : is_empty s = false <-> ~ LevelExprSet.Empty s. + Proof. + destruct is_empty eqn:he; split => //. + - apply LevelExprSet.is_empty_spec in he. contradiction. + - intros _ he'. now eapply LevelExprSet.is_empty_spec in he'. + Qed. + + Lemma nis_empty_exists s : is_empty s = false <-> exists le, LevelExprSet.In le s. + Proof. + rewrite nis_empty. split; firstorder. + destruct (choose s) eqn:hc. + - exists e. now apply choose_spec1 in hc. + - apply choose_spec2 in hc. contradiction. + Qed. + + Program Definition singleton (e : LevelExpr.t) : t + := {| t_set := LevelExprSet.singleton e |}. + Next Obligation. + Proof. + apply nis_empty => he. eapply (he e). lesets. + Qed. + + Lemma not_Empty_is_empty s : + ~ LevelExprSet.Empty s <-> LevelExprSet.is_empty s = false. + Proof. now rewrite nis_empty. Qed. + + Program Definition add (e : LevelExpr.t) (u : t) : t + := {| t_set := LevelExprSet.add e u |}. + Next Obligation. + apply not_Empty_is_empty; intro H. + eapply H. eapply LevelExprSet.add_spec. + left; reflexivity. + Qed. + + Lemma add_spec e u e' : + In e' (add e u) <-> e' = e \/ In e' u. + Proof. + apply LevelExprSet.add_spec. + Qed. + + Definition add_list : list LevelExpr.t -> t -> t + := List.fold_left (fun u e => add e u). + + Lemma add_list_spec l u e : + LevelExprSet.In e (add_list l u) <-> List.In e l \/ LevelExprSet.In e u. + Proof. + unfold add_list. rewrite <- fold_left_rev_right. + etransitivity. 2:{ eapply or_iff_compat_r. etransitivity. + 2: apply @InA_In_eq with (A:=LevelExpr.t). + eapply InA_rev. } + induction (List.rev l); cbn. + - split. intuition. intros [H|H]; tas. depelim H. + - split. + + intro H. apply add_spec in H. destruct H as [H|H]. + * left. now constructor. + * apply IHl0 in H. destruct H as [H|H]; [left|now right]. + now constructor 2. + + intros [H|H]. inv H. + * apply add_spec; now left. + * apply add_spec; right. apply IHl0. now left. + * apply add_spec; right. apply IHl0. now right. + Qed. + + Lemma elements_not_empty {u : t} : LevelExprSet.elements u <> []. + Proof. + rewrite -LevelExprSetProp.elements_Empty. + move/LevelExprSetFact.is_empty_1. + destruct u as [u1 u2]; cbn in *. congruence. + Qed. + + Equations to_nonempty_list (u : t) : LevelExpr.t * list LevelExpr.t := + | u with inspect (LevelExprSet.elements u) := { + | exist [] eqel => False_rect _ (elements_not_empty eqel) + | exist (e :: l) _ => (e, l) }. + + Lemma singleton_to_nonempty_list e : to_nonempty_list (singleton e) = (e, []). + Proof. + funelim (to_nonempty_list (singleton e)). Tactics.bang. + clear H. + pose proof (LevelExprSet.singleton_spec e1 e). + rewrite LevelExprSetFact.elements_iff in H. + rewrite InA_In_eq in H. rewrite e0 in H. + destruct H. forward H. now left. noconf H. f_equal. + pose proof (LevelExprSet.cardinal_spec (LevelExprSet.singleton e1)). rewrite e0 in H. cbn in H. + rewrite LevelExprSetProp.singleton_cardinal in H. + destruct l => //. + Qed. + + Lemma to_nonempty_list_spec u : + let '(e, u') := to_nonempty_list u in + e :: u' = LevelExprSet.elements u. + Proof. + funelim (to_nonempty_list u). Tactics.bang. now rewrite e0. + Qed. + + Lemma to_nonempty_list_spec' u : + (to_nonempty_list u).1 :: (to_nonempty_list u).2 = elements u. + Proof. + pose proof (to_nonempty_list_spec u). + now destruct (to_nonempty_list u). + Qed. + + Lemma In_to_nonempty_list (u : t) (e : LevelExpr.t) : + In e u + <-> e = (to_nonempty_list u).1 \/ List.In e (to_nonempty_list u).2. + Proof. + etransitivity. symmetry. apply LevelExprSet.elements_spec1. + pose proof (to_nonempty_list_spec' u) as H. + destruct (to_nonempty_list u) as [e' l]; cbn in *. + rewrite <- H; clear. etransitivity. apply InA_cons. + eapply or_iff_compat_l. apply InA_In_eq. + Qed. + + Lemma In_to_nonempty_list_rev (u : t) (e : LevelExpr.t) : + In e u <-> e = (to_nonempty_list u).1 \/ List.In e (List.rev (to_nonempty_list u).2). + Proof. + etransitivity. eapply In_to_nonempty_list. + apply or_iff_compat_l. apply in_rev. + Qed. + + Definition map_levelexprset f u := + LevelExprSetProp.of_list (List.map f (LevelExprSet.elements u)). + + Program Definition map (f : LevelExpr.t -> LevelExpr.t) (u : t) : t := + {| t_set := map_levelexprset f u |}. + Next Obligation. + rewrite /map_levelexprset. + have hs := to_nonempty_list_spec u. + destruct (to_nonempty_list u). rewrite -hs. cbn. + apply not_Empty_is_empty => he. apply (he (f t0)). + lesets. + Qed. + + Lemma map_levelexprset_spec f u e : + LevelExprSet.In e (map_levelexprset f u) <-> exists e0, LevelExprSet.In e0 u /\ e = (f e0). + Proof. + unfold map; cbn. + rewrite LevelExprSetProp.of_list_1 InA_In_eq in_map_iff. + split. + - intros [x [<- hin]]. exists x. split => //. + rewrite -InA_In_eq in hin. now apply LevelExprSet.elements_spec1 in hin. + - intros [x [hin ->]]. exists x. split => //. + rewrite -InA_In_eq. now apply LevelExprSet.elements_spec1. + Qed. + + Lemma map_spec f u e : + LevelExprSet.In e (map f u) <-> exists e0, LevelExprSet.In e0 u /\ e = (f e0). + Proof. apply map_levelexprset_spec. Qed. + + Program Definition non_empty_union (u v : t) : t := + {| t_set := LevelExprSet.union u v |}. + Next Obligation. + apply not_Empty_is_empty; intro H. + assert (HH: LevelExprSet.Empty u). { + intros x Hx. apply (H x). + eapply LevelExprSet.union_spec. now left. } + apply LevelExprSetFact.is_empty_1 in HH. + rewrite t_ne in HH; discriminate. + Qed. + + Lemma eq_exprsets (u v : t) : + u = v :> LevelExprSet.t -> u = v. + Proof. + destruct u as [u1 u2], v as [v1 v2]; cbn. intros X; destruct X. + now rewrite (uip_bool _ _ u2 v2). + Qed. + + Definition eq_univ (u v : t) : u = v :> LevelExprSet.t -> u = v := eq_exprsets u v. + + Lemma equal_exprsets (u v : t) : LevelExprSet.Equal u v -> u = v. + Proof. + intro H. now apply eq_univ, LevelExprSet.eq_leibniz. + Qed. + + #[deprecated(note = "use equal_exprsets instead")] + Notation eq_univ_equal := equal_exprsets. + + #[deprecated(note = "use equal_exprsets instead")] + Notation eq_univ' := equal_exprsets. + + Lemma equal_elements (u v : t) : + LevelExprSet.elements u = LevelExprSet.elements v -> u = v. + Proof. + intro H. apply eq_univ. + destruct u as [u1 u2], v as [v1 v2]; cbn in *; clear u2 v2. + eapply LevelExprSet.eq_leibniz. red. + intros x. rewrite -!LevelExprSet.elements_spec1 H //. + Qed. + + #[deprecated(note = "use equal_elements instead")] + Notation eq_univ_elements := equal_elements. + + #[deprecated(note = "use equal_elements instead")] + Definition eq_univ'' := equal_elements. + + Lemma univ_expr_eqb_true_iff (u v : t) : + LevelExprSet.equal u v <-> u = v. + Proof. + split. + - intros. + apply equal_exprsets. now apply LevelExprSet.equal_spec. + - intros ->. now apply LevelExprSet.equal_spec. + Qed. + + Lemma univ_expr_eqb_comm (u v : t) : + LevelExprSet.equal u v <-> LevelExprSet.equal v u. + Proof. + transitivity (u = v). 2: transitivity (v = u). + - apply univ_expr_eqb_true_iff. + - split; apply eq_sym. + - split; apply univ_expr_eqb_true_iff. + Qed. + + + Lemma for_all_false f u : + for_all f u = false -> exists_ (negb ∘ f) u. + Proof. + intro H. rewrite LevelExprSetFact.exists_b. + rewrite LevelExprSetFact.for_all_b in H. + all: try now intros x y []. + induction (LevelExprSet.elements u); cbn in *; [discriminate|]. + apply andb_false_iff in H; apply orb_true_iff; destruct H as [H|H]. + left; now rewrite H. + right; now rewrite IHl. + Qed. + + Lemma For_all_exprs (P : LevelExpr.t -> Prop) (u : t) + : For_all P u + <-> P (to_nonempty_list u).1 /\ Forall P (to_nonempty_list u).2. + Proof. + etransitivity. + - eapply iff_forall; intro e. eapply imp_iff_compat_r. + apply In_to_nonempty_list. + - cbn; split. + + intro H. split. apply H. now left. + apply Forall_forall. intros x H0. apply H; now right. + + intros [H1 H2] e [He|He]. subst e; tas. + eapply Forall_forall in H2; tea. + Qed. + + Lemma add_comm {le le' e} : add le (add le' e) = add le' (add le e). + Proof. + apply eq_univ_equal. intros x. + rewrite !LevelExprSet.add_spec. firstorder. + Qed. + + #[program] + Definition univ_union (prems prems' : t) : t := + {| t_set := LevelExprSet.union prems prems' |}. + Next Obligation. + destruct prems, prems'; cbn. + destruct (LevelExprSet.is_empty (LevelExprSet.union _ _)) eqn:ise => //. + eapply LevelExprSetFact.is_empty_2 in ise. + eapply not_Empty_is_empty in t_ne0, t_ne1. + destruct t_ne0. lesets. + Qed. + + Lemma univ_union_spec u u' l : + LevelExprSet.In l (univ_union u u') <-> + LevelExprSet.In l u \/ LevelExprSet.In l u'. + Proof. + destruct u, u'; unfold univ_union; cbn. + apply LevelExprSet.union_spec. + Qed. + + Lemma univ_union_add_singleton u le : univ_union u (singleton le) = add le u. + Proof. + apply eq_univ_equal. + intros x. rewrite univ_union_spec LevelExprSet.singleton_spec add_spec. + intuition auto. + Qed. + + Lemma univ_union_comm {u u'} : univ_union u u' = univ_union u' u. + Proof. + apply eq_univ_equal. + intros x. rewrite !univ_union_spec. + intuition auto. + Qed. + + Lemma univ_union_add_distr {le u u'} : univ_union (add le u) u' = add le (univ_union u u'). + Proof. + apply eq_univ_equal. + intros x. rewrite !univ_union_spec !add_spec !univ_union_spec. + intuition auto. + Qed. + + + Lemma levels_spec_aux l (e : LevelExprSet.t) acc : + LevelSet.In l (LevelExprSet.fold (fun le : LevelExprSet.elt => LevelSet.add (level le)) e acc) <-> + (exists k, LevelExprSet.In (l, k) e) \/ LevelSet.In l acc. + Proof. + eapply LevelExprSetProp.fold_rec. + - intros. + intuition auto. destruct H1 as [k hin]. lesets. + - intros x a s' s'' hin nin hadd ih. + rewrite LevelSet.add_spec. + split. + * intros [->|]. + left. exists x.2. red in H. subst. + apply hadd. cbn. left. now destruct x. + apply ih in H. + intuition auto. + left. destruct H0 as [k Hk]. exists k. apply hadd. now right. + * intros [[k ins'']|inacc]. + eapply hadd in ins''. destruct ins''; subst. + + now left. + + right. apply ih. now left; exists k. + + right. intuition auto. + Qed. + + Lemma levels_spec l (e : LevelExprSet.t) : + LevelSet.In l (levels e) <-> exists k, LevelExprSet.In (l, k) e. + Proof. + rewrite levels_spec_aux. intuition auto. lsets. + Qed. + + #[export] Instance proper_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) + levels. + Proof. + intros s s' eq l. + rewrite !levels_spec. + firstorder eauto. + Qed. + + Definition choose (u : t) : LevelExpr.t := (to_nonempty_list u).1. + + Lemma choose_spec u : In (choose u) u. + Proof. + rewrite /choose. + have hs := to_nonempty_list_spec u. + destruct to_nonempty_list. cbn. + rewrite -elements_spec1 InA_In_eq -hs. + now constructor. + Qed. + + Definition eq x y := eq (t_set x) (t_set y). + + #[export] Instance proper_choose : Proper (eq ==> Logic.eq) choose. + Proof. + intros x y e. + rewrite /choose. + have he := to_nonempty_list_spec x. + have he' := to_nonempty_list_spec y. + do 2 destruct to_nonempty_list. cbn. red in e. + apply LevelExprSet.eq_leibniz in e. now subst. + Qed. + + Lemma univ_non_empty (u : t) : ~ LevelSet.Empty (levels u). + Proof. + intros he. + apply (he (choose u).1). + rewrite levels_spec. exists (choose u).2. + destruct (choose u) eqn:e; cbn. rewrite -e. + apply choose_spec. + Qed. + + Lemma elim {P : t -> Type} : + (forall le, P (singleton le)) -> + (forall le x, P x -> ~ LevelExprSet.In le x -> P (add le x)) -> + forall x, P x. + Proof. + intros hs ha. + intros []. + revert t_set0 t_ne0. + apply: LevelExprSetProp.set_induction; eauto. + - move=> s /LevelExprSetFact.is_empty_1 he ne; exfalso => //. congruence. + - intros s s' IH x nin hadd hne. + destruct (LevelExprSet.is_empty s) eqn:hem in |- . + eapply LevelExprSetFact.is_empty_2 in hem. + assert (singleton x = {| t_set := s'; t_ne := hne |}) as <- => //. + unfold singleton. apply equal_exprsets. cbn. + intros a. specialize (hadd a). rewrite hadd. + rewrite LevelExprSet.singleton_spec. firstorder. subst. reflexivity. + specialize (IH hem). + specialize (ha x _ IH). + assert (LevelExprSet.Equal (add x {| t_set := s; t_ne := hem|}) {| t_set := s'; t_ne := hne |}). + 2:{ apply equal_exprsets in H. now rewrite -H. } + intros x'. specialize (hadd x'). rewrite LevelExprSet.add_spec. + cbn. firstorder. subst x'. now left. + Qed. + + Lemma map_map f g x : map f (map g x) = map (f ∘ g) x. + Proof. + apply equal_exprsets. + intros lk. + rewrite !map_spec. setoid_rewrite map_spec. + firstorder eauto. subst. firstorder. + Qed. + +End NonEmptyLevelExprSet. diff --git a/utils/theories/utils.v b/utils/theories/utils.v index 107c7bbd5..93cdc9f90 100644 --- a/utils/theories/utils.v +++ b/utils/theories/utils.v @@ -4,8 +4,9 @@ (** If you don't want to have the following scopes opened you should *) (** not import this file or close them. *) +From Corelib Require Import ssreflect ssrfun ssrbool. From Stdlib Require Export Bool ZArith Arith Lia List. - +From Corelib Require Import RelationClasses. From MetaRocq.Utils Require Export MRUtils monad_utils. Global Set Asymmetric Patterns. From b8ce6098cc51b2f325dbad90e2a4e75411b2e9b8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sun, 14 Sep 2025 00:54:03 +0200 Subject: [PATCH 052/164] Moved up to UnivLoopChecking --- common/theories/Environment.v | 4 +- common/theories/LoopChecking/Deciders.v | 18 +- common/theories/LoopChecking/HornClauses.v | 90 +++--- common/theories/LoopChecking/Interfaces.v | 305 ++---------------- common/theories/LoopChecking/Model.v | 57 ++-- common/theories/LoopChecking/Models.v | 42 +-- .../LoopChecking/PartialLoopChecking.v | 16 +- common/theories/Reflect.v | 29 +- ...PartialLoopChecking.v => oldLoopChecking.v | 0 .../theories/LoopChecking/UnivLoopChecking.v | 134 ++++---- utils/theories/NonEmptyLevelExprSet.v | 13 +- 11 files changed, 203 insertions(+), 505 deletions(-) rename template-rocq/theories/PartialLoopChecking.v => oldLoopChecking.v (100%) diff --git a/common/theories/Environment.v b/common/theories/Environment.v index a425af9ef..6622bfd1b 100644 --- a/common/theories/Environment.v +++ b/common/theories/Environment.v @@ -689,13 +689,13 @@ Module Environment (T : Term). #[global] Instance strictly_extends_decls_extends_strictly_on_decls Σ Σ' : strictly_extends_decls Σ Σ' -> extends_strictly_on_decls Σ Σ'. Proof. destruct Σ, Σ'; intros []. cbn in *; subst. split => //=. - split; [lsets|csets]. apply Retroknowledge.extends_refl. + split; [lsets|ucsets]. apply Retroknowledge.extends_refl. Qed. #[global] Instance extends_decls_extends Σ Σ' : extends_decls Σ Σ' -> extends Σ Σ'. Proof. destruct Σ, Σ'; intros []. cbn in *; subst. split => //=. - split; [lsets|csets]. apply Retroknowledge.extends_refl. + split; [lsets|ucsets]. apply Retroknowledge.extends_refl. Qed. #[global] Instance extends_strictly_on_decls_extends Σ Σ' : extends_strictly_on_decls Σ Σ' -> extends Σ Σ'. diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index f2c954961..178cf82cc 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -15,7 +15,7 @@ Module Type LoopCheckingItf (LS : LevelSets). (* Type of consistent models of a set of universe constraints *) Parameter model : Type. - Notation univ := LS.LevelExprSet.nonEmptyLevelExprSet. + Parameter univ : Type. Inductive constraint_type := UnivEq | UnivLe. Notation constraint := (univ * constraint_type * univ). @@ -104,7 +104,7 @@ Definition to_string_expr (e : LevelExpr.t) : string := let '(l, n) := e in Level.to_string l ^ (if n is Z0 then "" else "+" ^ string_of_Z n). Definition print_premise (l : premises) : string := - let (e, exprs) := NonEmptySetFacts.to_nonempty_list l in + let (e, exprs) := to_nonempty_list l in to_string_expr e ^ match exprs with | [] => "" @@ -354,16 +354,16 @@ Proof. red in inclv. eapply clauses_levels_spec. exists cl. split => //. eapply clause_levels_spec. destruct inclv as [[? []]|]. - + left. eapply levelexprset_levels_spec. now eexists. + + left. eapply levels_spec. now eexists. + right. intuition. * have [_ ho] := valid_model_only_model _ _ _ _ m hincl k. forward ho by now exists v. now right. Qed. -Lemma in_levels le prems : LevelExprSet.In le prems -> LevelSet.In le (levels prems). +Lemma in_levels le prems : LevelExprSet.In le prems -> LevelSet.In le.1 (levels prems). Proof. destruct le. intros hin. - apply levelexprset_levels_spec. now exists z. + apply levels_spec. now exists z. Qed. Lemma min_model_map_enabled m cls cls' : @@ -379,10 +379,10 @@ Proof. - intros hin; rewrite /enabled_clause. have [hm [incl hext]] := min_model_map_spec cls' m. have [hle [minp [inp ->]]] := min_premise_spec (min_model_map m cls') (premise cl). - move: (incl _ hin). move/(_ minp) => /fwd. + move: (incl _ hin). move/(_ minp.1) => /fwd. { apply clause_levels_spec. left. now apply in_levels. } move=> [k hmap]. - specialize (hm minp k hmap) as [_ hm _]. + specialize (hm minp.1 k hmap) as [_ hm _]. destruct minp. move: hm => /(_ _ hin)/(_ _ inp). intros le; depelim le. exists (y - z). now rewrite /min_atom_value (level_value_MapsTo hmap). @@ -710,13 +710,13 @@ Module LoopChecking (LS : LevelSets). Definition levels := levels. Definition clauses := clauses. - Notation univ := LS.LevelExprSet.nonEmptyLevelExprSet. + Notation univ := NES.t. Inductive constraint_type := UnivEq | UnivLe. Definition constraint := (univ * constraint_type * univ). Definition clauses_of_le l r := - LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) (LevelExprSet.t_set l) Clauses.empty. + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) (NES.t_set l) Clauses.empty. Lemma clauses_of_le_spec l r : forall cl, Clauses.In cl (clauses_of_le l r) <-> diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 30e0513f7..870c049de 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -91,8 +91,11 @@ Ltac rw_in l H := rewrite_strat (topdown l) in H. Module Clauses (LS : LevelSets). Module Export FLS := FromLevelSets LS. + Import NES (t_set, t_ne, level, levels, singleton, add, add_spec, + map, map_spec, add_list, add_list_spec, equal_exprsets). + Coercion t_set : NES.t >-> LevelExprSet.t. - Notation premises := nonEmptyLevelExprSet. + Notation premises := NES.t. Definition clause : Type := premises × LevelExpr.t. Module Clause. @@ -135,9 +138,9 @@ Module Clauses (LS : LevelSets). Definition compare_spec : forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y). Proof. - intros [? ?] [? ?]; cbn; repeat constructor. + intros [n t0] [n0 t1]; cbn; repeat constructor. destruct (LevelExprSet.compare_spec n n0); repeat constructor; tas. - eapply LevelExprSet.eq_leibniz in H. apply NonEmptySetFacts.eq_univ in H. + eapply LevelExprSet.eq_leibniz in H. apply NES.eq_univ in H. subst. cbn in *. destruct (LevelExpr.compare_spec t0 t1); repeat constructor; tas. now subst. Qed. @@ -360,11 +363,11 @@ Module Clauses (LS : LevelSets). exists cl, Clauses.In cl cls /\ (level cl.2) = x. Definition premise_min (l : premises) : Z := - let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + let (hd, tl) := NES.to_nonempty_list l in fold_left (B:=LevelExpr.t) (fun min atom => Z.min atom.2 min) tl (hd.2). Definition premise_max (l : premises) : Z := - let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + let (hd, tl) := NES.to_nonempty_list l in fold_left (B:=LevelExpr.t) (fun min atom => Z.max atom.2 min) tl (hd.2). Definition max_clause_premise (cls : clauses) := @@ -713,23 +716,23 @@ Module Clauses (LS : LevelSets). Definition of_level_set (ls : LevelSet.t) n (hne : ~ LevelSet.Empty ls) : premises := {| t_set := levelexprset_of_levels ls n |}. Next Obligation. - apply not_Empty_is_empty => he. apply hne. + apply NES.not_Empty_is_empty => he. apply hne. intros l nin. specialize (he (l,n)). apply he. now rewrite levelexprset_of_levels_spec. Qed. Lemma of_level_set_union_spec {ls ls' n hne} hne' hne'' : of_level_set (ls ∪ ls') n hne = - univ_union (of_level_set ls n hne') (of_level_set ls' n hne''). + NES.univ_union (of_level_set ls n hne') (of_level_set ls' n hne''). Proof. - apply eq_univ_equal. + apply NES.equal_exprsets. intros [l k]. rewrite /of_level_set //= !levelexprset_of_levels_spec LevelExprSet.union_spec. rewrite !levelexprset_of_levels_spec LevelSet.union_spec. clear. firstorder. Qed. Lemma of_level_set_singleton l k hne : of_level_set (LevelSet.singleton l) k hne = singleton (l, k). Proof. - apply eq_univ_equal. move=> [l' k']. + apply NES.equal_exprsets. move=> [l' k']. rewrite /of_level_set //= levelexprset_of_levels_spec !LevelExprSet.singleton_spec LevelSet.singleton_spec /LevelSet.E.eq /LevelExprSet.E.eq. firstorder subst => //. now noconf H. now noconf H. Qed. @@ -764,9 +767,9 @@ Module Clauses (LS : LevelSets). intros hs''. destruct x. apply hadd in hs'' as []. * noconf H. cbn. move/max_premise_of_spec. - intros h; etransitivity; tea. destruct (max_premise_of l n), a; cbn; constructor; lia. + intros h; etransitivity; tea. destruct (max_premise_of l t), a; cbn; constructor; lia. * intros h; specialize (hle H h). depelim hle. cbn. - destruct (max_premise_of l n); cbn; constructor; lia. + destruct (max_premise_of l t); cbn; constructor; lia. Qed. Definition max_clause_premises cls := @@ -808,7 +811,7 @@ Module Clauses (LS : LevelSets). Lemma add_expr_add_expr n n' lk : add_expr n (add_expr n' lk) = add_expr (n + n') lk. Proof. destruct lk; unfold add_expr. f_equal; lia. Qed. - Definition add_prems n s := map (add_expr n) s. + Definition add_prems n s := NES.map (add_expr n) s. Lemma In_add_prems k (prems : premises): forall le, LevelExprSet.In le (add_prems k prems) <-> @@ -827,8 +830,8 @@ Module Clauses (LS : LevelSets). Lemma add_prems_inj n prems prems' : add_prems n prems = add_prems n prems' -> prems = prems'. Proof. - rewrite /add_prems => /eq_univ_equal hm. - apply eq_univ_equal. + rewrite /add_prems => /NES.equal_exprsets hm. + apply NES.equal_exprsets. intros [l k]. specialize (hm (l, k + n)). rewrite !map_spec in hm. destruct hm as [hl hr]. split; intros hin. @@ -853,7 +856,7 @@ Module Clauses (LS : LevelSets). Lemma add_prems_add_prems n n' lk : add_prems n (add_prems n' lk) = add_prems (n + n') lk. Proof. destruct lk; unfold add_prems. - rewrite map_map. apply eq_univ_equal. + rewrite NES.map_map. apply NES.equal_exprsets. intros x. rewrite !map_spec. cbn in *. firstorder eauto. subst. exists x0. firstorder eauto. now rewrite add_expr_add_expr. @@ -863,7 +866,7 @@ Module Clauses (LS : LevelSets). Lemma add_prems_add {n lk prems} : add_prems n (add lk prems) = add (add_expr n lk) (add_prems n prems). Proof. - apply eq_univ_equal. intros x. + apply NES.equal_exprsets. intros x. rewrite In_add_prems LevelExprSet.add_spec In_add_prems /LevelExprSet.E.eq; rw LevelExprSet.add_spec. firstorder. subst. red in H; subst x0. now left. Qed. @@ -871,7 +874,7 @@ Module Clauses (LS : LevelSets). Lemma add_prems_0 u : add_prems 0 u = u. Proof. rewrite /add_prems. - apply eq_univ_equal. + apply NES.equal_exprsets. intros x. rewrite map_spec. split. - intros[e [hin ->]]. unfold add_expr. now destruct e; rewrite Z.add_0_r. @@ -881,7 +884,7 @@ Module Clauses (LS : LevelSets). Lemma add_prems_of_level_set k W k' prf : add_prems k (of_level_set W k' prf) = of_level_set W (k + k') prf. Proof. - apply eq_univ_equal => [] [l n]. + apply NES.equal_exprsets => [] [l n]. rewrite In_add_prems /of_level_set //= levelexprset_of_levels_spec. split. - move=> [] [l' n']. rewrite levelexprset_of_levels_spec => [] [[inw eq] eq']. @@ -940,21 +943,21 @@ Module Clauses (LS : LevelSets). rewrite clause_levels_spec. cbn. destruct cl; cbn. intros h. apply clauses_levels_spec. exists cl'; split => //. move: h; case. - move/levelexprset_levels_spec => [k]. + move/NES.levels_spec => [k]. destruct cl'; cbn in * => /In_add_prems => [] [] x []. destruct x => hin [=] ->. intros ->. - apply clause_levels_spec. left. apply levelexprset_levels_spec. now exists z. - intros ->. apply clause_levels_spec; right. destruct cl' => //=. destruct t0 => //. + apply clause_levels_spec. left. apply NES.levels_spec. now exists z. + intros ->. apply clause_levels_spec; right. destruct cl' => //=. destruct t2 => //. - move/clauses_levels_spec => [] cl [] hin /clause_levels_spec []. - * move=> /levelexprset_levels_spec => [] [k hin']; exists (add_clause n cl); split => //. + * move=> /NES.levels_spec => [] [k hin']; exists (add_clause n cl); split => //. now apply add_clauses_spec. apply clause_levels_spec. left. - apply levelexprset_levels_spec. exists (k + n). + apply NES.levels_spec. exists (k + n). destruct cl; cbn. apply In_add_prems. exists (l, k). split => //. * intros ->. exists (add_clause n cl); split => //. now apply add_clauses_spec. apply clause_levels_spec. right. - destruct cl; cbn. destruct t => //. + destruct cl; cbn. destruct t0 => //. Qed. Lemma add_clause_0 cl : add_clause 0 cl = cl. @@ -962,8 +965,8 @@ Module Clauses (LS : LevelSets). destruct cl as [prems [concl k]]; cbn. f_equal. 2:now rewrite Z.add_0_r. unfold add_prems. - eapply eq_univ_equal. intros [l k']. - rewrite NonEmptySetFacts.map_spec. + eapply NES.equal_exprsets. intros [l k']. + rewrite NES.map_spec. unfold add_expr. split. - intros [[] [hin heq]]. noconf heq. now rewrite Z.add_0_r. - exists (l, k'); split => //. now rewrite Z.add_0_r. @@ -972,14 +975,14 @@ Module Clauses (LS : LevelSets). Lemma add_clause_singleton n le concl k : add_clause n (singleton le, (concl, k)) = (singleton (add_expr n le), (concl, k + n)). Proof. rewrite /add_clause //=. f_equal. - apply eq_univ_equal. intros le'. rewrite In_add_prems. + apply NES.equal_exprsets. intros le'. rewrite In_add_prems. rewrite_strat (topdown LevelExprSet.singleton_spec). unfold LevelExprSet.E.eq. firstorder. subst. reflexivity. Qed. Lemma add_prems_singleton n cl : add_prems n (singleton cl) = singleton (add_expr n cl). Proof. - apply eq_univ_equal => [] [l k]. + apply NES.equal_exprsets => [] [l k]. rewrite In_add_prems LevelExprSet.singleton_spec. firstorder. - destruct x; noconf H0. @@ -1059,7 +1062,7 @@ Module Clauses (LS : LevelSets). destruct hex. destruct H as [l' [hin heq]]. subst mp. - eexists; split => //. - destruct H as [nein ->]. elim nein. - now eapply levelexprset_levels_spec in hexi. + now eapply NES.levels_spec in hexi. Qed. Variant in_pred_closure cls : clause -> Prop := @@ -1091,7 +1094,7 @@ Module Clauses (LS : LevelSets). LevelExprSet.Equal prems prems' -> in_pred_closure cls (prems, concl) -> in_pred_closure cls (prems', concl). Proof. - intros eq. apply NonEmptySetFacts.eq_univ_equal in eq. now subst prems. + intros eq. apply NES.equal_exprsets in eq. now subst prems. Qed. Lemma entails_equal cls (prems prems' : premises) concl : @@ -1100,7 +1103,7 @@ Module Clauses (LS : LevelSets). Proof. intros he en. replace prems' with prems => //. - now apply eq_univ_equal. + now apply NES.equal_exprsets. Qed. Lemma entails_plus cls c : entails cls c -> entails (succ_clauses cls) (succ_clause c). @@ -1115,7 +1118,7 @@ Module Clauses (LS : LevelSets). now rewrite Z.add_1_r Z.add_1_l. } constructor. now rewrite -add_clauses_spec. * have eq : (succ_prems (singleton (x, (k + 1)))) = (singleton (x, k + 1 + 1)). - { apply eq_univ_equal. unfold succ_prems. + { apply NES.equal_exprsets. unfold succ_prems. intros le. rewrite map_spec LevelExprSet.singleton_spec. split. { intros [? [hin ->]]. @@ -1127,8 +1130,8 @@ Module Clauses (LS : LevelSets). rewrite eq. constructor 2. + unfold succ_clause in IHentails. eapply entails_equal; tea. - intros x. rewrite /succ_prems. rewrite map_spec add_spec. - setoid_rewrite add_spec. rewrite map_spec. + intros x. rewrite /succ_prems. rewrite NES.map_spec NES.add_spec. + setoid_rewrite NES.add_spec. rewrite map_spec. firstorder eauto. subst. now left. + intros x. rewrite /succ_prems !map_spec. intros [e [hin ->]]. exists e. firstorder. @@ -1212,9 +1215,9 @@ Module Clauses (LS : LevelSets). now rewrite /premises_of_level_set LevelSetProp.fold_empty. Qed. - Lemma in_succ_add_premises {V u x k} : LevelExprSet.In (x, Z.of_nat (k + 1)) (add_list (premises_of_level_set V) u) -> LevelExprSet.In (x, Z.of_nat (k + 1)) u. + Lemma in_succ_add_premises {V u x k} : LevelExprSet.In (x, Z.of_nat (k + 1)) (NES.add_list (premises_of_level_set V) u) -> LevelExprSet.In (x, Z.of_nat (k + 1)) u. Proof. - rewrite add_list_spec. intros [hn|hn] => //. + rewrite NES.add_list_spec. intros [hn|hn] => //. eapply premises_of_level_set_spec in hn as []. lia. Qed. @@ -1272,17 +1275,18 @@ Module Clauses (LS : LevelSets). intros H. depind H. - constructor. apply LevelExprSet.add_spec. now right. - eapply (clause_cut _ _ concl'); tea. - rewrite add_comm. apply IHentails. + rewrite NES.add_comm. apply IHentails. intros x; rewrite LevelExprSet.add_spec. firstorder. Qed. + Import NES (univ_union, univ_union_add_distr, univ_union_add_distr, univ_union_comm, univ_union_add_singleton). Lemma entails_weak_union {cls prem concl concl'} : entails cls (prem, concl) -> - entails cls (univ_union concl' prem, concl). + entails cls (NES.univ_union concl' prem, concl). Proof. intros hyp. move: concl'. - apply: premises_elim. + apply: NES.elim. - intros le. rewrite univ_union_comm univ_union_add_singleton. now apply entails_weak. - intros le prems ih. @@ -1360,13 +1364,13 @@ Module Clauses (LS : LevelSets). { red in H0; subst concl0. now constructor. } { now constructor. } * have eq : prems = add concl0 prems. - { eapply eq_univ_equal. intros x; rewrite LevelExprSet.add_spec. firstorder. now red in H2; subst. } + { eapply NES.equal_exprsets. intros x; rewrite LevelExprSet.add_spec. firstorder. now red in H2; subst. } rewrite -eq in H1. eapply (clause_cut _ prems' _ prems). tea. 2:tea. now rewrite -eq in he. - intros he. eapply clause_cut. tea. eapply IHentails. - rewrite add_comm. now eapply entails_weak. + rewrite NES.add_comm. now eapply entails_weak. exact H1. Qed. @@ -1376,7 +1380,7 @@ Module Clauses (LS : LevelSets). entails cls (prems, concl). Proof. revert prems' prems concl. - apply: premises_elim. + apply: NES.elim. - intros. specialize (H le). forward H by now apply LevelExprSet.singleton_spec. cbn in H. eapply entails_add; tea. @@ -1452,7 +1456,7 @@ Module Clauses (LS : LevelSets). Proof. intros l r. rewrite /entails_all. - intros x. rewrite univ_union_spec. intros []. now apply l. now apply r. + intros x. rewrite NES.univ_union_spec. intros []. now apply l. now apply r. Qed. Lemma entails_all_union {cls prems concl prems' concl'} : diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index e25a4fdfe..90b0a4397 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -2,7 +2,7 @@ From Stdlib Require Import ssreflect ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils. +From MetaRocq.Utils Require Import utils NonEmptyLevelExprSet. From MetaRocq.Common Require Universes. From MetaRocq.Common Require Import LoopChecking.Common. @@ -44,27 +44,29 @@ Module Type FMapOTInterface (E : UsualOrderedType). Include FMapInterface.Sfun OT. End FMapOTInterface. +Module Q <: Quantity. + Include OrdersEx.Z_as_OT. + Definition reflect_eq : ReflectEq t := _. + Definition eq_leibniz x y : eq x y -> x = y := fun e => e. +End Q. + Module Type LevelSets. (* Signature of levels: decidable, ordered type *) - Declare Module Level : LevelOrderedTypeWithReflect. + Declare Module Level : OrderedTypeWithLeibnizWithReflect. Declare Module LevelSet : LevelSet_fun Level. - Declare Module LevelExpr : LevelExprItf Level. - Declare Module LevelExprSet : LevelExprSet_fun Level LevelExpr. + Declare Module LevelExpr : LevelExprT Level Q. + Declare Module LevelExprSet : LevelExprSet_fun Level Q LevelExpr. Declare Module LevelMap : FMapOTInterface Level. End LevelSets. Module FromLevelSets (LS : LevelSets). Export LS. -Definition level (e : LevelExpr.t) : Level.t := fst e. -Coercion level : LevelExpr.t >-> Level.t. -Extraction Inline level. - -Definition levels (e : LevelExprSet.t) := -LevelExprSet.fold (fun le => LevelSet.add (level le)) e LevelSet.empty. -Export LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). +Module NES := NonEmptyLevelExprSet Level Q LevelSet LevelExpr LevelExprSet. +Import NES. -Existing Instance Level.reflect_eq. +#[export] Existing Instance Level.reflect_eq. +#[export] Existing Instance NES.reflect_eq. Module LevelSetFact := WFactsOn Level LevelSet. Module LevelSetProp := WPropertiesOn Level LevelSet. @@ -95,36 +97,10 @@ Definition print_lset (l : LevelSet.t) := Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. Module LevelExprSetProp := WPropertiesOn LevelExpr LevelExprSet. -(* We have decidable equality w.r.t leibniz equality for sets of levels. *) -#[global, program] Instance levelexprset_reflect : ReflectEq LevelExprSet.t := - { eqb := LevelExprSet.equal }. -Next Obligation. - destruct (LevelExprSet.equal x y) eqn:e; constructor. - eapply LevelExprSet.equal_spec in e. - now eapply LevelExprSet.eq_leibniz. - intros e'. - subst y. - pose proof (@LevelExprSetFact.equal_1 x x). - forward H. reflexivity. congruence. -Qed. - #[global] Instance levelexprset_eq_dec : Classes.EqDec LevelExprSet.t := Classes.eq_dec. -Derive NoConfusion for LevelExprSet.nonEmptyLevelExprSet. - -(* We use uip on the is_empty condition *) -#[global, program] Instance nonEmptyLevelExprSet_reflect : ReflectEq nonEmptyLevelExprSet := - { eqb x y := eqb x.(t_set) y.(t_set) }. -Next Obligation. - destruct (eqb_spec (t_set x) (t_set y)); constructor. - destruct x, y; cbn in *. subst. - now rewrite (uip t_ne0 t_ne1). - intros e; subst x; apply H. - reflexivity. -Qed. +Derive NoConfusion for NES.t. -(** This coercion allows to see the non-empty set as a regular [LevelExprSet.t] *) -Coercion t_set : nonEmptyLevelExprSet >-> LevelExprSet.t. Module LevelExprSetDecide := WDecide (LevelExprSet). Ltac lesets := LevelExprSetDecide.fsetdec. @@ -163,251 +139,6 @@ Proof. now apply LevelSet.choose_spec2 in ch. Qed. -Module NonEmptySetFacts. - #[program] Definition singleton (e : LevelExpr.t) : nonEmptyLevelExprSet - := {| t_set := LevelExprSet.singleton e |}. - Next Obligation. - apply negbTE. - eapply (contra_notN (P := LevelExprSet.Empty (LevelExprSet.singleton e))). - apply LevelExprSetFact.is_empty_2. intros ne. red in ne. specialize (ne e). lesets. - Qed. - - Lemma not_Empty_is_empty s : - ~ LevelExprSet.Empty s <-> LevelExprSet.is_empty s = false. - Proof. - split. - - intro H. apply not_true_is_false. intro H'. - apply H. now apply LevelExprSetFact.is_empty_2 in H'. - - intros H he. red in he. apply negbT in H. unshelve eapply (contraNnot _ H). - 3:exact he. intros ha. now apply LevelExprSetFact.is_empty_1. - Qed. - - Program Definition add (e : LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet - := {| t_set := LevelExprSet.add e u |}. - Next Obligation. - apply not_Empty_is_empty; intro H. - eapply H. eapply LevelExprSet.add_spec. - left; reflexivity. - Qed. - - Lemma add_spec e u e' : - LevelExprSet.In e' (add e u) <-> e' = e \/ LevelExprSet.In e' u. - Proof. - apply LevelExprSet.add_spec. - Qed. - - Definition add_list : list LevelExpr.t -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet - := List.fold_left (fun u e => add e u). - - Lemma add_list_spec l u e : - LevelExprSet.In e (add_list l u) <-> In e l \/ LevelExprSet.In e u. - Proof. - unfold add_list. rewrite <- fold_left_rev_right. - etransitivity. 2:{ eapply or_iff_compat_r. etransitivity. - 2: apply @InA_In_eq with (A:=LevelExpr.t). - eapply InA_rev. } - induction (List.rev l); cbn. - - split. intuition. intros [H|H]; tas. invs H. - - split. - + intro H. apply add_spec in H. destruct H as [H|H]. - * left. now constructor. - * apply IHl0 in H. destruct H as [H|H]; [left|now right]. - now constructor 2. - + intros [H|H]. inv H. - * apply add_spec; now left. - * apply add_spec; right. apply IHl0. now left. - * apply add_spec; right. apply IHl0. now right. - Qed. - - Lemma elements_not_empty {u : nonEmptyLevelExprSet} : LevelExprSet.elements u <> []. - Proof. - rewrite -LevelExprSetProp.elements_Empty. - move/LevelExprSetFact.is_empty_1. - destruct u as [u1 u2]; cbn in *. congruence. - Qed. - - Equations to_nonempty_list (u : nonEmptyLevelExprSet) : LevelExpr.t * list LevelExpr.t := - | u with inspect (LevelExprSet.elements u) := { - | exist [] eqel => False_rect _ (elements_not_empty eqel) - | exist (e :: l) _ => (e, l) }. - - Lemma singleton_to_nonempty_list e : to_nonempty_list (singleton e) = (e, []). - Proof. - funelim (to_nonempty_list (singleton e)). bang. - clear H. - pose proof (LevelExprSet.singleton_spec e1 e). - rewrite LevelExprSetFact.elements_iff in H. - rewrite InA_In_eq in H. rewrite e0 in H. - destruct H. forward H. now left. noconf H. f_equal. - pose proof (LevelExprSet.cardinal_spec (LevelExprSet.singleton e1)). rewrite e0 in H. cbn in H. - rewrite LevelExprSetProp.singleton_cardinal in H. - destruct l => //. - Qed. - - Lemma to_nonempty_list_spec u : - let '(e, u') := to_nonempty_list u in - e :: u' = LevelExprSet.elements u. - Proof. - funelim (to_nonempty_list u). bang. now rewrite e0. - Qed. - - Lemma to_nonempty_list_spec' u : - (to_nonempty_list u).1 :: (to_nonempty_list u).2 = LevelExprSet.elements u. - Proof. - pose proof (to_nonempty_list_spec u). - now destruct (to_nonempty_list u). - Qed. - - Lemma In_to_nonempty_list (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : - LevelExprSet.In e u - <-> e = (to_nonempty_list u).1 \/ In e (to_nonempty_list u).2. - Proof. - etransitivity. symmetry. apply LevelExprSet.elements_spec1. - pose proof (to_nonempty_list_spec' u) as H. - destruct (to_nonempty_list u) as [e' l]; cbn in *. - rewrite <- H; clear. etransitivity. apply InA_cons. - eapply or_iff_compat_l. apply InA_In_eq. - Qed. - - Lemma In_to_nonempty_list_rev (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : - LevelExprSet.In e u - <-> e = (to_nonempty_list u).1 \/ In e (List.rev (to_nonempty_list u).2). - Proof. - etransitivity. eapply In_to_nonempty_list. - apply or_iff_compat_l. apply in_rev. - Qed. - - - Program Definition non_empty_union (u v : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := - {| t_set := LevelExprSet.union u v |}. - Next Obligation. - apply not_Empty_is_empty; intro H. - assert (HH: LevelExprSet.Empty u). { - intros x Hx. apply (H x). - eapply LevelExprSet.union_spec. now left. } - apply LevelExprSetFact.is_empty_1 in HH. - rewrite t_ne in HH; discriminate. - Qed. - - - Lemma eq_univ (u v : nonEmptyLevelExprSet) : - u = v :> LevelExprSet.t -> u = v. - Proof. - destruct u as [u1 u2], v as [v1 v2]; cbn. intros X; destruct X. - now rewrite (uip_bool _ _ u2 v2). - Qed. - - Lemma eq_univ_equal (u v : nonEmptyLevelExprSet) : - LevelExprSet.Equal u v <-> u = v. - Proof. - split. - - intro H. now apply eq_univ, LevelExprSet.eq_leibniz. - - intros ->; reflexivity. - Qed. - - Lemma eq_univ_elements (u v : nonEmptyLevelExprSet) : - LevelExprSet.elements u = LevelExprSet.elements v -> u = v. - Proof. - intro H. apply eq_univ. - destruct u as [u1 u2], v as [v1 v2]; cbn in *; clear u2 v2. - eapply LevelExprSet.eq_leibniz. red. - intros x. rewrite -!LevelExprSet.elements_spec1 H //. - Qed. - - Lemma univ_expr_eqb_true_iff (u v : nonEmptyLevelExprSet) : - LevelExprSet.equal u v <-> u = v. - Proof. - split. - - intros. - apply eq_univ_equal. now apply LevelExprSet.equal_spec. - - intros ->. now apply LevelExprSet.equal_spec. - Qed. - - Lemma univ_expr_eqb_comm (u v : nonEmptyLevelExprSet) : - LevelExprSet.equal u v <-> LevelExprSet.equal v u. - Proof. - transitivity (u = v). 2: transitivity (v = u). - - apply univ_expr_eqb_true_iff. - - split; apply eq_sym. - - split; apply univ_expr_eqb_true_iff. - Qed. - - - Lemma LevelExprSet_for_all_false f u : - LevelExprSet.for_all f u = false -> LevelExprSet.exists_ (negb ∘ f) u. - Proof. - intro H. rewrite LevelExprSetFact.exists_b. - rewrite LevelExprSetFact.for_all_b in H. - all: try now intros x y []. - induction (LevelExprSet.elements u); cbn in *; [discriminate|]. - apply andb_false_iff in H; apply orb_true_iff; destruct H as [H|H]. - left; now rewrite H. - right; now rewrite IHl. - Qed. - - Lemma LevelExprSet_For_all_exprs (P : LevelExpr.t -> Prop) (u : nonEmptyLevelExprSet) - : LevelExprSet.For_all P u - <-> P (to_nonempty_list u).1 /\ Forall P (to_nonempty_list u).2. - Proof. - etransitivity. - - eapply iff_forall; intro e. eapply imp_iff_compat_r. - apply In_to_nonempty_list. - - cbn; split. - + intro H. split. apply H. now left. - apply Forall_forall. intros x H0. apply H; now right. - + intros [H1 H2] e [He|He]. subst e; tas. - eapply Forall_forall in H2; tea. - Qed. - - Lemma add_comm {le le' e} : add le (add le' e) = add le' (add le e). - Proof. - apply eq_univ_equal. intros x. - rewrite !LevelExprSet.add_spec. firstorder. - Qed. - - #[program] - Definition univ_union (prems prems' : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := - {| t_set := LevelExprSet.union prems prems' |}. - Next Obligation. - destruct prems, prems'; cbn. - destruct (LevelExprSet.is_empty (LevelExprSet.union _ _)) eqn:ise => //. - eapply LevelExprSetFact.is_empty_2 in ise. - eapply not_Empty_is_empty in t_ne0, t_ne1. - destruct t_ne0. lesets. - Qed. - - Lemma univ_union_spec u u' l : - LevelExprSet.In l (univ_union u u') <-> - LevelExprSet.In l u \/ LevelExprSet.In l u'. - Proof. - destruct u, u'; unfold univ_union; cbn. - apply LevelExprSet.union_spec. - Qed. - - Lemma univ_union_add_singleton u le : univ_union u (singleton le) = add le u. - Proof. - apply eq_univ_equal. - intros x. rewrite univ_union_spec LevelExprSet.singleton_spec add_spec. - intuition auto. - Qed. - - Lemma univ_union_comm {u u'} : univ_union u u' = univ_union u' u. - Proof. - apply eq_univ_equal. - intros x. rewrite !univ_union_spec. - intuition auto. - Qed. - - Lemma univ_union_add_distr {le u u'} : univ_union (add le u) u' = add le (univ_union u u'). - Proof. - apply eq_univ_equal. - intros x. rewrite !univ_union_spec !add_spec !univ_union_spec. - intuition auto. - Qed. - -End NonEmptySetFacts. -Export NonEmptySetFacts. - Lemma diff_eq U V : LevelSet.diff V U =_lset V <-> LevelSet.inter V U =_lset LevelSet.empty. Proof. split. lsets. lsets. Qed. @@ -452,7 +183,7 @@ Lemma levels_exprs_non_W_atoms {W prem} : LevelSet.Equal (levels (non_W_atoms W prem)) (LevelSet.diff (levels prem) W). Proof. intros e. unfold non_W_atoms. - rewrite levelexprset_levels_spec LevelSet.diff_spec levelexprset_levels_spec. + rewrite levels_spec LevelSet.diff_spec levels_spec. firstorder eauto. rewrite LevelExprSet.filter_spec in H. now exists x. rewrite LevelExprSet.filter_spec in H. destruct H. @@ -468,8 +199,8 @@ Proof. split. - intros he. intros l hin. - eapply levelexprset_levels_spec in hin as [k hin]. lesets. - - intros emp l hin. eapply emp. eapply (levelexprset_levels_spec l.1). exists l.2. + eapply levels_spec in hin as [k hin]. lesets. + - intros emp l hin. eapply emp. eapply (levels_spec l.1). exists l.2. now destruct l. Qed. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 0955e8be0..d78267155 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -78,6 +78,8 @@ Set Equations Transparent. Module Model (LS : LevelSets). Module Export Clauses := Clauses(LS). + Export NES. + Import Init.Logic (eq). Definition model := LevelMap.t (option Z). Definition equal_model (m m' : model) := LevelMap.Equal m m'. @@ -157,7 +159,7 @@ Module Model (LS : LevelSets). end. Definition min_premise (m : model) (l : premises) : option Z := - let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + let (hd, tl) := to_nonempty_list l in fold_left (fun min atom => option_map2 Z.min (min_atom_value m atom) min) tl (min_atom_value m hd). Definition satisfiable_atom (m : model) (atom : Level.t * Z) : bool := @@ -250,7 +252,7 @@ Module Model (LS : LevelSets). if LevelSet.is_empty upd then minit =m m else strictly_updates cls upd minit m. - #[export] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. + #[export] Instance level_value_proper : Proper (equal_model ==> Logic.eq ==> Logic.eq) level_value. Proof. intros x y eqm l ? <-. unfold level_value. unfold equal_model in eqm. @@ -264,14 +266,14 @@ Module Model (LS : LevelSets). now rewrite hl. Qed. - #[export] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. + #[export] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> Logic.eq ==> Logic.eq) min_atom_value. Proof. intros m m' eqm ? ? ->. unfold min_atom_value. destruct y => //. now rewrite eqm. Qed. - #[export] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. + #[export] Instance min_premise_proper : Proper (LevelMap.Equal ==> Logic.eq ==> Logic.eq) min_premise. Proof. intros m m' eq ? ? ->. unfold min_premise. @@ -279,7 +281,7 @@ Module Model (LS : LevelSets). now setoid_rewrite eq. Qed. - #[export] Instance level_value_above_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> eq) level_value_above. + #[export] Instance level_value_above_proper : Proper (LevelMap.Equal ==> Logic.eq ==> Logic.eq ==> Logic.eq) level_value_above. Proof. intros m m' hm ? ? -> ? ? ->. unfold level_value_above. @@ -330,7 +332,7 @@ Module Model (LS : LevelSets). now for compatible predicates *) Lemma strictly_updates_elim : forall (cls : Clauses.t) (P : LevelSet.t -> model -> model -> Prop) - (HP : Proper (LevelSet.Equal ==> eq ==> eq ==> iff) P), + (HP : Proper (LevelSet.Equal ==> Logic.eq ==> Logic.eq ==> iff) P), (forall m cl m', Clauses.In cl cls -> strict_update m cl m' -> P (LevelSet.singleton (clause_conclusion cl)) m m') -> (forall (ls ls' : LevelSet.t) (m m' m'' : model), @@ -457,7 +459,7 @@ Module Model (LS : LevelSets). - intros [] => //=. - intros [] [] [] => //=. cbn in *. split; now symmetry. - intros [] [] [] [] [] => //=; cbn in *. split. - now transitivity t1. now transitivity t2. + now transitivity t2. now transitivity t3. Qed. Definition eqwm_list (x y : list Level.t * LevelMap.t (option Z)) := @@ -469,7 +471,7 @@ Module Model (LS : LevelSets). - intros [] => //=. - intros [] [] [] => //=. cbn in *. split; now symmetry. - intros [] [] [] [] [] => //=; cbn in *. split. - now transitivity l0. now transitivity t0. + now transitivity l0. now transitivity t1. Qed. Lemma update_value_valid {m cl} : @@ -597,7 +599,7 @@ Module Model (LS : LevelSets). intros [prems [concl k]] ? <- [] [] eq. set (cl := (prems, (concl, k))) in *. cbn. destruct eq as [eql eqm]. cbn in *. subst l0. - have equpd := update_value_proper t t0 eqm cl cl eq_refl. + have equpd := update_value_proper t0 t1 eqm cl cl eq_refl. depelim equpd. rewrite H H0. split => //. rewrite H0 H1. split => //. Qed. @@ -649,7 +651,7 @@ Module Model (LS : LevelSets). destruct l => //. forward H0. auto with datatypes. intros [= <- <-]. destruct H0 as [pref [heq su]]. rewrite app_nil_r in heq. subst pref. - exists (LevelSetProp.of_list (t :: l)). split => //. + exists (LevelSetProp.of_list (t0 :: l)). split => //. intros ?. cbn. lsets. Qed. @@ -1095,7 +1097,7 @@ Module Model (LS : LevelSets). forall prems, P prems (min_premise m prems). Proof. intros hs hadd. - eapply premises_elim. + eapply elim. - intros le. rewrite /min_premise. rewrite singleton_to_nonempty_list. cbn. apply hs. - intros le prems hp. now rewrite min_premise_add. @@ -1302,10 +1304,9 @@ Module Model (LS : LevelSets). Qed. Import -(notations) LevelExprSet. - Import NonEmptySetFacts. Definition max_premise_value (m : model) (l : premises) : option Z := - let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in + let (hd, tl) := to_nonempty_list l in fold_left (fun min atom => option_map2 Z.max (levelexpr_value m atom) min) tl (levelexpr_value m hd). Lemma max_premise_value_spec_aux (m : model) s k : @@ -1483,7 +1484,7 @@ Module Model (LS : LevelSets). levels. Proof. intros s s' eq l. - rewrite !levelexprset_levels_spec. + rewrite !levels_spec. firstorder eauto. Qed. @@ -2070,7 +2071,7 @@ Lemma is_update_of_empty cls m : intros hcl. unfold min_premise. funelim (to_nonempty_list prems). bang. clear H. - rw_in levelexprset_levels_spec hcl. + rw_in levels_spec hcl. have -> : min_atom_value m e = min_atom_value m' e. { destruct e as [k l']. rewrite /min_atom_value. rewrite -hcl //. @@ -2097,7 +2098,7 @@ Lemma is_update_of_empty cls m : Proof. intros hin. rewrite (@min_premise_preserved _ m) //. - move=> x. rewrite levelexprset_levels_spec => [] [k] /hin inW. + move=> x. rewrite levels_spec => [] [k] /hin inW. apply levelmap_level_value_eq => k'. rewrite restrict_model_spec. firstorder. Qed. @@ -2192,7 +2193,7 @@ Lemma is_update_of_empty cls m : exists v. split => //. eapply min_premise_restrict with W => //. { intros l k' hp. move/in_restrict_clauses: incl => [] //= _ hsub _. apply hsub. - rewrite levelexprset_levels_spec. now exists k'. } + rewrite levels_spec. now exists k'. } move: above. rewrite /level_value_above /level_value. elim: find_spec => //. @@ -2748,14 +2749,14 @@ Lemma is_update_of_empty cls m : Qed. Definition premise_values (prems : premises) m := - NonEmptySetFacts.map (fun '(l, k) => (l, option_get 0 (level_value m l))) prems. + map (fun '(l, k) => (l, option_get 0 (level_value m l))) prems. Lemma premise_values_spec prems m : forall l k, LevelExprSet.In (l, k) (premise_values prems m) <-> (exists k', LevelExprSet.In (l, k') prems /\ k = option_get 0 (level_value m l)). Proof. rewrite /premise_values. - intros l k. rewrite NonEmptySetFacts.map_spec. + intros l k. rewrite map_spec. firstorder. destruct x. noconf H0. exists z. split => //. exists(l, x); split => //. now rewrite -H0. Qed. @@ -2974,7 +2975,7 @@ Lemma is_update_of_empty cls m : Qed. Lemma interp_prems_singleton V e : - interp_prems V (singleton e) = interp_expr V e. + interp_prems V (NES.singleton e) = interp_expr V e. Proof. rewrite /interp_prems. now rewrite singleton_to_nonempty_list /=. @@ -3053,10 +3054,10 @@ Lemma is_update_of_empty cls m : eexists; split; trea. now apply eq in b0. Qed. - Lemma equivlistA_add le u : let l := to_nonempty_list (add le u) in + Lemma equivlistA_add le u : let l := to_nonempty_list (NES.add le u) in equivlistA eq (l.1 :: l.2) (le :: LevelExprSet.elements u). Proof. - have he := to_nonempty_list_spec (add le u). + have he := to_nonempty_list_spec (NES.add le u). destruct to_nonempty_list. cbn. intros x. rewrite he. rewrite !LevelExprSet.elements_spec1. @@ -3068,7 +3069,7 @@ Lemma is_update_of_empty cls m : Qed. Lemma interp_prems_add V le (u : premises) : - interp_prems V (add le u) = Z.max (interp_expr V le) (interp_prems V u). + interp_prems V (NES.add le u) = Z.max (interp_expr V le) (interp_prems V u). Proof. rewrite 2!interp_prems_elements. erewrite fold_right_interp. 2:apply equivlistA_add. @@ -3080,12 +3081,12 @@ Lemma is_update_of_empty cls m : Qed. Lemma interp_prems_elim (P : premises -> Z -> Prop) V : - (forall le, P (singleton le) (interp_expr V le)) -> - (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (add le u) (Z.max (interp_expr V le) k)) -> + (forall le, P (NES.singleton le) (interp_expr V le)) -> + (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (NES.add le u) (Z.max (interp_expr V le) k)) -> forall u, P u (interp_prems V u). Proof. intros hs hadd. - eapply premises_elim. + eapply elim. - intros le. rewrite interp_prems_singleton. apply hs. - intros le prems ih hnin. rewrite interp_prems_add. now apply hadd. @@ -3213,9 +3214,9 @@ Lemma is_update_of_empty cls m : unfold enabled_clauses. intros x hin. unfold enabled_clause. pose proof (@min_premise_spec (max_clause_premises cls) (premise x)) as [premmin [prem [premin premeq]]]. - have inV : LevelSet.In prem (clauses_levels cls). + have inV : LevelSet.In (level prem) (clauses_levels cls). { rewrite clauses_levels_spec. exists x; split => //. rewrite /clause_levels. - eapply LevelSet.union_spec; left. rewrite levelexprset_levels_spec. exists prem.2. + eapply LevelSet.union_spec; left. rewrite levels_spec. exists prem.2. destruct prem. exact premin. } rewrite premeq. unfold min_atom_value. destruct prem as [l k]. diff --git a/common/theories/LoopChecking/Models.v b/common/theories/LoopChecking/Models.v index a4b1e301a..01562388d 100644 --- a/common/theories/LoopChecking/Models.v +++ b/common/theories/LoopChecking/Models.v @@ -45,7 +45,7 @@ Module Models (LS : LevelSets). firstorder. subst k. red in H; subst. firstorder. left; firstorder. apply clauses_premises_levels_spec in hin as [cl [incl inlev]]. - apply levelexprset_levels_spec in inlev as [k inprem]. + apply levels_spec in inlev as [k inprem]. have hs := max_clause_premise_of_spec l k cls cl incl inprem. depelim hs. now rewrite H3. * intros [[hin' [-> iss]]|]. @@ -114,19 +114,19 @@ Module Models (LS : LevelSets). depelim sp. rewrite eq in H0. noconf H0. lia. * destruct H. elim H. eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. + eapply levels_spec. now exists mink. - unfold level_value in hl. destruct LevelMap.find eqn:hl'. subst o. 2:{ move/LevelMapFact.F.not_find_in_iff: hl'. elim. rewrite premises_model_map_in. left. eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. } + eapply levels_spec. now exists mink. } eapply LevelMap.find_2 in hl'. move/premises_model_map_spec: hl' => [[]|[nin hm]] => //. * now intros hnminp [_ hn]. * move: nin; elim. eapply clauses_premises_levels_spec. exists cl. split => //. - eapply levelexprset_levels_spec. now exists mink. + eapply levels_spec. now exists mink. Qed. Lemma in_premises_model V cl : @@ -190,13 +190,13 @@ Module Models (LS : LevelSets). destruct cl as [prems concl]. pose proof (to_nonempty_list_spec' prems). set (l := (to_nonempty_list prems).1) in *. - have hs := max_clause_premise_of_spec l l.2 cls (prems, concl) hin. + have hs := max_clause_premise_of_spec l.1 l.2 cls (prems, concl) hin. forward hs. cbn. eapply LevelExprSet.elements_spec1; rewrite -H. constructor. destruct l; reflexivity. depelim hs. - exists l, y. apply premises_model_map_spec. left. + exists l.1, y. apply premises_model_map_spec. left. split => //. eapply clauses_premises_levels_spec. eexists; split; tea => //. - rewrite //= levelexprset_levels_spec. exists l.2. + rewrite //= levels_spec. exists l.2. setoid_rewrite <- LevelExprSet.elements_spec1. rewrite -H //=. constructor. destruct l; reflexivity. Qed. @@ -239,7 +239,7 @@ Module Models (LS : LevelSets). Definition min_model_clause cl m := LevelExprSet.fold (fun '(l, k) acc => add_max l (Some k) acc) (premise cl) - (add_max (concl cl) None m). + (add_max (concl cl).1 None m). Definition min_model_map (m : model) cls : model := Clauses.fold min_model_clause cls m. @@ -385,15 +385,15 @@ Module Models (LS : LevelSets). is_max_of_clause_map map l cl a. Proof. intros m. rewrite /is_max_of_clause_map /is_max_of_clause_model. - have h := MapsTo_fold_add_max l (premise cl) (add_max (concl cl) None a). + have h := MapsTo_fold_add_max l (premise cl) (add_max (concl cl).1 None a). change (LevelExprSet.fold (fun '(l, k0) (acc : model) => add_max l (Some k0) acc) (premise cl) - (add_max (concl cl) None a)) with (min_model_clause cl a) in h. + (add_max (concl cl).1 None a)) with (min_model_clause cl a) in h. cbn in h. destruct h. split. - intros k hm. specialize (H k hm) as [[kl []]|[hm' hle]]. * split => //. subst k. red. split. intros kl' hin. constructor. now apply H2. move=> kl' hm''. specialize (H3 kl'). rewrite add_max_spec in H3. forward H3. - destruct (Level.eq_dec l (concl cl)). + destruct (Level.eq_dec l (concl cl).1). { subst l. left. split => //. rewrite max_opt_of_r. apply level_value_MapsTo in hm''. now rewrite hm''. } { right. split => //. } exact H3. left. @@ -410,26 +410,26 @@ Module Models (LS : LevelSets). - intros l' k. destruct H0 as [H0 hext]. specialize (H0 l' k). intros [hm|hinc]. { forward H0. left. rewrite add_max_spec. - destruct (Level.eq_dec l' (concl cl)); eauto. + destruct (Level.eq_dec l' (concl cl).1); eauto. { left. split => //. rewrite max_opt_of_r. now rewrite (level_value_MapsTo hm). } destruct H0 as [? [hinm hle]]. eapply is_higher_mon; tea. exists x. split; eauto. reflexivity. } { red in hinc. destruct hinc. apply H0. now right. destruct H1 as [-> ->]. - destruct (Level.eq_dec l (concl cl)). + destruct (Level.eq_dec l (concl cl).1). red. - destruct (LevelMap.find (concl cl) a) eqn:hl. + destruct (LevelMap.find (concl cl).1 a) eqn:hl. * apply LevelMap.find_2 in hl. - specialize (hext (concl cl) o). + specialize (hext (concl cl).1 o). forward hext. rewrite add_max_spec. left. split => //. rewrite max_opt_of_r. now rewrite (level_value_MapsTo hl). destruct hext as [k' []]. exists k'. split => //. constructor. - * specialize (hext (concl cl) None). + * specialize (hext (concl cl).1 None). forward hext. rewrite add_max_spec. left. split => //. now rewrite /level_value hl. destruct cl; unfold clause_conclusion in *. exact hext. - * specialize (hext (concl cl) (level_value a (concl cl))). + * specialize (hext (concl cl).1 (level_value a (concl cl).1)). forward hext. rewrite add_max_spec. left. split => //. destruct hext as [l' []]; exists l'; split => //. constructor. } Qed. @@ -506,10 +506,10 @@ Module Models (LS : LevelSets). apply hadd in ins'' as [<-|]. * have := min_model_clause_spec l' x a. cbn. intros [_ hm']. eapply clause_levels_spec in inlev as []. - + eapply levelexprset_levels_spec in H as [k' incl]. + + eapply levels_spec in H as [k' incl]. specialize (hm' l' (Some k')). forward hm'. right. left. rewrite /is_in_premise. exists k'; eauto. destruct hm' as [? []]; now eexists. - + subst l'. specialize (hm' (concl x) None). forward hm'. + + subst l'. specialize (hm' (concl x).1 None). forward hm'. right. right. split => //. destruct hm' as [? []]; now eexists. * specialize (ihcls _ H _ inlev) as [k' ina]. @@ -530,7 +530,7 @@ Module Models (LS : LevelSets). intros k' h. specialize (ihcls _ hin' l). forward ihcls. - { eapply clause_levels_spec. left. eapply levelexprset_levels_spec. now exists k'. } + { eapply clause_levels_spec. left. eapply levels_spec. now exists k'. } destruct ihcls as [ka ihcls]. specialize (ih _ _ ihcls) as [ihm ihcls' maxm]. specialize (ihcls' _ hin' _ h). @@ -556,7 +556,7 @@ Module Models (LS : LevelSets). * apply incl. apply clauses_levels_spec. exists cl. split => //. red in incl'. apply clause_levels_spec. - clear -incl'. firstorder. subst. left. apply levelexprset_levels_spec. + clear -incl'. firstorder. subst. left. apply levels_spec. firstorder. * rewrite (om l). now exists x. Qed. diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index 8aac72232..f8f14691f 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -284,7 +284,7 @@ Lemma invalid_clause_measure W cls cl m : defined_model_of W m -> ~~ valid_clause m cl -> Clauses.In cl (cls_diff cls W) -> - (0 < measure_w W cls m (concl cl))%Z. + (0 < measure_w W cls m (concl cl).1)%Z. Proof. intros hwv. unfold valid_clause. destruct cl as [prem [l k]]; cbn. @@ -335,10 +335,10 @@ Proof. assert (k + (maxpreml - (premise_min preml)) = (maxpreml + k - (premise_min preml)))%Z as ->. lia. enough (maxpreml <= (v_minus_w_bound W m))%Z. lia. - { have vm := v_minus_w_bound_spec W m exmax. unfold levelexpr_value in eqmaxpre. + { have vm := v_minus_w_bound_spec W m exmax.1. unfold levelexpr_value in eqmaxpre. rewrite -eqmaxpre in vm. have := (@levels_exprs_non_W_atoms W prem (level exmax)). - rewrite levelexprset_levels_spec => -[] /fwd. + rewrite levels_spec => -[] /fwd. { exists exmax.2. now destruct exmax. } rewrite LevelSet.diff_spec => [] [_ nw] _. specialize (vm nw). depelim vm. lia. } @@ -404,9 +404,9 @@ Proof using. destruct (valid_clause) eqn:vc => //. eapply invalid_clause_measure in dnf; tea. 2:{ rewrite vc //. } - enough (measure_w W cls m (concl cl) = 0). lia. + enough (measure_w W cls m (concl cl).1 = 0). lia. rewrite /measure in hm. - move/(sum_W_0 (concl cl)): hm => /fwd; [|lia]. + move/(sum_W_0 (concl cl).1): hm => /fwd; [|lia]. apply Clauses.diff_spec in hcl as [clw clr]. now eapply in_clauses_with_concl in clw as [clw incls]. Qed. @@ -723,9 +723,9 @@ Proof. all:try eapply levelset_neq in neq. all:have cls_sub := clauses_conclusions_levels cls. all:destruct prf as [clsV mof isupd]. - - red. eapply LevelSet.equal_spec in eq. + - red. eapply LevelSet.equal_spec in eq0. set (prf := check_model_defined_init_map _ _); clearbody prf. - eapply check_model_is_update_of in eqm; tea. rewrite eq in eqm. + eapply check_model_is_update_of in eqm; tea. rewrite eq0 in eqm. destruct eqm as [eqm incl]. rewrite union_idem in eqm. unshelve eapply strictly_updates_entails_on_V in eqm; tea. eapply entails_all_clauses_subset; tea. apply clauses_with_concl_subset. @@ -785,7 +785,7 @@ Proof. eapply is_model_invalid_clause in H; tea. assert (~ LevelSet.In (level (concl cl)) W). { intros hin. rewrite in_clauses_with_concl in H. intuition auto. } - exists (concl cl). split => //. } + exists (concl cl).1. split => //. } rewrite -!diff_cardinal //. clear -w_incl clsV incl wcls_incl. have hincl := clauses_conclusions_levels cls. lsets. lsets. assert (Wcls ⊂_lset V). lsets. eapply strict_subset_cardinal. diff --git a/common/theories/Reflect.v b/common/theories/Reflect.v index e8426d86e..29dff1b44 100644 --- a/common/theories/Reflect.v +++ b/common/theories/Reflect.v @@ -203,7 +203,7 @@ Defined. Definition eqb_ConstraintType x y := match x, y with - | ConstraintType.Le n, ConstraintType.Le m => Z.eqb n m + | ConstraintType.Le, ConstraintType.Le => true | ConstraintType.Eq, ConstraintType.Eq => true | _, _ => false end. @@ -212,8 +212,6 @@ Definition eqb_ConstraintType x y := Proof. refine {| eqb := eqb_ConstraintType |}. destruct x, y; simpl; try constructor; try congruence. - destruct (Z.eqb_spec z z0); constructor. now subst. - cong. Defined. #[global, program] Instance Z_as_int : ReflectEq Int.Z_as_Int.t := @@ -225,7 +223,6 @@ Qed. Scheme level_lt_ind_dep := Induction for Level.lt_ Sort Prop. Scheme level_expr_lt_ind_dep := Induction for LevelExpr.lt_ Sort Prop. Scheme constraint_type_lt_ind_dep := Induction for ConstraintType.lt_ Sort Prop. -Scheme level_constraint_lt_ind_dep := Induction for LevelConstraint.lt_ Sort Prop. Scheme constraint_lt_ind_dep := Induction for UnivConstraint.lt_ Sort Prop. Derive Signature for UnivConstraint.lt_. Derive Signature for le. @@ -286,7 +283,6 @@ Qed. *) Lemma constraint_type_lt_level_irrel {x y} (l l' : ConstraintType.lt_ x y) : l = l'. Proof. induction l using constraint_type_lt_ind_dep; depelim l'; auto. - f_equal. apply uip. Qed. From Stdlib Require Import RelationClasses. @@ -308,23 +304,6 @@ Proof. now rewrite (lt_universe_irrel l l4). Qed. -Lemma levelconstraint_lt_irrel (x y : LevelConstraint.t) (l l' : LevelConstraint.lt_ x y) : l = l'. -Proof. - revert l'. induction l using level_constraint_lt_ind_dep. - - intros l'. depelim l'. - now rewrite (lt_level_irrel l l4). - now elim (irreflexivity (R:=ConstraintType.lt) l4). - now elim (irreflexivity l4). - - intros l'; depelim l'. - now elim (irreflexivity (R:=ConstraintType.lt) l). - now rewrite (constraint_type_lt_level_irrel l l4). - now elim (irreflexivity l4). - - intros l'; depelim l'. - now elim (irreflexivity l). - now elim (irreflexivity l). - now rewrite (lt_level_irrel l l4). -Qed. - Module LevelSetsUIP. Import LevelSet.Raw. @@ -418,16 +397,16 @@ Module ConstraintSetsUIP. - depelim o'. f_equal; auto. clear -l0 l2. red in l0, l2. extensionality y. extensionality inl. - apply levelconstraint_lt_irrel. + apply constraint_lt_irrel. extensionality y. extensionality inl. - apply levelconstraint_lt_irrel. + apply constraint_lt_irrel. Qed. #[global,program] Instance reflect_ConstraintSet : ReflectEq UnivConstraintSet.t := {| eqb := eqb_ConstraintSet |}. Next Obligation. intros [thisx okx] [thisy oky]. - unfold eqb_UnivConstraintSet. cbn. + unfold eqb_ConstraintSet. cbn. cbn -[eqb]. destruct (eqb_spec thisx thisy); subst; constructor. - f_equal. apply ok_irrel. diff --git a/template-rocq/theories/PartialLoopChecking.v b/oldLoopChecking.v similarity index 100% rename from template-rocq/theories/PartialLoopChecking.v rename to oldLoopChecking.v diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v index 410bcb15c..c2e63b3a2 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -83,12 +83,14 @@ End LevelExprZ. Module LevelExprZSet. Include MSetList.MakeWithLeibniz LevelExprZ. - Definition levels (e : t) := - fold (fun le => LevelSet.add (fst le)) e LevelSet.empty. - - Record nonEmptyLevelExprSet - := { t_set : t ; - t_ne : is_empty t_set = false }. + Lemma reflect_eq : ReflectEq t. + Proof. + refine {| eqb := equal |}. + intros x y. have := (equal_spec x y). + destruct equal => //; constructor. + now apply eq_leibniz, H. + intros ->. destruct H. now forward H0 by reflexivity. + Qed. End LevelExprZSet. Module LevelExprZSetFacts := WFactsOn LevelExprZ LevelExprZSet. Module LevelExprZSetProp := MSetProperties.OrdProperties LevelExprZSet. @@ -130,19 +132,6 @@ Proof. + intros hin'. move: (ih hin') => []; split => //. apply hadd; now right. Qed. -Program Definition to_atoms (u : Universe.t) : LevelExprZSet.nonEmptyLevelExprSet := - {| LevelExprZSet.t_set := to_levelexprzset u |}. -Next Obligation. - destruct u. cbn. - destruct (LevelExprZSet.is_empty _) eqn:he => //. - apply LevelExprZSet.is_empty_spec in he. - assert (LevelExprSet.is_empty t_set). - apply LevelExprSet.is_empty_spec. intros x hin. - destruct x. eapply (he (t, Z.of_nat n)). - now apply to_levelexprzset_spec_1. - congruence. -Qed. - Definition from_levelexprzset (u : LS.LevelExprSet.t) : LevelExprSet.t := LS.LevelExprSet.fold (fun '(l, k) => LevelExprSet.add (l, Z.to_nat k)) u LevelExprSet.empty. @@ -173,44 +162,42 @@ Proof. apply hadd. now right. Qed. -Program Definition from_atoms (u : LS.LevelExprSet.nonEmptyLevelExprSet) : Universe.t := - {| LevelExprSet.t_set := from_levelexprzset (LS.LevelExprSet.t_set u) |}. -Next Obligation. - destruct u. cbn. - destruct (LevelExprSet.is_empty _) eqn:he => //. - apply LevelExprSet.is_empty_spec in he. - assert (LevelExprZSet.is_empty t_set). - apply LevelExprZSet.is_empty_spec. intros x hin. - destruct x. eapply (he (t, Z.to_nat z)). - now apply from_levelexprzset_spec. - congruence. -Qed. - Module UnivLoopChecking. Module LoopCheck := LoopChecking LS. + Import LoopCheck.Impl.I. + Program Definition to_atoms (u : Universe.t) : NES.t := + {| NES.t_set := to_levelexprzset u |}. + Next Obligation. + destruct u. cbn. + destruct (LevelExprZSet.is_empty _) eqn:he => //. + apply LevelExprZSet.is_empty_spec in he. + assert (Universes.LevelExprSet.is_empty t_set0). + apply Universes.LevelExprSet.is_empty_spec. intros x hin. + destruct x. eapply (he (t0, Z.of_nat n)). + now apply to_levelexprzset_spec_1. + congruence. + Qed. + + Program Definition from_atoms (u : NES.t) : Universe.t := + {| Universe.t_set := from_levelexprzset (NES.t_set u) |}. + Next Obligation. + apply Universe.NES.not_Empty_is_empty => he. + eapply (NES.not_Empty_is_empty u). apply t_ne. + intros [] hin. + apply from_levelexprzset_spec in hin. now apply he in hin. + Qed. + + Definition to_cstr d := match d with + | ConstraintType.Eq => LoopCheck.UnivEq + | ConstraintType.Le => LoopCheck.UnivLe + end. Definition to_constraint (x : UnivConstraint.t) : LoopCheck.constraint := let '(l, d, r) := x in - let '(l, d, r) := match d with - | ConstraintType.Eq => (l, LoopCheck.UnivEq, r) - | ConstraintType.Le k => - if (k (Universe.make' l, LoopCheck.UnivEq, Universe.make' r) - | ConstraintType.Le k => - if (k Universes.LevelSet.In l (Universes.LevelExprSet.levels u). + LevelSet.In l (levels (to_atoms u)) <-> Universes.LevelSet.In l (Universe.levels u). Proof. - rewrite levelexprset_levels_spec. + rewrite levels_spec. rewrite /in_to_atoms. split. - move=> [] k. move/to_levelexprzset_spec_2 => [] hin _. - apply univ_levels_spec. now eexists. - - rewrite univ_levels_spec => -[] k hin. + apply Universe.levels_spec. now eexists. + - rewrite Universe.levels_spec => -[] k hin. exists (Z.of_nat k). now rewrite (in_to_atoms (l, k)). Qed. @@ -279,12 +266,12 @@ Module UnivLoopChecking. rewrite Nat2Z.id //. Qed. - Definition choose_prems (u : premises) : LevelExpr.t := (NonEmptySetFacts.to_nonempty_list u).1. + Definition choose_prems (u : premises) : LevelExpr.t := (to_nonempty_list u).1. Lemma choose_prems_spec u : LevelExprSet.In (choose_prems u) u. Proof. rewrite /choose_prems. - have hs := NonEmptySetFacts.to_nonempty_list_spec u. - destruct NonEmptySetFacts.to_nonempty_list. cbn. + have hs := to_nonempty_list_spec u. + destruct to_nonempty_list. cbn. rewrite -LevelExprSet.elements_spec1 InA_In_eq -hs. now constructor. Qed. @@ -375,12 +362,12 @@ Module UnivLoopChecking. | exist (Some (inr loop)) eq => Some (inr loop). Proof. - move=> c'. - move/LoopCheck.enforce_clauses: eq. + move/LoopCheck.enforce_clauses: eq0. rewrite /LoopCheck.clauses => ->. rewrite UnivConstraintSet.add_spec => -[]. * move=> ->. clsets. * move=> hin. move: (repr_constraints m c' hin) => h. clsets. - - move/LoopCheck.enforce_clauses: eq. + - move/LoopCheck.enforce_clauses: eq0. rewrite /LoopCheck.clauses => -> c'. rewrite UnivLoopChecking.Clauses.union_spec => -[]. * move/(repr_constraints_inv m c') => [] c2 []. @@ -401,25 +388,25 @@ Module UnivLoopChecking. destruct hex as [le [inl ->]]. cbn in *. destruct hin; auto. subst. left. now apply LoopCheck.Impl.in_levels. - move=> [] hin. - * eapply levelexprset_levels_spec in hin as [k hin]. + * eapply levels_spec in hin as [k hin]. exists (r, (lev, k)). split => //. exists (lev, k). split => //. apply clause_levels_spec. now right. - * eapply levelexprset_levels_spec in hin as [k hin]. + * eapply levels_spec in hin as [k hin]. exists (r, choose_prems l). split => //. exists (choose_prems l). split => //. apply choose_prems_spec. apply clause_levels_spec. left. - apply levelexprset_levels_spec. now exists k. + apply levels_spec. now exists k. Qed. - Lemma univ_in_add n u : Universes.LevelSet.Equal - (Universes.LevelExprSet.levels (Universe.add n u)) - (Universes.LevelExprSet.levels u). + (* Lemma univ_in_add n u : Universes.LevelSet.Equal + (Universe.levels (Universe.add_prems n u)) + (Universe.levels u). Proof. - intros l. rewrite !univ_levels_spec. - rewrite /Universe.add. rw Universes.NonEmptySetFacts.map_spec. - firstorder. destruct x0; noconf H0; cbn. now exists n0. + intros l. rewrite !Universe.levels_spec. + rw Universe.add_spec. + firstorder. subst n. destruct n; noconf H; cbn. now exists n0. exists (n + x), (l, x). split => //. - Qed. + Qed. *) Lemma clauses_levels_union cls cls' : clauses_levels (Clauses.union cls cls') =_lset LevelSet.union (clauses_levels cls) (clauses_levels cls'). @@ -432,8 +419,7 @@ Module UnivLoopChecking. Definition univ_constraint_levels (c : UnivConstraint.t) := let '(l, d, r) := c in - LevelSet.union (Universes.LevelExprSet.levels l) - (Universes.LevelExprSet.levels r). + LevelSet.union (Universe.levels l) (Universe.levels r). Lemma declared_univ_cstr_levels_spec ls c : declared_univ_cstr_levels ls c <-> @@ -458,11 +444,7 @@ Module UnivLoopChecking. Proof. intros l; destruct c as [[l' d] r]; cbn. rewrite /constraint_levels. rewrite !LevelSet.union_spec. cbn. - destruct d. - destruct Z.ltb. - - rewrite !levels_in_to_atoms. rewrite univ_in_add. firstorder. - - rewrite !levels_in_to_atoms. rewrite univ_in_add. firstorder. - - rewrite !levels_in_to_atoms. firstorder. + rewrite !levels_in_to_atoms. firstorder. Qed. Lemma in_to_clauses_levels c : @@ -527,7 +509,7 @@ Module UnivLoopChecking. funelim (enforce m c) => //=. move=> [=] <-; cbn. rewrite /levels //=. split. - - clear H Heqcall. now move/LoopCheck.enforce_levels: eq. + - clear H Heqcall. now move/LoopCheck.enforce_levels: eq0. - clear H Heqcall. reflexivity. Qed. diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v index 2ec15e124..12792d3b3 100644 --- a/utils/theories/NonEmptyLevelExprSet.v +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -255,9 +255,10 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) Definition eq_univ (u v : t) : u = v :> LevelExprSet.t -> u = v := eq_exprsets u v. - Lemma equal_exprsets (u v : t) : LevelExprSet.Equal u v -> u = v. + Lemma equal_exprsets (u v : t) : LevelExprSet.Equal u v <-> u = v. Proof. - intro H. now apply eq_univ, LevelExprSet.eq_leibniz. + split; intro H. now apply eq_univ, LevelExprSet.eq_leibniz. + now subst. Qed. #[deprecated(note = "use equal_exprsets instead")] @@ -328,7 +329,7 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) Lemma add_comm {le le' e} : add le (add le' e) = add le' (add le e). Proof. - apply eq_univ_equal. intros x. + apply equal_exprsets. intros x. rewrite !LevelExprSet.add_spec. firstorder. Qed. @@ -353,21 +354,21 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) Lemma univ_union_add_singleton u le : univ_union u (singleton le) = add le u. Proof. - apply eq_univ_equal. + apply equal_exprsets. intros x. rewrite univ_union_spec LevelExprSet.singleton_spec add_spec. intuition auto. Qed. Lemma univ_union_comm {u u'} : univ_union u u' = univ_union u' u. Proof. - apply eq_univ_equal. + apply equal_exprsets. intros x. rewrite !univ_union_spec. intuition auto. Qed. Lemma univ_union_add_distr {le u u'} : univ_union (add le u) u' = add le (univ_union u u'). Proof. - apply eq_univ_equal. + apply equal_exprsets. intros x. rewrite !univ_union_spec !add_spec !univ_union_spec. intuition auto. Qed. From 970489e55bd3d2aef27723eb9f52f65600eabb09 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sun, 14 Sep 2025 01:39:23 +0200 Subject: [PATCH 053/164] Finally linked to MetaRocq constraints and valuations --- .../theories/LoopChecking/UnivLoopChecking.v | 115 ++++++++++++++---- 1 file changed, 92 insertions(+), 23 deletions(-) diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v index c2e63b3a2..9e76ee982 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -513,31 +513,100 @@ Module UnivLoopChecking. - clear H Heqcall. reflexivity. Qed. + Definition to_valuation (v : LevelMap.t nat) : valuation := + {| valuation_mono := fun s => Pos.of_nat (option_get 0 (LevelMap.find (Level.level s) v)); + valuation_poly := fun i => option_get 0 (LevelMap.find (Level.lvar i) v) + |}. + + Lemma clauses_sem_subset {v cls cls'} : clauses_sem v cls -> cls' ⊂_clset cls -> clauses_sem v cls'. + Proof. + now move=> hall hsub cl /hsub. + Qed. + + Lemma clauses_sem_clauses_of_le V l r : + clauses_sem V (LoopCheck.clauses_of_le l r) -> + (interp_prems V l <= interp_prems V r)%Z. + Proof. + rewrite /clauses_sem. + intros hl. red in hl. + setoid_rewrite LoopCheck.clauses_of_le_spec in hl. + move: l hl. apply: elim. + - move => le he. + rewrite interp_prems_singleton. + move: (he (r, le)) => /fwd. + exists le. split => //. now apply LevelExprSet.singleton_spec. + cbn. lia. + - intros le x ih hnin ih'. + rewrite interp_prems_add. + forward ih. intros x0 [x1 [hin ->]]. + move: (ih' (r, x1)) => /fwd. exists x1. split => //. apply LevelExprSet.add_spec. now right. + auto. + move: (ih' (r, le)) => /fwd. exists le. split => //. apply LevelExprSet.add_spec. now left. + cbn. lia. + Qed. + + Lemma to_atoms_singleton l k : to_atoms (Universe.singleton (l, k)) = singleton (l, Z.of_nat k). + Proof. Admitted. + + Lemma to_atoms_add le u : to_atoms (Universe.add le u) = add (to_atom le) (to_atoms u). + Proof. Admitted. + + Lemma interp_prem_to_atom v le : Z.to_nat (interp_expr v (to_atom le)) = val (to_valuation v) le. + Proof. + destruct le => //=. cbn. + destruct t0. + - (* lzero is forced to have value 0, has it should stay maximal *) todo "handle lzero". + - todo "handle monos". + - cbn. unfold interp_level. destruct LevelMap.find eqn:he => //=. lia. + lia. + Qed. + + Lemma clauses_sem_union v cls cls' : clauses_sem v (Clauses.Clauses.union cls cls') <-> + clauses_sem v cls /\ clauses_sem v cls'. + Proof. + unfold clauses_sem. split. + intros hf. split; eapply clauses_sem_subset; tea; clsets. + intros []. intros cl. rewrite Clauses.Clauses.union_spec. + specialize (H cl). specialize (H0 cl). intros []; auto. + Qed. + + Lemma interp_prems_to_atoms v l : Z.to_nat (interp_prems v (to_atoms l)) = Universes.val (to_valuation v) l. + Proof. + move: l. + apply Universe.elim. + - intros [l k]. + rewrite to_atoms_singleton interp_prems_singleton. + rewrite val_singleton. + now rewrite (interp_prem_to_atom v (l, k)). + - intros le x eq nin. + rewrite to_atoms_add interp_prems_add. + rewrite val_add. + rewrite -interp_prem_to_atom. lia. + Qed. + + Lemma clauses_sem_val m l r : + clauses_sem (LoopCheck.valuation m) (LoopCheck.clauses_of_le (to_atoms l) (to_atoms r)) -> + Universes.val (to_valuation (LoopCheck.valuation m)) l <= Universes.val (to_valuation (LoopCheck.valuation m)) r. + Proof. + move/clauses_sem_clauses_of_le. + have he := interp_prems_to_atoms (LoopCheck.valuation m) l. + have he' := interp_prems_to_atoms (LoopCheck.valuation m) r. lia. + Qed. + Lemma model_satisfies m : - exists V, satisfies - - (* Definition enforce_level_constraints (m : univ_model) (l : UnivConstraintSet.t) := - UnivConstraintSet.fold (fun c m => - match m with - | inl m => - let c := (level_constraint_to_constraint c) in - match LoopCheck.enforce m c with - | None => (inr (c, None)) - | Some (inl m) => (inl m) - | Some (inr u) => (inr (c, Some u)) - end - | inr err => inr err - end) l (inl m). *) + exists V, satisfies V (constraints m). + Proof. + destruct m as [m cstrs repr repr_inv]. cbn. + have val := LoopCheck.model_valuation m. + exists (to_valuation (LoopCheck.valuation m)). + move=> cstr /repr /(clauses_sem_subset val). + intros cls. destruct cstr as [[l []] r]; cbn. + constructor. cbn in cls. now apply clauses_sem_val. + constructor. cbn in cls. + rewrite clauses_sem_union in cls. destruct cls as [hl hr]. + eapply Nat.le_antisymm; now apply clauses_sem_val. + Qed. Import LoopCheck.Impl.I.Model.Model.Clauses.FLS. - Definition of_constraint (c : LoopCheck.constraint) : UnivConstraint.t := - let '(l, d, r) := c in - let d' := match d with - | LoopCheck.UnivLe => ConstraintType.Le 0 - | LoopCheck.UnivEq => ConstraintType.Eq - end - in - (from_atoms l, d', from_atoms r). - End UnivLoopChecking. From 72735745f5bb318cf53bcfb2184285cea9dc3e3d Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 15 Sep 2025 17:25:54 +0200 Subject: [PATCH 054/164] Finalized completeness proof w.r.t. arbitrary presentations --- common/_RocqProject.in | 1 + common/theories/LoopChecking/Deciders.v | 86 +- common/theories/LoopChecking/HornClauses.v | 396 ++++++- common/theories/LoopChecking/Model.v | 7 +- common/theories/Reflect.v | 2 +- common/theories/UnivConstraintType.v | 51 + common/theories/Universes.v | 46 +- .../theories/LoopChecking/UnivLoopChecking.v | 1034 ++++++++++++++++- template-rocq/theories/SemiLattice.v | 33 +- utils/theories/NonEmptyLevelExprSet.v | 8 + 10 files changed, 1485 insertions(+), 179 deletions(-) create mode 100644 common/theories/UnivConstraintType.v diff --git a/common/_RocqProject.in b/common/_RocqProject.in index 992b49d6c..4ff658e4c 100644 --- a/common/_RocqProject.in +++ b/common/_RocqProject.in @@ -1,6 +1,7 @@ -R theories MetaRocq.Common theories/Primitive.v +theories/UnivConstraintType.v # theories/uGraph.v theories/config.v theories/Kernames.v diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 178cf82cc..e3515e895 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -4,7 +4,7 @@ From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils. -From MetaRocq.Common Require Universes. +From MetaRocq.Common Require UnivConstraintType Universes. From Equations Require Import Equations. From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model Models PartialLoopChecking. @@ -17,8 +17,7 @@ Module Type LoopCheckingItf (LS : LevelSets). Parameter model : Type. Parameter univ : Type. - Inductive constraint_type := UnivEq | UnivLe. - Notation constraint := (univ * constraint_type * univ). + Notation constraint := (univ * UnivConstraintType.ConstraintType.t * univ). (* Returns the valuation of the model: a minimal assignement from levels to constraints that make the enforced clauses valid. *) @@ -216,9 +215,9 @@ Definition check_clauses (cls : clauses) (cls' : clauses) : bool := in Clauses.for_all check_one cls'. -(* If a clause checks, then it should be valid in any extension of the model *) +(* If a clause checks, then it is entailed (and will be valid in any extension of the model) *) Theorem check_entails {cls cl} : - check cls cl = Valid -> valid_entailment cls cl. + check cls cl = Valid -> entails cls cl. Proof. destruct cl as [prems [concl k]]. funelim (check cls _) => // _. @@ -226,7 +225,6 @@ Proof. clear Heqcall H. cbn [concl fst snd] in *. clear Heq0. unfold valid_entailment, valid_clause, level_value_above. move/check_atom_value_spec: Heq; intros h; depelim h. rename H into hgt. - intros valuation ext. have vmupd := model_updates v. have vmok := model_ok v. set (pm := premises_model_map _ _) in *. @@ -242,8 +240,7 @@ Proof. have tr := entails_all_trans of_lset ent. eapply (entails_all_satisfies (l := concl0) (k := k)) in tr. 2:{ red. rewrite /level_value he. now constructor. } - eapply clauses_sem_entails in tr ; tea. - now apply tr. + exact tr. Qed. Lemma check_entails_looping {cls cl v isl} : @@ -491,6 +488,11 @@ Module Abstract. intros x hin. now apply Clauses.empty_spec in hin. Qed. + Lemma clauses_levels_declared m : clauses_levels (clauses m) ⊂_lset levels m. + Proof. + exact m.(model).(CorrectModel.clauses_declared). + Qed. + Lemma init_model_levels : levels init_model = LevelSet.empty. Proof. reflexivity. Qed. @@ -688,13 +690,24 @@ Module Abstract. Definition check_clauses m cls := check_clauses (clauses m) cls. - Lemma check_clauses_ok m cls : - check_clauses m cls -> forall V, clauses_sem V (clauses m) -> clauses_sem V cls. + Lemma check_clauses_spec m cls : + check_clauses m cls <-> entails_clauses (clauses m) cls. Proof. - rewrite /check_clauses /Deciders.check_clauses. - move/Clauses.for_all_spec => ha V cs cl /ha. - destruct check eqn:ch => // _. - eapply check_entails in ch. now apply ch. + split. + - rewrite /check_clauses /Deciders.check_clauses. + move/Clauses.for_all_spec => ha cl /ha. + destruct check eqn:ch => // _. + eapply check_entails in ch. now apply ch. + - intros hv. + rewrite /check_clauses /Deciders.check_clauses. + eapply Clauses.for_all_spec; tc => cl hin. + destruct check eqn:hc => //. + * exfalso; eapply check_valid_looping; tea. + 2:eapply m.(model).(model_valid).(model_ok). + eapply enabled_clauses_ext, m.(model).(enabled_model). + eapply (is_update_of_ext m.(model).(model_valid).(I.model_updates)). + * move/check_invalid: hc => he. + exfalso. elim he. now apply hv. Qed. End Abstract. @@ -710,50 +723,37 @@ Module LoopChecking (LS : LevelSets). Definition levels := levels. Definition clauses := clauses. - Notation univ := NES.t. + Lemma clauses_levels_declared m : clauses_levels (clauses m) ⊂_lset levels m. + Proof. + apply clauses_levels_declared. + Qed. - Inductive constraint_type := UnivEq | UnivLe. - Definition constraint := (univ * constraint_type * univ). + Notation univ := NES.t. - Definition clauses_of_le l r := - LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) (NES.t_set l) Clauses.empty. + Import UnivConstraintType.ConstraintType (t, Le, Eq). - Lemma clauses_of_le_spec l r : - forall cl, Clauses.In cl (clauses_of_le l r) <-> - LevelExprSet.Exists (fun lk => cl = (r, lk)) l. - Proof. - intros cl; rewrite /clauses_of_le. - eapply LevelExprSetProp.fold_rec. - - move=> s' he; split. clsets. - move=> [] x []; lesets. - - move=> x a s' s'' hin hnin hadd ih. - rewrite Clauses.add_spec. split. - * move=> [->|]. firstorder. - rewrite ih. firstorder. - * move=> [] x' [] /hadd[<-|]; auto. - rewrite ih. right; firstorder. - Qed. + Definition constraint := (univ * UnivConstraintType.ConstraintType.t * univ). Local Definition to_clauses (cstr : constraint) : Clauses.t := let '(l, d, r) := cstr in match d with - | UnivLe => clauses_of_le l r - | UnivEq => Clauses.union (clauses_of_le l r) (clauses_of_le r l) + | Le => clauses_of_le l r + | Eq => clauses_of_eq l r end. Lemma to_clauses_spec l d r : forall cl, Clauses.In cl (to_clauses (l, d, r)) <-> match d with - | UnivLe => LevelExprSet.Exists (fun lk => cl = (r, lk)) l - | UnivEq => LevelExprSet.Exists (fun lk => cl = (r, lk)) l \/ LevelExprSet.Exists (fun rk => cl = (l, rk)) r + | Le => LevelExprSet.Exists (fun lk => cl = (r, lk)) l + | Eq => LevelExprSet.Exists (fun lk => cl = (r, lk)) l \/ LevelExprSet.Exists (fun rk => cl = (l, rk)) r end. Proof. intros cl. destruct d => //=. - - rewrite Clauses.union_spec. + - apply clauses_of_le_spec. + - rewrite /clauses_of_eq Clauses.union_spec. have := clauses_of_le_spec l r cl. have := clauses_of_le_spec r l cl. firstorder. - - apply clauses_of_le_spec. Qed. Definition init_model := Impl.Abstract.init_model. @@ -816,9 +816,9 @@ Module LoopChecking (LS : LevelSets). Definition check m c := Impl.check_clauses m.(Impl.Abstract.clauses) (to_clauses c). - Lemma check_correct {m c} : - check m c -> forall V, clauses_sem V (clauses m) -> clauses_sem V (to_clauses c). - Proof. apply check_clauses_ok. Qed. + Lemma check_spec {m c} : + check m c <-> entails_clauses (clauses m) (to_clauses c). + Proof. apply check_clauses_spec. Qed. (* Returns the valuation of the model: a minimal assignement from levels to constraints that make the enforced clauses valid. *) diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 870c049de..b01988695 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -76,7 +76,7 @@ *) -From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import ssreflect ssrfun ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils. @@ -871,14 +871,19 @@ Module Clauses (LS : LevelSets). firstorder. subst. red in H; subst x0. now left. Qed. + Lemma add_expr_0 e : add_expr 0 e = e. + Proof. + destruct e => //=. lia_f_equal. + Qed. + Lemma add_prems_0 u : add_prems 0 u = u. Proof. rewrite /add_prems. apply NES.equal_exprsets. intros x. rewrite map_spec. split. - - intros[e [hin ->]]. unfold add_expr. now destruct e; rewrite Z.add_0_r. - - intros inu; exists x. split => //. destruct x. now rewrite /add_expr Z.add_0_r. + - intros[e [hin ->]]. now rewrite add_expr_0. + - intros inu; exists x. split => //. now rewrite add_expr_0. Qed. Lemma add_prems_of_level_set k W k' prf : @@ -1082,13 +1087,16 @@ Module Clauses (LS : LevelSets). Definition entails_all cls (prems concls : premises) := LevelExprSet.For_all (fun le => entails cls (prems, le)) concls. - Notation " cls ⊢ prems → concl " := (entails cls (prems, concl)) (at level 20). - Notation " cls ⊢a prems → concl " := (entails_all cls prems concl) (at level 20). + Definition entails_clauses cls cls' := + Clauses.For_all (entails cls) cls'. + + Notation " cls ⊢ prems → concl " := (entails cls (prems, concl)) (at level 70). + Notation " cls ⊢a prems → concl " := (entails_all cls prems concl) (at level 70). Definition entails_equiv cls u u' := cls ⊢a u → u' /\ cls ⊢a u' → u. - Notation "cls '⊢a' u ↔ u'" := (entails_equiv cls u u') (at level 20). + Notation "cls '⊢a' u ↔ u'" := (entails_equiv cls u u') (at level 70). Lemma in_pred_closure_equal cls (prems prems' : premises) concl : LevelExprSet.Equal prems prems' -> @@ -1279,7 +1287,7 @@ Module Clauses (LS : LevelSets). intros x; rewrite LevelExprSet.add_spec. firstorder. Qed. - Import NES (univ_union, univ_union_add_distr, univ_union_add_distr, univ_union_comm, univ_union_add_singleton). + Import NES (univ_union, univ_union_add_distr, univ_union_add_distr, univ_union_assoc, univ_union_spec, univ_union_comm, univ_union_add_singleton). Lemma entails_weak_union {cls prem concl concl'} : entails cls (prem, concl) -> entails cls (NES.univ_union concl' prem, concl). @@ -1294,6 +1302,14 @@ Module Clauses (LS : LevelSets). now eapply entails_weak. Qed. + Lemma add_prems_univ_union {n u u'} : add_prems n (univ_union u u') = univ_union (add_prems n u) (add_prems n u'). + Proof. + apply equal_exprsets => l. + rewrite In_add_prems. + rw univ_union_spec. + rewrite !In_add_prems. firstorder. + Qed. + Lemma entails_all_weak {cls prem concl concl'} : entails_all cls prem concl -> entails_all cls (add concl' prem) concl. @@ -1450,36 +1466,45 @@ Module Clauses (LS : LevelSets). Qed. Lemma entails_all_concl_union {cls prems concl concl'} : - cls ⊢a prems → concl -> - cls ⊢a prems → concl' -> - cls ⊢a prems → univ_union concl concl'. + cls ⊢a prems → univ_union concl concl' <-> + cls ⊢a prems → concl /\ cls ⊢a prems → concl'. Proof. - intros l r. - rewrite /entails_all. - intros x. rewrite NES.univ_union_spec. intros []. now apply l. now apply r. + split; revgoals. + - move=> [] l r. + rewrite /entails_all. + intros x. rewrite NES.univ_union_spec. intros []. now apply l. now apply r. + - intros hu; split; + move=> le hin; move: (hu le) => /fwd //; + now rewrite NES.univ_union_spec. Qed. Lemma entails_all_union {cls prems concl prems' concl'} : - cls ⊢a prems → concl -> - cls ⊢a prems' → concl' -> + cls ⊢a prems → concl -> cls ⊢a prems' → concl' -> cls ⊢a univ_union prems prems' → univ_union concl concl'. Proof. - intros l r. - apply entails_all_concl_union. + move=> l r. + rewrite entails_all_concl_union. split. rewrite univ_union_comm. now eapply entails_all_weak_union. now eapply entails_all_weak_union. Qed. - Lemma entails_all_shift {cls : clauses} {prems concl : premises} (n : Z) : - cls ⊢a prems → concl -> + cls ⊢a prems → concl <-> cls ⊢a add_prems n prems → add_prems n concl. Proof. - intros cla cl. - rewrite In_add_prems => [[le' [hin ->]]]. - eapply (entails_shift (cl := (prems, le'))). - now apply cla in hin. + split. + - intros cla cl. + rewrite In_add_prems => [[le' [hin ->]]]. + eapply (entails_shift (cl := (prems, le'))). + now apply cla in hin. + - intros cla cl incl. + move: (cla (add_expr n cl)) => /fwd. + rewrite In_add_prems. exists cl; split => //. + move/(entails_shift (- n)) => //=. + rewrite !add_prems_add_prems add_expr_add_expr. + have -> : (- n + n = 0) by lia. + now rewrite add_prems_0 //= add_expr_0. Qed. Lemma in_pred_closure_subset {cls cls' prems concl} : @@ -1529,6 +1554,7 @@ Module Clauses (LS : LevelSets). Proof. intros x hin. now constructor. Qed. + Hint Resolve entails_all_tauto : entails. Lemma loop_any_successor cls u n : cls ⊢a u → succ_prems u -> @@ -1538,11 +1564,11 @@ Module Clauses (LS : LevelSets). - auto. - intros ass. specialize (IHn ass). - have sh := entails_all_shift 1 IHn. + apply (entails_all_shift 1) in IHn. eapply entails_all_trans. tea. - rewrite add_prems_add_prems in sh. + rewrite add_prems_add_prems in IHn. have eq : 1 + Z.of_nat (S n) = Z.of_nat (S (S n)) by lia. - now rewrite eq in sh. + now rewrite eq in IHn. Qed. Lemma entails_pred_closure_neg {cls u concl k p} : @@ -1626,4 +1652,322 @@ Module Clauses (LS : LevelSets). now eapply succ_clauses_equiv in ha. Qed. + Lemma entails_all_succ {cls s} : + cls ⊢a succ_prems s → s. + Proof. + intros cl hin. + eapply Clauses.entails_succ; tea. + intros l k hin'. exists (k + 1). split => //; try lia. + eapply In_add_prems. exists (l, k); split => //. + Qed. + + Lemma entails_all_add_n {cls s n} : + cls ⊢a add_prems (Z.of_nat n) s → s. + Proof. + induction n. + - rewrite //= add_prems_0. apply entails_all_tauto. + - have -> : (Z.of_nat (S n) = 1 + Z.of_nat n) by lia. + rewrite -add_prems_add_prems. + eapply entails_all_trans; tea. + apply entails_all_succ. + Qed. + + Definition clauses_of_le l r := + LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) (NES.t_set l) Clauses.empty. + + Lemma clauses_of_le_spec l r : + forall cl, Clauses.In cl (clauses_of_le l r) <-> + LevelExprSet.Exists (fun lk => cl = (r, lk)) l. + Proof. + intros cl; rewrite /clauses_of_le. + eapply LevelExprSetProp.fold_rec. + - move=> s' he; split. clsets. + move=> [] x []; lesets. + - move=> x a s' s'' hin hnin hadd ih. + rewrite Clauses.add_spec. split. + * move=> [->|]. firstorder. + rewrite ih. firstorder. + * move=> [] x' [] /hadd[<-|]; auto. + rewrite ih. right; firstorder. + Qed. + + Infix "∨" := univ_union (at level 58). + Notation succ x := (add_prems 1%Z x). + + Definition clauses_of_eq (u v : NES.t) := + Clauses.union (clauses_of_le u v) (clauses_of_le v u). + + Notation " cls '⊢ℋ' cls' " := (entails_clauses cls cls') (at level 70). (* \mscrH *) + Notation " s ⋞ t " := (clauses_of_le s t) (at level 60). (* \curlyeqprec *) + Notation " s ≡ t " := (clauses_of_eq s t) (at level 60). (* \allequal *) + + Definition le (t u : NES.t) := t ∨ u ≡ u. + + Module Theory. + + Lemma eq_antisym {cls s t} : + cls ⊢ℋ s ≡ t <-> cls ⊢ℋ s ⋞ t /\ cls ⊢ℋ t ⋞ s. + Proof. + rewrite /clauses_of_eq /entails_clauses. + split => [hf|[]]. + - split; intros l; specialize (hf l); + now rewrite Clauses.union_spec in hf. + - intros hl hr l. + now rewrite Clauses.union_spec. + Qed. + + Lemma to_entails_all {cls s t} : + cls ⊢ℋ s ⋞ t <-> cls ⊢a t → s. + Proof. + split. + - intros hs l hin. apply (hs (t, l)). + apply clauses_of_le_spec. now exists l. + - intros ha l. rewrite clauses_of_le_spec. + intros [lk [hin ->]]. now apply ha. + Qed. + + Lemma to_entails_equiv {cls s t} : + cls ⊢ℋ s ≡ t <-> cls ⊢a t ↔ s. + Proof. + rewrite eq_antisym !to_entails_all. + firstorder. + Qed. + + Lemma le_succ_congr {cls s t n} : + cls ⊢ℋ s ⋞ t -> cls ⊢ℋ add_prems n s ⋞ add_prems n t. + Proof. + rewrite !to_entails_all. + eapply entails_all_shift. + Qed. + + Lemma le_succ_inj {cls n s t} : + cls ⊢ℋ add_prems n s ⋞ add_prems n t -> cls ⊢ℋ s ⋞ t. + Proof. + rewrite !to_entails_all. + eapply entails_all_shift. + Qed. + + Lemma succ_inj {cls n s t} : + cls ⊢ℋ add_prems n s ≡ add_prems n t -> cls ⊢ℋ s ≡ t. + Proof. + move/eq_antisym => [] /le_succ_inj hst. + move/le_succ_inj => hts. + now apply eq_antisym. + Qed. + + Lemma succ_congr {cls n s t} : + cls ⊢ℋ s ≡ t -> + cls ⊢ℋ add_prems n s ≡ add_prems n t. + Proof. + move/eq_antisym => [] hle hle'. + apply eq_antisym; split; now apply le_succ_congr. + Qed. + + Lemma le_refl {cls s} : + cls ⊢ℋ s ⋞ s. + Proof. + rewrite !to_entails_all. now constructor. + Qed. + Hint Resolve le_refl : entails. + + Lemma eq_refl {cls s} : + cls ⊢ℋ s ≡ s. + Proof. + apply eq_antisym; split; apply le_refl. + Qed. + Hint Resolve eq_refl : entails. + + Lemma le_succ {cls s} : cls ⊢ℋ s ⋞ succ s. + Proof. + eapply to_entails_all, entails_all_succ. + Qed. + Hint Resolve le_succ : entails. + + Lemma eq_sym {cls s t} : + cls ⊢ℋ s ≡ t -> cls ⊢ℋ t ≡ s. + Proof. + now move/eq_antisym => []; rewrite eq_antisym. + Qed. + Hint Immediate eq_sym : entails. + + Lemma le_trans {cls s t u} : + cls ⊢ℋ s ⋞ t -> cls ⊢ℋ t ⋞ u -> cls ⊢ℋ s ⋞ u. + Proof. + move/to_entails_all => h /to_entails_all h'. + apply to_entails_all. now eapply entails_all_trans. + Qed. + + Lemma eq_trans {cls s t u} : + cls ⊢ℋ s ≡ t -> cls ⊢ℋ t ≡ u -> cls ⊢ℋ s ≡ u. + Proof. + move/eq_antisym => []; rewrite eq_antisym. + move=> st ts [] tu ut. + apply eq_antisym; split; eauto using le_trans. + Qed. + + Lemma join_le_left {cls s t u} : + cls ⊢ℋ s ∨ t ⋞ u <-> + cls ⊢ℋ s ⋞ u /\ cls ⊢ℋ t ⋞ u. + Proof. + rewrite !to_entails_all. + now rewrite entails_all_concl_union. + Qed. + + Lemma join_idem {cls s} : cls ⊢ℋ s ∨ s ≡ s. + Proof. + apply eq_antisym. split. + - apply join_le_left; split; auto with entails. + - apply to_entails_all. eapply entails_all_weak_union, entails_all_tauto. + Qed. + + Lemma join_le_right {cls s t u} : + cls ⊢ℋ s ⋞ t -> cls ⊢ℋ s ⋞ u -> + cls ⊢ℋ s ⋞ t ∨ u. + Proof. + rewrite !to_entails_all => hl hr. + have he := entails_all_union hl hr. + eapply entails_all_trans; tea. + have /eq_antisym [_ hle] := @join_idem cls s. + now eapply to_entails_all. + Qed. + + Lemma join_comm {cls s t} : cls ⊢ℋ s ∨ t ≡ t ∨ s. + Proof. rewrite univ_union_comm; auto with entails. Qed. + + Lemma join_assoc {cls s t u} : + cls ⊢ℋ s ∨ t ∨ u ≡ s ∨ (t ∨ u). + Proof. + rewrite univ_union_assoc; auto with entails. + Qed. + + Lemma join_left {cls s t} : + cls ⊢ℋ s ⋞ s ∨ t. + Proof. + eapply to_entails_all. + rewrite univ_union_comm;apply entails_all_weak_union; + auto with entails. + Qed. + + Lemma join_right {cls s t} : + cls ⊢ℋ s ⋞ t ∨ s. + Proof. + eapply to_entails_all. apply entails_all_weak_union; + auto with entails. + Qed. + + Lemma le_spec {cls s t} : cls ⊢ℋ s ⋞ t <-> cls ⊢ℋ le s t. + Proof. + rewrite /le; split. + - move=> hle. apply eq_antisym. split. + rewrite join_le_left; split; auto with entails. + apply join_right. + - move/eq_antisym=> [] hle hle'. + now rewrite join_le_left in hle. + Qed. + + Lemma join_succ {cls s} : + cls ⊢ℋ s ∨ succ s ≡ succ s. + Proof. + apply eq_antisym; split. + - apply join_le_left; split; auto with entails. + - apply join_right. + Qed. + + Lemma succ_join {cls s t} : + cls ⊢ℋ succ (s ∨ t) ≡ succ s ∨ succ t. + Proof. + rewrite add_prems_univ_union; auto with entails. + Qed. + + Lemma join_congr_left {cls r s t} : + cls ⊢ℋ s ≡ t -> + cls ⊢ℋ s ∨ r ≡ t ∨ r. + Proof. + intros he. + apply eq_antisym; split. + - rewrite to_entails_all. eapply entails_all_union; auto with entails. + apply to_entails_all. now apply eq_antisym in he. + - rewrite to_entails_all. eapply entails_all_union; auto with entails. + apply to_entails_all. now apply eq_antisym in he. + Qed. + + Lemma join_congr_right {cls r s t} : + cls ⊢ℋ s ≡ t -> + cls ⊢ℋ r ∨ s ≡ r ∨ t. + Proof. + intros heq. + rewrite univ_union_comm [r ∨ _]univ_union_comm. + now apply join_congr_left. + Qed. + + End Theory. + + Module Semilattice. + Reserved Notation "x ≌ y" (at level 90). + Record semilattice := + { carrier :> Type; + eq : carrier -> carrier -> Prop where "x ≌ y" := (eq x y); + succ : carrier -> carrier; + join : carrier -> carrier -> carrier; + join_assoc x y z : join (join x y) z ≌ join x (join y z); + join_comm x y : join x y ≌ join y x; + join_idem x : join x x ≌ x; + join_sub x : join x (succ x) ≌ succ x; + succ_inj : forall x y, succ x ≌ succ y -> x ≌ y; + succ_join : forall x y, succ (join x y) ≌ join (succ x) (succ y); + }. + + Notation "x ≌ y" := (eq _ x y). + Local Open Scope nat_scope. + Section Derived. + Context (s : semilattice). + Definition le (x y : s) := join s x y ≌ y. + + Fixpoint add (x : s) n : s := + match n with + | 0 => x + | S n => succ _ (add x n) + end. + End Derived. + End Semilattice. + + Section prems_semi. + Obligation Tactic := idtac. + Import Semilattice (semilattice, carrier, eq, succ, join). + Context (cls : Clauses.t). + + Equations? leset_sl : semilattice := + leset_sl := {| carrier := NES.t; + eq x y := cls ⊢ℋ x ≡ y; + succ := add_prems 1; + join := univ_union |}. + Proof. + all: intros. + - cbn. apply Theory.join_assoc. + - apply Theory.join_comm. + - apply Theory.join_idem. + - apply Theory.join_succ. + - now eapply Theory.succ_inj. + - apply Theory.succ_join. + Defined. + End prems_semi. + + Import Semilattice. + Section Morphism. + Context (s s' : semilattice). + Context (f : s -> s'). + Class respects := + { of_succ x : f (succ s x) = succ s' (f x); + of_join x y : f (join _ x y) = join _ (f x) (f y) }. + + Lemma respects_assoc {r : respects} x y z : f (join s (join s x y) z) ≌ join s' (f x) (join s' (f y) (f z)). + Proof. + rewrite !of_join. apply join_assoc. + Qed. + + Lemma respects_comm {r : respects} x y : f (join s x y) ≌ join s' (f y) (f x). + Proof. rewrite !of_join. apply join_comm. Qed. + + End Morphism. + End Clauses. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index d78267155..9a59774e6 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -123,11 +123,11 @@ Module Model (LS : LevelSets). - constructor. constructor. Qed. - Inductive findSpec l m : option (option Z) -> Prop := + Inductive findSpec {A} l m : option A -> Prop := | inm k : LevelMap.MapsTo l k m -> findSpec l m (Some k) | ninm : ~ LevelMap.In l m -> findSpec l m None. - Lemma find_spec l m : findSpec l m (LevelMap.find l m). + Lemma find_spec {A} l (m : LevelMap.t A) : findSpec l m (LevelMap.find l m). Proof. destruct (LevelMap.find l m) eqn:heq; constructor. now apply LevelMap.find_2. @@ -1949,7 +1949,8 @@ Module Model (LS : LevelSets). Proof. rewrite /infers_atom. intros infa le. - depelim infa. eapply level_value_MapsTo' in H0. eapply le in H0 as [k' [hm hle]]. + depelim infa. eapply level_value_MapsTo' in H0. + eapply le0 in H0 as [k' [hm hle]]. rewrite (level_value_MapsTo hm). depelim hle; constructor; lia. Qed. diff --git a/common/theories/Reflect.v b/common/theories/Reflect.v index 29dff1b44..6be7d9e2a 100644 --- a/common/theories/Reflect.v +++ b/common/theories/Reflect.v @@ -2,7 +2,7 @@ (* For primitive integers and floats *) From Stdlib Require Numbers.Cyclic.Int63.Uint63 Floats.PrimFloat Floats.FloatAxioms. From MetaRocq.Utils Require Import utils. -From MetaRocq.Common Require Import BasicAst Universes Kernames. +From MetaRocq.Common Require Import BasicAst UnivConstraintType Universes Kernames. From Stdlib Require Import ssreflect. From Equations Require Import Equations. diff --git a/common/theories/UnivConstraintType.v b/common/theories/UnivConstraintType.v new file mode 100644 index 000000000..704514167 --- /dev/null +++ b/common/theories/UnivConstraintType.v @@ -0,0 +1,51 @@ +From Stdlib Require Import OrdersAlt Structures.OrdersEx MSetList MSetAVL MSetFacts MSetProperties MSetDecide FMapAVL. +From Equations Require Import Equations. +From MetaRocq.Utils Require Import utils MRMSets MRFSets NonEmptyLevelExprSet. +From MetaRocq.Common Require Import BasicAst config. +From Stdlib Require Import ssreflect. + +From Equations Require Import Equations. + +Module ConstraintType. + Inductive t_ : Set := Le | Eq. + Derive NoConfusion EqDec for t_. + + Definition t := t_. + Definition eq : t -> t -> Prop := eq. + Definition eq_equiv : Equivalence eq := _. + + Inductive lt_ : t -> t -> Prop := + | LeEq : lt_ Le Eq. + Derive Signature for lt_. + Definition lt := lt_. + + Global Instance lt_strorder : StrictOrder lt. + Proof. + constructor. + - intros []; intro X; inversion X. + - intros ? ? ? X Y; invs X; invs Y; constructor. + Qed. + + Global Instance lt_compat : Proper (eq ==> eq ==> iff) lt. + Proof. + intros ? ? X ? ? Y; invs X; invs Y. reflexivity. + Qed. + + Definition compare (x y : t) : comparison := + match x, y with + | Le, Le => Datatypes.Eq + | Le, Eq => Datatypes.Lt + | Eq, Eq => Datatypes.Eq + | Eq, _ => Datatypes.Gt + end. + + Lemma compare_spec x y : CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). + Proof. + destruct x, y; repeat constructor. + Qed. + + Lemma eq_dec x y : {eq x y} + {~ eq x y}. + Proof. + unfold eq. decide equality. + Qed. +End ConstraintType. diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 8405396af..4f72563c8 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -1,7 +1,7 @@ From Stdlib Require Import OrdersAlt Structures.OrdersEx MSetList MSetAVL MSetFacts MSetProperties MSetDecide FMapAVL. From Equations Require Import Equations. From MetaRocq.Utils Require Import utils MRMSets MRFSets NonEmptyLevelExprSet. -From MetaRocq.Common Require Import BasicAst config. +From MetaRocq.Common Require Import BasicAst config UnivConstraintType. From Stdlib Require Import ssreflect. Local Open Scope nat_scope. @@ -629,50 +629,6 @@ Proof. - intros le x. rewrite val_add. lia. Qed. -Module ConstraintType. - Inductive t_ : Set := Le | Eq. - Derive NoConfusion EqDec for t_. - - Definition t := t_. - Definition eq : t -> t -> Prop := eq. - Definition eq_equiv : Equivalence eq := _. - - Inductive lt_ : t -> t -> Prop := - | LeEq : lt_ Le Eq. - Derive Signature for lt_. - Definition lt := lt_. - - Global Instance lt_strorder : StrictOrder lt. - Proof. - constructor. - - intros []; intro X; inversion X. - - intros ? ? ? X Y; invs X; invs Y; constructor. - Qed. - - Global Instance lt_compat : Proper (eq ==> eq ==> iff) lt. - Proof. - intros ? ? X ? ? Y; invs X; invs Y. reflexivity. - Qed. - - Definition compare (x y : t) : comparison := - match x, y with - | Le, Le => Datatypes.Eq - | Le, Eq => Datatypes.Lt - | Eq, Eq => Datatypes.Eq - | Eq, _ => Datatypes.Gt - end. - - Lemma compare_spec x y : CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). - Proof. - destruct x, y; repeat constructor. - Qed. - - Lemma eq_dec x y : {eq x y} + {~ eq x y}. - Proof. - unfold eq. decide equality. - Qed. -End ConstraintType. - Module UnivConstraint. Definition t : Type := Universe.t * ConstraintType.t * Universe.t. diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v index 9e76ee982..945758d3f 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -6,7 +6,7 @@ From Stdlib Require Import ssreflect ssrfun ssrbool. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils. -From MetaRocq.Common Require Import Universes. +From MetaRocq.Common Require Import UnivConstraintType Universes. From MetaRocq.Common.LoopChecking Require Import Common Interfaces Deciders. From Equations Require Import Equations. Set Equations Transparent. @@ -187,14 +187,126 @@ Module UnivLoopChecking. apply from_levelexprzset_spec in hin. now apply he in hin. Qed. - Definition to_cstr d := match d with - | ConstraintType.Eq => LoopCheck.UnivEq - | ConstraintType.Le => LoopCheck.UnivLe - end. + +Module ZUnivConstraint. + Definition t : Type := NES.t * ConstraintType.t * NES.t. + + Definition eq : t -> t -> Prop := Logic.eq. + Definition eq_equiv : Equivalence eq := _. + + Definition make l1 ct l2 : t := (l1, ct, l2). + + Inductive lt_ : t -> t -> Prop := + | lt_Level2 l1 t (l2 l2' : NES.t) : LevelExprSet.lt l2 l2' -> lt_ (l1, t, l2) (l1, t, l2') + | lt_Cstr l1 t t' l2 l2' : ConstraintType.lt t t' -> lt_ (l1, t, l2) (l1, t', l2') + | lt_Level1 (l1 l1' : NES.t) t t' l2 l2' : LevelExprSet.lt l1 l1' -> lt_ (l1, t, l2) (l1', t', l2'). + Derive Signature for lt_. + Definition lt := lt_. + + Lemma lt_strorder : StrictOrder lt. + Proof. + constructor. + - intros []; intro X; inversion X; subst; + try (eapply LevelExprSet.lt_strorder; eassumption). + eapply ConstraintType.lt_strorder; eassumption. + - intros ? ? ? X Y; invs X; invs Y; constructor; tea. + etransitivity; eassumption. + 2: etransitivity; eassumption. + eapply ConstraintType.lt_strorder; eassumption. + Qed. + + Lemma lt_compat : Proper (eq ==> eq ==> iff) lt. + Proof. + intros ? ? X ? ? Y; invs X; invs Y. reflexivity. + Qed. + + Definition compare : t -> t -> comparison := + fun '(l1, t, l2) '(l1', t', l2') => + compare_cont (LevelExprSet.compare l1 l1') + (compare_cont (ConstraintType.compare t t') + (LevelExprSet.compare l2 l2')). + + Lemma universe_eq (x y : Universe.t) : Universe.t_set x = Universe.t_set y -> x = y. + Proof. + apply Universe.eq_univ. + Qed. + + Lemma compare_spec x y + : CompareSpec (eq x y) (lt x y) (lt y x) (compare x y). + Proof. + destruct x as [[l1 t] l2], y as [[l1' t'] l2']; cbn. + destruct (LevelExprSet.compare_spec l1 l1'); cbn; repeat constructor; tas. + eapply LevelExprSet.eq_leibniz, eq_univ in H. subst l1'. + destruct (ConstraintType.compare_spec t t'); cbn; repeat constructor; tas. + invs H. + destruct (LevelExprSet.compare_spec l2 l2'); cbn; repeat constructor; tas. + eapply LevelExprSet.eq_leibniz, eq_univ in H. now subst l2'. + Qed. + + Lemma eq_dec x y : {eq x y} + {~ eq x y}. + Proof. + unfold eq. decide equality; apply eq_dec. + Defined. + + Definition eq_leibniz (x y : t) : eq x y -> x = y := id. +End ZUnivConstraint. + + Module ZUnivConstraintSet := MSetAVL.Make ZUnivConstraint. + Module ZUnivConstraintSetFact := WFactsOn ZUnivConstraint ZUnivConstraintSet. + Module ZUnivConstraintSetOrdProp := MSetProperties.OrdProperties ZUnivConstraintSet. + Module ZUnivConstraintSetProp := ZUnivConstraintSetOrdProp.P. + + Definition of_z_constraints (x : ZUnivConstraintSet.t) : Clauses.t := + ZUnivConstraintSet.fold (fun c cls => + Clauses.union (LoopCheck.to_clauses c) cls) x Clauses.empty. + + Lemma of_z_constraints_spec {cstrs} : + forall cl, Clauses.In cl (of_z_constraints cstrs) <-> + (exists cstr, ZUnivConstraintSet.In cstr cstrs /\ + Clauses.In cl (LoopCheck.to_clauses cstr)). + Proof. + rewrite /of_z_constraints. + eapply ZUnivConstraintSetProp.fold_rec. + - intros s' he cl; split. clsets. + intros [cstr [hin ?]]. firstorder. + - intros x a s' s'' hin hnin hadd h cl. + rewrite Clauses.union_spec h. + split. + * intros []. exists x. split => //. apply hadd. now left. + firstorder. + * intros [cstr [hin' incl]]. + apply hadd in hin' as []. + + subst. now left. + + right. exists cstr. split => //. + Qed. Definition to_constraint (x : UnivConstraint.t) : LoopCheck.constraint := let '(l, d, r) := x in - (to_atoms l, to_cstr d, to_atoms r). + (to_atoms l, d, to_atoms r). + + Definition to_clauses (x : UnivConstraintSet.t) : Clauses.t := + UnivConstraintSet.fold (fun c cls => + Clauses.union (LoopCheck.to_clauses (to_constraint c)) cls) x Clauses.empty. + + Lemma to_clauses_spec {cstrs} : + forall cl, Clauses.In cl (to_clauses cstrs) <-> + (exists cstr, UnivConstraintSet.In cstr cstrs /\ + Clauses.In cl (LoopCheck.to_clauses (to_constraint cstr))). + Proof. + rewrite /to_clauses. + eapply UnivConstraintSetProp.fold_rec. + - intros s' he cl; split. clsets. + intros [cstr [hin ?]]. firstorder. + - intros x a s' s'' hin hnin hadd h cl. + rewrite Clauses.union_spec h. + split. + * intros []. exists x. split => //. apply hadd. now left. + firstorder. + * intros [cstr [hin' incl]]. + apply hadd in hin' as []. + + subst. now left. + + right. exists cstr. split => //. + Qed. Module Clauses := LoopCheck.Impl.I.Model.Model.Clauses.Clauses. @@ -276,24 +388,23 @@ Module UnivLoopChecking. now constructor. Qed. - Lemma clauses_of_le_nempty l r : ~ Clauses.Empty (LoopCheck.clauses_of_le l r). + Lemma clauses_of_le_nempty l r : ~ Clauses.Empty (clauses_of_le l r). Proof. intros he. red in he. eapply he. - rewrite !LoopCheck.clauses_of_le_spec. + rewrite !clauses_of_le_spec. exists (choose_prems l). split; trea. apply choose_prems_spec. Qed. Lemma to_clauses_ne c : ~ Clauses.Empty (LoopCheck.to_clauses c). Proof. - intros he. red in he. destruct c as [[l []] r]. - eapply he. apply LoopCheck.to_clauses_spec. - right. exists (choose_prems r). split; trea. apply choose_prems_spec. - eapply he. apply LoopCheck.to_clauses_spec. - exists (choose_prems l). split; trea. apply choose_prems_spec. + intros he. red in he. destruct c as [[l []] r]; revgoals. + - eapply he. apply LoopCheck.to_clauses_spec. + right. exists (choose_prems r). split; trea. apply choose_prems_spec. + - eapply he. apply LoopCheck.to_clauses_spec. + exists (choose_prems l). split; trea. apply choose_prems_spec. Qed. - Equations? init_model : univ_model := init_model := {| model := LoopCheck.init_model; constraints := UnivConstraintSet.empty |}. @@ -377,11 +488,11 @@ Module UnivLoopChecking. rewrite UnivConstraintSet.add_spec. now left. Qed. - Lemma in_clause_levels_of_le lev l r : LevelSet.In lev (clauses_levels (LoopCheck.clauses_of_le l r)) <-> + Lemma in_clause_levels_of_le lev l r : LevelSet.In lev (clauses_levels (clauses_of_le l r)) <-> LevelSet.In lev (levels l) \/ LevelSet.In lev (levels r). Proof. rewrite clauses_levels_spec. - setoid_rewrite LoopCheck.clauses_of_le_spec. + setoid_rewrite clauses_of_le_spec. split. - intros [cl [hex hin]]. apply clause_levels_spec in hin. @@ -452,12 +563,12 @@ Module UnivLoopChecking. LevelSet.In l (constraint_levels c). Proof. intros l. - destruct c as [[l' d] r] => //=. - destruct d. rewrite clauses_levels_union LevelSet.union_spec. - rewrite /constraint_levels //= LevelSet.union_spec. - rewrite !in_clause_levels_of_le. firstorder. - rewrite /constraint_levels //= LevelSet.union_spec. - rewrite !in_clause_levels_of_le. firstorder. + destruct c as [[l' []] r] => //=; revgoals. + - rewrite clauses_levels_union LevelSet.union_spec. + rewrite /constraint_levels //= LevelSet.union_spec. + rewrite !in_clause_levels_of_le. firstorder. + - rewrite /constraint_levels //= LevelSet.union_spec. + rewrite !in_clause_levels_of_le. firstorder. Qed. Lemma ndecl_nin_levels ls c : @@ -518,18 +629,22 @@ Module UnivLoopChecking. valuation_poly := fun i => option_get 0 (LevelMap.find (Level.lvar i) v) |}. + Definition of_valuation V (v : valuation) : LevelMap.t nat := + let add_val l := LevelMap.add l (val v l) in + LevelSet.fold add_val V (LevelMap.empty _). + Lemma clauses_sem_subset {v cls cls'} : clauses_sem v cls -> cls' ⊂_clset cls -> clauses_sem v cls'. Proof. now move=> hall hsub cl /hsub. Qed. Lemma clauses_sem_clauses_of_le V l r : - clauses_sem V (LoopCheck.clauses_of_le l r) -> + clauses_sem V (clauses_of_le l r) -> (interp_prems V l <= interp_prems V r)%Z. Proof. rewrite /clauses_sem. intros hl. red in hl. - setoid_rewrite LoopCheck.clauses_of_le_spec in hl. + setoid_rewrite clauses_of_le_spec in hl. move: l hl. apply: elim. - move => le he. rewrite interp_prems_singleton. @@ -546,12 +661,37 @@ Module UnivLoopChecking. Qed. Lemma to_atoms_singleton l k : to_atoms (Universe.singleton (l, k)) = singleton (l, Z.of_nat k). - Proof. Admitted. + Proof. + apply NES.equal_exprsets. + rewrite /to_atoms //=. + Qed. Lemma to_atoms_add le u : to_atoms (Universe.add le u) = add (to_atom le) (to_atoms u). - Proof. Admitted. + Proof. apply NES.equal_exprsets => //=. + move=> [l k]. + rewrite LevelExprSet.add_spec. + split. + - move/to_levelexprzset_spec_2 => []. + rewrite Universes.LevelExprSet.add_spec => -[<-|hin]. + * move=> pos. + left. cbn. lia_f_equal. + * move=> pos. right. + apply to_levelexprzset_spec_1 in hin. + rewrite Z2Nat.id // in hin. + - move=> [eq|hin]. + destruct le; noconf eq. + * apply to_levelexprzset_spec_1. + rewrite Universes.LevelExprSet.add_spec. + now left. + * apply to_levelexprzset_spec_2 in hin as [hin pos]. + have [k' eq] : exists z, Z.of_nat z = k. exists (Z.to_nat k). + rewrite Z2Nat.id //. subst k. + apply to_levelexprzset_spec_1. + rewrite Nat2Z.id in hin. + rewrite Universes.LevelExprSet.add_spec. now right. + Qed. - Lemma interp_prem_to_atom v le : Z.to_nat (interp_expr v (to_atom le)) = val (to_valuation v) le. + Lemma interp_prem_to_atom v le : interp_expr v (to_atom le) = Z.of_nat (val (to_valuation v) le). Proof. destruct le => //=. cbn. destruct t0. @@ -570,7 +710,7 @@ Module UnivLoopChecking. specialize (H cl). specialize (H0 cl). intros []; auto. Qed. - Lemma interp_prems_to_atoms v l : Z.to_nat (interp_prems v (to_atoms l)) = Universes.val (to_valuation v) l. + Lemma interp_prems_to_atoms v l : interp_prems v (to_atoms l) = Z.of_nat (Universes.val (to_valuation v) l). Proof. move: l. apply Universe.elim. @@ -581,11 +721,11 @@ Module UnivLoopChecking. - intros le x eq nin. rewrite to_atoms_add interp_prems_add. rewrite val_add. - rewrite -interp_prem_to_atom. lia. + rewrite interp_prem_to_atom. lia. Qed. Lemma clauses_sem_val m l r : - clauses_sem (LoopCheck.valuation m) (LoopCheck.clauses_of_le (to_atoms l) (to_atoms r)) -> + clauses_sem (LoopCheck.valuation m) (clauses_of_le (to_atoms l) (to_atoms r)) -> Universes.val (to_valuation (LoopCheck.valuation m)) l <= Universes.val (to_valuation (LoopCheck.valuation m)) r. Proof. move/clauses_sem_clauses_of_le. @@ -594,11 +734,10 @@ Module UnivLoopChecking. Qed. Lemma model_satisfies m : - exists V, satisfies V (constraints m). + satisfies (to_valuation (LoopCheck.valuation (model m))) (constraints m). Proof. destruct m as [m cstrs repr repr_inv]. cbn. have val := LoopCheck.model_valuation m. - exists (to_valuation (LoopCheck.valuation m)). move=> cstr /repr /(clauses_sem_subset val). intros cls. destruct cstr as [[l []] r]; cbn. constructor. cbn in cls. now apply clauses_sem_val. @@ -607,6 +746,837 @@ Module UnivLoopChecking. eapply Nat.le_antisymm; now apply clauses_sem_val. Qed. + Lemma to_of_valuation V v : + forall l, LevelSet.In l.1 V -> val (to_valuation (of_valuation V v)) l = val v l. + Proof. + Admitted. + + Lemma to_of_valuation_univ V v : + forall u : Universe.t, LevelSet.Subset (Universe.levels u) V -> val (to_valuation (of_valuation V v)) u = val v u. + Proof. + Admitted. + + Lemma of_valuation_spec V v : + forall l k, LevelMap.MapsTo l k (of_valuation V v) <-> + (LevelSet.In l V /\ k = val v l). + Proof. + intros l k. + rewrite /of_valuation. + eapply LevelSetProp.fold_rec. + - move=> s' he. + rewrite LevelMapFact.F.empty_mapsto_iff. + split => // -[] hin' _. lsets. + - move=> x a s' s'' hin hnin hadd ih. + rewrite LevelMapFact.F.add_mapsto_iff /Level.eq ih. + rewrite hadd. firstorder; subst; auto. + destruct (eq_dec x l); firstorder. subst. now left. + Qed. + + Lemma interp_level_of_valuation {V v l} : + LevelSet.In l V -> + interp_level (of_valuation V v) l = val v l. + Proof. + move=> hin. + rewrite /interp_level. + elim: find_spec => [k /of_valuation_spec []|] => //. + elim. exists (val v l). rewrite [LevelMap.Raw.MapsTo _ _ _]of_valuation_spec. + split => //. + Qed. + + Lemma clauses_levels_mon {cls cls'} : + cls ⊂_clset cls' -> + clauses_levels cls ⊂_lset clauses_levels cls'. + Proof. + move=> sub l /clauses_levels_spec; rewrite clauses_levels_spec. + firstorder. + Qed. + (* Lemma in_to_clauses_elem {l k a} : *) + + Definition check m (c : UnivConstraint.t) : bool := + LoopCheck.check m.(model) (to_constraint c). + Derive Signature for satisfies0. + + Lemma in_to_clauses_sem {l r V v} : + LevelSet.Subset (univ_constraint_levels (l, ConstraintType.Le, r)) V -> + val v l <= val v r -> + forall cl, LevelExprSet.Exists (fun lk : LevelExprSet.elt => cl = (to_atoms r, lk)) (to_levelexprzset l) -> + clause_sem (of_valuation V v) cl. + Proof. + move=> hlev leq [prems concl]. + move=> [] [l'' k'] [] /to_levelexprzset_spec_2 [] inl' pos ->. + cbn. rewrite interp_prems_to_atoms //=. + rewrite to_of_valuation_univ. + { intros ? hin; apply hlev. cbn. lsets. } + transitivity (Z.of_nat (val v l)). lia. + rewrite interp_level_of_valuation. + { apply hlev; cbn. + eapply LevelSet.union_spec; left. eapply Universe.levels_spec. + now eexists. } + have vle := val_In_le l v _ inl'. cbn in vle. + by u; lia. + Qed. + + Lemma satisfies_clauses_sem v m V : + LoopCheck.levels (model m) ⊂_lset V -> + satisfies v (constraints m) -> + clauses_sem (of_valuation V v) (LoopCheck.clauses (model m)). + Proof. + have repr := repr_constraints_inv m. + have repr_inv := repr_constraints m. + move=> hsub hs cl /[dup] hin /repr [] c [] /[dup] /repr_inv hr /hs sat. + destruct c as [[l' d] r]. + move=> /[dup] intocl. + rewrite LoopCheck.to_clauses_spec. + depelim sat. cbn -[clause_sem]. + - apply in_to_clauses_sem; auto. + cbn; intros le inr. apply hsub. + apply (LoopCheck.clauses_levels_declared m.(model)). + move/clauses_levels_mon: hr; apply. + rewrite in_to_clauses_levels. + rewrite in_constraint_levels_to_constraint //=. + - cbn. move=> []. + * apply in_to_clauses_sem; [|lia]. + cbn; intros le inr. + apply hsub, (LoopCheck.clauses_levels_declared m.(model)). + move/clauses_levels_mon: hr; apply. + rewrite in_to_clauses_levels. + rewrite in_constraint_levels_to_constraint //=. + * apply in_to_clauses_sem; [|lia]. + cbn; intros le inr. + apply hsub, (LoopCheck.clauses_levels_declared m.(model)). + move/clauses_levels_mon: hr; apply. + rewrite in_to_clauses_levels. + rewrite in_constraint_levels_to_constraint //=. lsets. + Qed. + + Lemma clauses_sem_satisfies {v V c} : + univ_constraint_levels c ⊂_lset V -> + clauses_sem (of_valuation V v) (LoopCheck.to_clauses (to_constraint c)) -> + satisfies0 v c. + Proof. + intros hin hsem. destruct c as [[l []] r]; cbn in *. + - constructor. + move/clauses_sem_clauses_of_le: hsem. + rewrite !interp_prems_to_atoms. + rewrite !to_of_valuation_univ. lsets. lsets. lia. + - constructor. + rewrite clauses_sem_union in hsem. destruct hsem as [hsem hsem']. + move/clauses_sem_clauses_of_le: hsem. + move/clauses_sem_clauses_of_le: hsem'. + rewrite !interp_prems_to_atoms. + rewrite !to_of_valuation_univ. lsets. lsets. lia. + Qed. + + Instance in_pred_closure_proper : Proper (Clauses.Equal ==> Logic.eq ==> impl) in_pred_closure. + Proof. + intros cls cls' eq ? cl -> h. + induction h. + - constructor. now rewrite -eq. + - constructor. + Qed. + + + Instance proper_entails : Proper (Clauses.Equal ==> Logic.eq ==> impl) entails. + Proof. + intros cls cls' eq ? cl -> h. + induction h. + - constructor; auto. + - econstructor 2; eauto. + now rewrite -eq. + Qed. + + Definition entails_cstr cstrs c := + entails_clauses (to_clauses cstrs) (LoopCheck.to_clauses (to_constraint c)). + + Definition entails_z_cstr cstrs c := + entails_clauses (of_z_constraints cstrs) (LoopCheck.to_clauses c). + + Definition entails_cstrs cstrs cstrs' := + entails_clauses (of_z_constraints cstrs) (of_z_constraints cstrs'). + + Definition to_z_cstrs cstrs := + UnivConstraintSet.fold (fun c acc => ZUnivConstraintSet.add (to_constraint c) acc) + cstrs ZUnivConstraintSet.empty. + + Lemma check_valid m c : + check m c <-> entails_cstr (constraints m) c. + Proof. + rewrite /check LoopCheck.check_spec. + rewrite /entails_clauses. + enough ((LoopCheck.clauses (model m)) =_clset (to_clauses (constraints m))). + { split; intros ? ?. + move/H0. now rewrite H. + move/H0. now rewrite H. } + intros cl. + rewrite to_clauses_spec. + split. + - now move/(repr_constraints_inv m). + - intros [cstr [hin incl]]. + eapply (repr_constraints m); tea. + Qed. + + Section Nat_Semilattice. + Import Semilattice. + Equations? nat_semilattice : semilattice := + nat_semilattice := + {| carrier := nat; + eq := Logic.eq; + succ x := S x; + join x y := Nat.max x y |}. + Proof. + all:lia. + Qed. + End Nat_Semilattice. + + Section Z_Semilattice. + Import Semilattice. + Equations? Z_semilattice : semilattice := + Z_semilattice := + {| carrier := Z; + eq := Logic.eq; + succ x := Z.succ x; + join x y := Z.max x y |}. + Proof. + all:lia. + Qed. + End Z_Semilattice. + + Lemma interp_prems_union {v x y} : interp_prems v (x ∨ y) = Z.max (interp_prems v x) (interp_prems v y). + Proof. + move: x; apply NES.elim. + - intros []. rewrite univ_union_comm univ_union_add_singleton. + now rewrite interp_prems_add interp_prems_singleton. + - intros le' x ih hnin. + rewrite univ_union_add_distr !interp_prems_add ih. lia. + Qed. + + Lemma val_respects cls v : respects (leset_sl cls) Z_semilattice (fun u => interp_prems v u). + Proof. + split; cbn. + - intros x. rewrite interp_add_prems. lia. + - intros x y. rewrite interp_prems_union. lia. + Qed. + + Definition valid_entailments cls cls' := + forall V, clauses_sem V cls -> clauses_sem V cls'. + + Lemma entails_cstr_spec cstrs c : + (exists V, clauses_sem V (of_z_constraints cstrs)) -> + entails_z_cstr cstrs c -> + (forall cl, Clauses.In cl (LoopCheck.to_clauses c) -> + valid_entailment (of_z_constraints cstrs) cl). + Proof. + rewrite /entails_cstr /entails_clauses. + move=> ev hf cl /hf he. red. + now eapply clauses_sem_entails in he. + Qed. + + Import Semilattice. + + Record presentation := + { V : LevelSet.t; + C : list (NES.t × NES.t); }. + + Inductive entails_L (p : presentation) : NES.t -> NES.t -> Prop := + | entails_c {l r} : List.In (l, r) p.(C) -> entails_L p l r + | entails_refl {x} : entails_L p x x + | entails_sym {x y} : entails_L p x y -> entails_L p y x + | entails_trans {x y z} : entails_L p x y -> entails_L p y z -> entails_L p x z + | entails_succ_congr {x y n} : entails_L p x y -> entails_L p (add_prems n x) (add_prems n y) + | entails_join_congr {x y r} : entails_L p x y -> entails_L p (x ∨ r) (y ∨ r) + | entails_assoc {x y z} : entails_L p ((x ∨ y) ∨ z) (x ∨ (y ∨ z)) + | entails_idem {x} : entails_L p (x ∨ x) x + | entails_comm {x y} : entails_L p (x ∨ y) (y ∨ x) + | entails_sub {x} : entails_L p (x ∨ succ_prems x) (succ_prems x) + | entails_succ_inj {x y n} : entails_L p (add_prems n x) (add_prems n y) -> + entails_L p x y + | entails_succ_join {x y} : entails_L p (succ_prems (x ∨ y)) (succ_prems x ∨ succ_prems y). + + Definition entails_L_curry p eq := entails_L p eq.1 eq.2. + + Lemma entails_join_congr_all {p} {x x' y y'} : entails_L p x x' -> entails_L p y y' -> entails_L p (x ∨ y) (x' ∨ y'). + Proof. + intros he he'. + eapply entails_trans with (x' ∨ y). + now apply entails_join_congr. + rewrite (@univ_union_comm x' y) (@univ_union_comm x' y'). + now apply entails_join_congr. + Qed. + + Lemma entails_join_congr_all_inv {p} {x x' y z} : entails_L p (x ∨ y) z -> entails_L p x x' -> entails_L p (x' ∨ y) z. + Proof. + intros he he'. + eapply entails_trans with (x ∨ y) => //. + apply entails_join_congr => //. now eapply entails_sym. + Qed. + + Lemma entails_join_congr_all_inv_r {p} {x y y' z} : entails_L p (x ∨ y) z -> entails_L p y y' -> entails_L p (x ∨ y') z. + Proof. + intros he he'. + eapply entails_trans with (x ∨ y) => //. + rewrite !(@univ_union_comm x). + apply entails_join_congr => //. now eapply entails_sym. + Qed. + + Section pres_Semilattice. + Import Semilattice. + Context (p : presentation). + + Definition relations (c : list (NES.t × NES.t)) : Prop := + List.Forall (fun '(l, r) => l = r) c. + + Definition univ_le (u u' : premises) := + forall l k, LevelExprSet.In (l, k) u -> exists k', LevelExprSet.In (l, k') u /\ (k <= k')%Z. + + Lemma univ_le_refl u u' : u = u' -> univ_le u u'. + Proof. + intros <- l k hin; exists k; split => //; lia. + Qed. + + Definition univ_eq u u' := + univ_le u u' /\ univ_le u' u. + + Lemma univ_eq_refl u u' : u = u' -> univ_eq u u'. + Proof. + split; apply univ_le_refl; tea. now symmetry. + Qed. + + Equations? pres_semilattice : semilattice := + pres_semilattice := + {| carrier := NES.t; + eq x y := relations p.(C) -> univ_eq x y; + succ x := add_prems 1 x; + join x y := univ_union x y |}. + Proof. + all:intros. + - apply univ_eq_refl. now rewrite univ_union_assoc. + - apply univ_eq_refl. now rewrite univ_union_comm. + - split. intros l k; rewrite !LevelExprSet.union_spec. + intros []; exists k; split => //; try lia; + now rewrite univ_union_spec. + intros l k hin. exists k. split => //. lia. + - split. intros l k; rewrite !LevelExprSet.union_spec. + intros []; exists k; split => //; try lia; + now rewrite univ_union_spec. + intros l k hin. exists k. split => //. lia. + - split. intros l k hin. exists k. split => //. reflexivity. + intros l k hin. exists k. split => //; reflexivity. + - apply univ_eq_refl. now rewrite add_prems_univ_union. + Qed. + End pres_Semilattice. + + Definition entails_L_le p l r := (entails_L p (l ∨ r) r). + Notation " p ⊢ℒ t ≼ u " := (entails_L_le p t u) (t, u at next level, at level 62, no associativity). + Notation " p ⊢ℒ t ≈ u " := (entails_L p t u) (t, u at next level, at level 62, no associativity). + + Hint Constructors entails_L : entails_L. + + Lemma entails_L_le_refl p x : + p ⊢ℒ x ≼ x. + Proof. + eapply entails_idem. + Qed. + + Lemma entails_L_le_trans p x y z : + p ⊢ℒ x ≼ y -> p ⊢ℒ y ≼ z -> p ⊢ℒ x ≼ z. + Proof. + intros le le'. + eapply entails_trans. 2:exact le'. + red in le, le'. + eapply entails_trans with (x ∨ y ∨ z). + rewrite univ_union_assoc. eapply entails_sym. + eapply entails_join_congr_all => //. apply entails_refl. + rewrite univ_union_assoc. + eapply entails_trans with (x ∨ ((y ∨ y) ∨ z)). + eapply entails_join_congr_all; auto with entails_L. + rewrite univ_union_assoc -univ_union_assoc. + now eapply entails_join_congr_all. + Qed. + + Lemma subset_univ_union {u u' : premises} : + u ⊂_leset u' -> u ∨ u' = u'. + Proof. + intros hincl; apply equal_exprsets => l. + rewrite univ_union_spec. firstorder. + Qed. + + Lemma incl_entails_L {cls} {u u' : premises} : + u ⊂_leset u' -> cls ⊢ℒ u ≼ u'. + Proof. + move=> hincl; red. + rewrite subset_univ_union //; auto with entails_L. + Qed. + + Lemma entails_L_subset {cls} {prems prems' prems'' : premises} : + cls ⊢ℒ prems ≼ prems' -> + prems' ⊂_leset prems'' -> + cls ⊢ℒ prems ≼ prems''. + Proof. + move=> heq /(@incl_entails_L cls). + now eapply entails_L_le_trans. + Qed. + + (* Section interp. + Context (p : presentation). + Let s := pres_semilattice p. + Definition interp_atom le := + let '(l, k) := le in + (singleton (l, 0)) (Z.to_nat k). + + Definition interp_univ l := + let '(e, u) := NES.to_nonempty_list l in + List.fold_left (fun acc a => s.(join) (interp_atom a) acc) u (interp_atom e). + + Definition interp_cstr c := + let '(l, d, r) := c in + match d with + | ConstraintType.Le => le s (interp_univ l) (interp_univ r) + | ConstraintType.Eq => s.(eq) (interp_univ l) (interp_univ r) + end. + + Definition interp_cstrs c := + ZUnivConstraintSet.For_all (fun c => interp_cstr c) c. + End interp. *) + + Definition relation_of_constraint c := + let '(l, d, r) := c in + match d with + | ConstraintType.Le => (univ_union l r, r) + | ConstraintType.Eq => (l, r) + end. + + Definition Zuniv_constraint_levels (c : ZUnivConstraint.t) := + let '(l, d, r) := c in + LevelSet.union (NES.levels l) (NES.levels r). + + Definition relations_of_constraints c := + ZUnivConstraintSet.fold (fun c acc => relation_of_constraint c :: acc) c []. + + Lemma relations_of_constraints_spec {l r cstrs} : List.In (l, r) (relations_of_constraints cstrs) <-> + exists cl, ZUnivConstraintSet.In cl cstrs /\ (l, r) = relation_of_constraint cl. + Proof. Admitted. + + Definition levels_of_z_constraints c := + ZUnivConstraintSet.fold (fun c acc => LevelSet.union (Zuniv_constraint_levels c) acc) c LevelSet.empty. + + Definition presentation_of cstrs := + {| V := levels_of_z_constraints cstrs; + C := relations_of_constraints cstrs |}. + + Definition entails_L_clause p cl := + entails_L_le p (singleton (concl cl)) (premise cl). + + Definition relations_of_clauses c := + Clauses.fold (fun '(prems, concl) acc => (singleton concl ∨ prems, prems) :: acc) c []. + + Lemma relations_of_clauses_spec {cls} : + forall eq, In eq (relations_of_clauses cls) -> + exists prems concl, Clauses.In (prems, concl) cls /\ + eq = (NES.singleton concl ∨ prems, prems). + Proof. + rewrite /relations_of_clauses. + eapply ClausesProp.fold_rec. + - move=> s'he eq => //=. + - move=> x a s' s'' hin hnin hadd ih eq. + destruct x as [prems concl]. cbn. + intros [<-|ina]. + * do 2 eexists. split => //. apply hadd. now left. + * move: (ih _ ina) => [? [? []]]. do 2 eexists; split => //. + apply hadd. now right. assumption. + Qed. + + Lemma relations_of_clauses_spec_inv {cls} : + forall cl, Clauses.In cl cls -> + In (NES.singleton (concl cl) ∨ premise cl, premise cl) (relations_of_clauses cls). + Proof. + rewrite /relations_of_clauses. + eapply ClausesProp.fold_rec. + - move=> s'he eq => //=. + - move=> x a s' s'' hin hnin hadd ih eq. + destruct x as [prems concl]. cbn. + rewrite hadd. + intros [<-|ina]. + * cbn. now left. + * move: (ih _ ina) => insing. now right. + Qed. + + Definition presentation_of_clauses cls := + {| V := Clauses.clauses_levels cls; + C := relations_of_clauses cls |}. + + Lemma in_pred_closure_entails_clause {cls cl} : + in_pred_closure cls cl -> + entails cls cl. + Proof. + destruct cl as [prems concl]; intros inp. + eapply clause_cut; trea. + constructor. now apply NES.add_spec. + Qed. + + Lemma in_clause_of_le {le} {l r : premises} : + LevelExprSet.In le l <-> + Clauses.Clauses.In (r, le) (l ⋞ r). + Proof. + rewrite clauses_of_le_spec. + split. + - exists le. split => //. + - intros [lk [hin [=]]]. now subst le. + Qed. + + Lemma entails_clauses_le {cstrs l r} : + ZUnivConstraintSet.In (l, ConstraintType.Le, r) cstrs -> + of_z_constraints cstrs ⊢a r → l. + Proof. + intros hin l' cl. + eapply in_pred_closure_entails_clause, incls0. + rewrite of_z_constraints_spec. eexists; split; tea. + now apply in_clause_of_le. + Qed. + + Lemma entails_clauses_eq_left {cstrs l r} : + ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> + of_z_constraints cstrs ⊢a r → l. + Proof. + intros hin l' cl. + eapply in_pred_closure_entails_clause, incls0. + rewrite of_z_constraints_spec. eexists; split; tea. + rewrite LoopCheck.to_clauses_spec. left. exists l'. split => //. + Qed. + + Lemma entails_clauses_eq_right {cstrs l r} : + ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> + of_z_constraints cstrs ⊢a l → r. + Proof. + intros hin l' cl. + eapply in_pred_closure_entails_clause, incls0. + rewrite of_z_constraints_spec. eexists; split; tea. + rewrite LoopCheck.to_clauses_spec. right. exists l'. split => //. + Qed. + + Lemma entails_clauses_eq_cstr {cstrs l r} : + ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> + of_z_constraints cstrs ⊢ℋ l ≡ r. + Proof. + intros hin. + apply Theory.eq_antisym. + split. + - rewrite Theory.to_entails_all. now apply entails_clauses_eq_left. + - rewrite Theory.to_entails_all. now apply entails_clauses_eq_right. + Qed. + + Lemma entails_clauses_le_cstr {cstrs l r} : + ZUnivConstraintSet.In (l, ConstraintType.Le, r) cstrs -> + of_z_constraints cstrs ⊢ℋ l ⋞ r. + Proof. + intros hin. + rewrite Theory.to_entails_all. now apply entails_clauses_le. + Qed. + + + Lemma add_idem {l x} : NES.add l (NES.add l x) = NES.add l x. + Proof. + apply equal_exprsets => l'. + rewrite !NES.add_spec. firstorder. + Qed. + + Lemma entails_L_idem_gen {le} {prems : premises} {p} : + LevelExprSet.In le prems -> + entails_L p ((singleton le) ∨ prems) prems. + Proof. + move: prems; apply: NES.elim. + - move=> le' /LevelExprSet.singleton_spec <-. + apply entails_idem. + - move=> le' x hin hnin /LevelExprSet.add_spec []. + * intros eq; subst le'. + rewrite univ_union_comm univ_union_add_singleton. + rewrite add_idem. apply entails_refl. + * move/hin => heq. + rewrite -!univ_union_add_singleton -univ_union_assoc. + now apply entails_join_congr. + Qed. + + Lemma presentation_of_clauses_spec cls prems concl : + Clauses.In (prems, concl) cls -> + In (NES.singleton concl ∨ prems, prems) (C (presentation_of_clauses cls)). + Proof. + rewrite /presentation_of_clauses //=. + move/relations_of_clauses_spec_inv => //=. + Qed. + (* - move/relations_of_clauses_spec => [] prems' [] concl' [hin heq]. + have eqprems : prems = prems'. + noconf heq. *) + + + Lemma in_pred_closure_entails_L {cls} cl : + in_pred_closure cls cl -> + entails_L_clause (presentation_of_clauses cls) cl. + Proof. + induction 1. + - rewrite /entails_L_clause /entails_L_le. + destruct cl as [prems concl]; cbn. + rewrite -add_prems_singleton -add_prems_univ_union. + apply entails_succ_congr. + apply entails_c. now eapply presentation_of_clauses_spec. + - change (x, (k + 1)%Z) with (add_expr 1 (x, k)). + rewrite -add_prems_singleton. red; cbn. + eapply entails_sub. + Qed. + + Lemma entails_L_le_eq {cls l r} : cls ⊢ℒ l ≼ r -> cls ⊢ℒ l ∨ r ≈ r. + Proof. trivial. Qed. + + Lemma entails_L_eq_le_1 {cls} {l r} : cls ⊢ℒ l ≈ r -> cls ⊢ℒ l ≼ r. + Proof. + intros eq; red. + eapply (entails_join_congr_all_inv (x := r)). + eapply entails_idem. now eapply entails_sym. + Qed. + + Lemma entails_L_eq_le_2 {cls} {l r} : cls ⊢ℒ l ≈ r -> cls ⊢ℒ r ≼ l. + Proof. + intros eq; red. + eapply entails_sym in eq. now eapply entails_L_eq_le_1 in eq. + Qed. + + Lemma entails_L_eq_antisym {cls} {l r} : cls ⊢ℒ r ≼ l -> cls ⊢ℒ l ≼ r -> cls ⊢ℒ l ≈ r. + Proof. + unfold entails_L_le. intros le le'. + eapply entails_trans with (l ∨ r) => //. + apply entails_sym. now rewrite univ_union_comm. + Qed. + + Lemma entails_L_le_join_l {p x x' r} : + p ⊢ℒ x ≼ x' -> + p ⊢ℒ x ∨ r ≼ x' ∨ r. + Proof. + intros le. + red in le |- *. + rewrite univ_union_assoc (@univ_union_comm r) univ_union_assoc -univ_union_assoc. + eapply entails_join_congr_all => //. + apply entails_idem. + Qed. + + Lemma entails_L_le_congr {p x y x' y'} : + p ⊢ℒ x ≼ x' -> + p ⊢ℒ y ≼ y' -> + p ⊢ℒ x ∨ y ≼ x' ∨ y'. + Proof. + move/(entails_L_le_join_l (r:=y)) => le le'. + eapply entails_L_le_trans; tea. + rewrite !(@univ_union_comm x'). + now eapply entails_L_le_join_l. + Qed. + + Lemma entails_L_le_idem {p x} : + p ⊢ℒ x ∨ x ≼ x. + Proof. + eapply entails_L_eq_le_1, entails_idem. + Qed. + + Lemma entails_L_le_join {p x y z} : + p ⊢ℒ x ≼ z -> + p ⊢ℒ y ≼ z -> + p ⊢ℒ x ∨ y ≼ z. + Proof. + move=> le le'. + have := entails_L_le_congr le le' => comb. + eapply entails_L_le_trans; tea. + eapply entails_L_le_idem. + Qed. + + Lemma entails_clause_pres {cls} cl : + entails cls cl -> + entails_L_clause (presentation_of_clauses cls) cl. + Proof. + intros h; induction h. + - red. + now apply entails_L_idem_gen. + - move: IHh; rewrite -!univ_union_add_singleton. + eapply in_pred_closure_entails_L in H. + rewrite /entails_L_clause in H |- *; cbn in *. + have hsub:= entails_L_subset H H0. red in hsub. + move=> h'. + eapply entails_L_le_trans. tea. + move/entails_L_eq_le_1: hsub. now rewrite univ_union_comm. + Qed. + + Definition entails_L_clauses cls cls' := + Clauses.For_all (entails_L_clause (presentation_of_clauses cls)) cls'. + + Lemma entails_clauses_pres {cls} cls' : + cls ⊢ℋ cls' -> + entails_L_clauses cls cls'. + Proof. + move=> h cl /h. apply entails_clause_pres. + Qed. + + Lemma entails_L_clauses_eq {cls s t} : + entails_L_clauses cls (s ≡ t) <-> + entails_L_clauses cls (s ⋞ t) /\ entails_L_clauses cls (t ⋞ s). + Proof. + rewrite /entails_L_clauses /clauses_of_eq. + split. + - intros ha; split => l; move:(ha l); rewrite Clauses.union_spec; + intros he hle; apply he; now constructor. + - intros [le le'] l. + rewrite Clauses.union_spec; intros []; [apply le|apply le']; assumption. + Qed. + + (* Lemma relations_of_clauses_of_constraints cstr (cstrs : ZUnivConstraintSet.t) (l r : premises) : + ZUnivConstraintSet.In cstr cstrs <-> + In (relation_of_constraint cstr) (relations_of_clauses (of_z_constraints cstrs)). + Proof. + split. + - move=> hin. + set (cls := of_z_constraints cstrs). + have hs := @relations_of_clauses_spec_inv cls. + (* have hcut : forall cl, Clauses.In cl (of_z_constraints cstrs) -> *) + rewrite /of_z_constraints. + + + Lemma presentation_of_spec cstrs : + equivlistA Logic.eq (presentation_of cstrs).(C) (presentation_of_clauses (of_z_constraints cstrs)).(C). + Proof. + rewrite /presentation_of /presentation_of_clauses //=. + intros [prems concl]; rewrite !InA_In_eq. + rewrite relations_of_constraints_spec. + split. + - intros [c [hin heq]]. + destruct c as [[l []] r]. cbn in heq; noconf heq. + move: cstrs l r hin. + have cls := @of_z_constraints_spec cstrs. + + (l, r). + rewrite relations_of_clauses_spec. *) + + + Lemma entails_L_split p (s t : premises) : + (forall le, LevelExprSet.In le s -> p ⊢ℒ singleton le ≼ t) -> + p ⊢ℒ s ≼ t. + Proof. + move: s; apply: NES.elim. + - intros [l k] ih. eapply ih. + now apply LevelExprSet.singleton_spec. + - move=> le x h hnin ih. + forward h. + { move=> le' hin. move: (ih le') => /fwd //. + eapply LevelExprSet.add_spec. now right. } + specialize (ih le); forward ih. + eapply LevelExprSet.add_spec; now left. + rewrite -univ_union_add_singleton. + now eapply entails_L_le_join. + Qed. + + Lemma entails_L_le_left {p x y} : + p ⊢ℒ x ≼ x ∨ y. + Proof. + red. rewrite -univ_union_assoc. + eapply entails_join_congr_all. apply entails_idem. apply entails_refl. + Qed. + + Lemma entails_L_le_right {p x y} : + p ⊢ℒ y ≼ x ∨ y. + Proof. + rewrite univ_union_comm; apply entails_L_le_left. + Qed. + + Lemma entails_L_in p l (t : premises) : + LevelExprSet.In l t -> + p ⊢ℒ NES.singleton l ≼ t. + Proof. + move: t; apply: NES.elim. + - move=>[l' k] /LevelExprSet.singleton_spec => ->. + apply entails_L_le_refl. + - move=> le x h hnin /NES.add_spec []. + * intros ->. rewrite -univ_union_add_singleton. + apply entails_L_le_right. + * move/h => hle. + rewrite -univ_union_add_singleton. + eapply entails_L_le_trans with x => //. + apply entails_L_le_left. + Qed. + + Lemma entails_L_clauses_all {cstrs s t} : + (presentation_of_clauses (of_z_constraints cstrs)) ⊢ℒ s ≈ t -> + (presentation_of cstrs) ⊢ℒ s ≈ t. + Proof. + induction 1; try solve [econstructor; eauto]. cbn in H. + move/relations_of_clauses_spec: H => [prems [concl [hin heq]]]. + noconf heq. + move/of_z_constraints_spec: hin => [cstr [hin hin']]. + destruct cstr as [[l d] r]. + eapply LoopCheck.to_clauses_spec in hin'. + destruct d; eapply entails_L_le_eq. + - destruct hin' as [? [hin' heq]]. noconf heq. + eapply entails_L_le_trans with l. + * now eapply entails_L_in. + * constructor. cbn. rewrite relations_of_constraints_spec. + eexists; split; tea. now cbn. + - destruct hin' as [hin'|hin']; + destruct hin' as [? [hin' heq]]; noconf heq. + * eapply entails_L_le_trans with l. + + now eapply entails_L_in. + + eapply entails_L_eq_le_1. + constructor. cbn. rewrite relations_of_constraints_spec. + eexists; split; tea. cbn. now cbn. + * eapply entails_L_le_trans with r. + + now eapply entails_L_in. + + eapply entails_L_eq_le_1. apply entails_sym. + constructor. cbn. rewrite relations_of_constraints_spec. + eexists; split; tea. cbn. now cbn. + Qed. + + Lemma entails_L_clauses_le {cstrs s t} : + entails_L_clauses (of_z_constraints cstrs) (s ⋞ t) -> + presentation_of cstrs ⊢ℒ s ≼ t. + Proof. + intros hf. do 2 red in hf. rw_in clauses_of_le_spec hf. + eapply entails_L_split. + move=> le hin. + move: (hf (t, le)) => /fwd. + { exists le; split => //. } + move=> h; red in h. cbn in h. + now eapply entails_L_clauses_all in h. + Qed. + + Lemma entails_L_clauses_of_eq {cstrs s t} : + entails_L_clauses (of_z_constraints cstrs) (s ≡ t) -> + presentation_of cstrs ⊢ℒ s ≈ t. + Proof. + intros hf. do 2 red in hf. + eapply entails_L_eq_antisym. + all: apply entails_L_clauses_le. + - intros cl hin; red. eapply hf. + rewrite /clauses_of_eq. clsets. + - intros cl hin; red. eapply hf. + rewrite /clauses_of_eq. clsets. + Qed. + + Lemma completeness cstrs s t : + entails_L (presentation_of cstrs) s t <-> + entails_z_cstr cstrs (s, ConstraintType.Eq, t). + Proof. + unfold entails_z_cstr. + split. + - induction 1; cbn. + move: H => //=; rewrite relations_of_constraints_spec => -[] [[l' []] r'] [hin heq]; noconf heq. + * eapply Theory.le_spec. + now apply entails_clauses_le_cstr. + * now eapply entails_clauses_eq_cstr. + * eapply Theory.eq_refl. + * now eapply Theory.eq_sym. + * now eapply Theory.eq_trans. + * now eapply Theory.succ_congr. + * now eapply Theory.join_congr_left. + * eapply Theory.join_assoc. + * eapply Theory.join_idem. + * eapply Theory.join_comm. + * eapply Theory.join_succ. + * now eapply Theory.succ_inj. + * eapply Theory.succ_join. + - move/entails_clauses_pres; apply entails_L_clauses_of_eq. + Qed. + Import LoopCheck.Impl.I.Model.Model.Clauses.FLS. End UnivLoopChecking. diff --git a/template-rocq/theories/SemiLattice.v b/template-rocq/theories/SemiLattice.v index 5c2b972b3..88c8e5343 100644 --- a/template-rocq/theories/SemiLattice.v +++ b/template-rocq/theories/SemiLattice.v @@ -2,40 +2,15 @@ From Stdlib Require Import ssreflect ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils. +From MetaRocq.Utils Require Import utils NonEmptyLevelExprSet. -From MetaRocq.Common Require Universes. +From MetaRocq.Common Require Universes HornClauses. From Equations Require Import Equations. Set Equations Transparent. +End Completeness. -Section Completeness. - Reserved Notation "x ≡ y" (at level 90). - Record semilattice := - { carrier :> Type; - eq : carrier -> carrier -> Prop where "x ≡ y" := (eq x y); - succ : carrier -> carrier; - join : carrier -> carrier -> carrier; - join_assoc x y z : join x (join y z) ≡ join (join x y) z; - join_comm x y : join x y ≡ join y x; - join_idem x : join x x ≡ x; - join_sub x : join x (succ x) ≡ succ x; - succ_inj : forall x y, succ x ≡ succ y -> x ≡ y; - succ_join : forall x y, succ (join x y) ≡ join (succ x) (succ y); - }. - - Notation "x ≡ y" := (eq _ x y). - - Section Derived. - Context (s : semilattice). - Definition le (x y : s) := join s x y ≡ y. - - Fixpoint add (x : s) n : s := - match n with - | 0 => x - | S n => succ _ (add x n) - end. - End Derived. +Section Presentation. Definition term (V : Type) : Type := list (V * nat). Definition relation (V : Type) := term V -> term V -> Prop. diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v index 12792d3b3..579d5284d 100644 --- a/utils/theories/NonEmptyLevelExprSet.v +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -468,6 +468,14 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) cbn. firstorder. subst x'. now left. Qed. + Lemma univ_union_assoc {s t u} : univ_union (univ_union s t) u = + univ_union s (univ_union t u). + Proof. + apply equal_exprsets. + intros x. rewrite !univ_union_spec. + intuition auto. + Qed. + Lemma map_map f g x : map f (map g x) = map (f ∘ g) x. Proof. apply equal_exprsets. From f4c3680fb38b6ffd692b0bc883f110557fd8c078 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 15 Sep 2025 17:34:11 +0200 Subject: [PATCH 055/164] Cleanup a bit --- .../theories/LoopChecking/UnivLoopChecking.v | 30 +------------------ 1 file changed, 1 insertion(+), 29 deletions(-) diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v index 945758d3f..89c0f9459 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -1422,34 +1422,6 @@ End ZUnivConstraint. rewrite Clauses.union_spec; intros []; [apply le|apply le']; assumption. Qed. - (* Lemma relations_of_clauses_of_constraints cstr (cstrs : ZUnivConstraintSet.t) (l r : premises) : - ZUnivConstraintSet.In cstr cstrs <-> - In (relation_of_constraint cstr) (relations_of_clauses (of_z_constraints cstrs)). - Proof. - split. - - move=> hin. - set (cls := of_z_constraints cstrs). - have hs := @relations_of_clauses_spec_inv cls. - (* have hcut : forall cl, Clauses.In cl (of_z_constraints cstrs) -> *) - rewrite /of_z_constraints. - - - Lemma presentation_of_spec cstrs : - equivlistA Logic.eq (presentation_of cstrs).(C) (presentation_of_clauses (of_z_constraints cstrs)).(C). - Proof. - rewrite /presentation_of /presentation_of_clauses //=. - intros [prems concl]; rewrite !InA_In_eq. - rewrite relations_of_constraints_spec. - split. - - intros [c [hin heq]]. - destruct c as [[l []] r]. cbn in heq; noconf heq. - move: cstrs l r hin. - have cls := @of_z_constraints_spec cstrs. - - (l, r). - rewrite relations_of_clauses_spec. *) - - Lemma entails_L_split p (s t : premises) : (forall le, LevelExprSet.In le s -> p ⊢ℒ singleton le ≼ t) -> p ⊢ℒ s ≼ t. @@ -1553,7 +1525,7 @@ End ZUnivConstraint. Qed. Lemma completeness cstrs s t : - entails_L (presentation_of cstrs) s t <-> + presentation_of cstrs ⊢ℒ s ≈ t <-> entails_z_cstr cstrs (s, ConstraintType.Eq, t). Proof. unfold entails_z_cstr. From 620e59bdfa8b437f4d1aa92fd96e0d64f39da280 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 15 Sep 2025 17:38:44 +0200 Subject: [PATCH 056/164] Completeness for le also --- .../theories/LoopChecking/UnivLoopChecking.v | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v index 89c0f9459..f8e3b0564 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -1524,7 +1524,7 @@ End ZUnivConstraint. rewrite /clauses_of_eq. clsets. Qed. - Lemma completeness cstrs s t : + Lemma completeness_eq cstrs s t : presentation_of cstrs ⊢ℒ s ≈ t <-> entails_z_cstr cstrs (s, ConstraintType.Eq, t). Proof. @@ -1549,6 +1549,18 @@ End ZUnivConstraint. - move/entails_clauses_pres; apply entails_L_clauses_of_eq. Qed. + Lemma completeness_le cstrs s t : + presentation_of cstrs ⊢ℒ s ≼ t <-> + entails_z_cstr cstrs (s, ConstraintType.Le, t). + Proof. + unfold entails_z_cstr. + split. + - move/completeness_eq. cbn. + intros h; red in h. cbn in h. + eapply Theory.le_spec. now rewrite /C.le. + - move/entails_clauses_pres. apply entails_L_clauses_le. + Qed. + Import LoopCheck.Impl.I.Model.Model.Clauses.FLS. End UnivLoopChecking. From a420a6d7a1870ee7b230882a217a30d8b4a08ea1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 18 Sep 2025 10:14:16 +0200 Subject: [PATCH 057/164] Improve notations setup --- common/theories/LoopChecking/HornClauses.v | 2 +- .../theories/LoopChecking/UnivLoopChecking.v | 783 +++++++++++++++--- 2 files changed, 688 insertions(+), 97 deletions(-) diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index b01988695..3659712e5 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -1691,7 +1691,7 @@ Module Clauses (LS : LevelSets). rewrite ih. right; firstorder. Qed. - Infix "∨" := univ_union (at level 58). + Infix "∨" := univ_union (at level 10). Notation succ x := (add_prems 1%Z x). Definition clauses_of_eq (u v : NES.t) := diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v index f8e3b0564..7d1bef180 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -255,6 +255,8 @@ End ZUnivConstraint. Module ZUnivConstraintSetFact := WFactsOn ZUnivConstraint ZUnivConstraintSet. Module ZUnivConstraintSetOrdProp := MSetProperties.OrdProperties ZUnivConstraintSet. Module ZUnivConstraintSetProp := ZUnivConstraintSetOrdProp.P. + Module ZUnivConstraintSetDecide := WDecide ZUnivConstraintSet. + Ltac zucsets := ZUnivConstraintSetDecide.fsetdec. Definition of_z_constraints (x : ZUnivConstraintSet.t) : Clauses.t := ZUnivConstraintSet.fold (fun c cls => @@ -898,6 +900,45 @@ End ZUnivConstraint. UnivConstraintSet.fold (fun c acc => ZUnivConstraintSet.add (to_constraint c) acc) cstrs ZUnivConstraintSet.empty. + Lemma to_z_cstrs_spec_1 {cstrs} : + forall c, UnivConstraintSet.In c cstrs -> + (exists cstrz, ZUnivConstraintSet.In cstrz (to_z_cstrs cstrs) /\ + cstrz = to_constraint c). + Proof. + rewrite /to_z_cstrs. + eapply UnivConstraintSetProp.fold_rec. + - now move=> s' he c /he. + - intros x a s' s'' hin hnin hadd h cl. + rw ZUnivConstraintSet.add_spec => /hadd []. + * intros ->. eexists; split => //. now left. + * move/h => [cstr [hin' incl]]. subst cstr. + exists (to_constraint cl). firstorder. + Qed. + + Lemma to_z_cstrs_spec_2 {cstrs} : + forall c, ZUnivConstraintSet.In c (to_z_cstrs cstrs) -> + (exists cstr, UnivConstraintSet.In cstr cstrs /\ + c = to_constraint cstr). + Proof. + rewrite /to_z_cstrs. + eapply UnivConstraintSetProp.fold_rec. + - move=> s' he c. zucsets. + - intros x a s' s'' hin hnin hadd h c. + rewrite ZUnivConstraintSet.add_spec => -[]. + * intros ->. eexists; split => //. apply hadd. now left. + * move/h => [cstr [hin' incl]]. subst c. + exists cstr. firstorder. + Qed. + + (* Lemma to_z_cstrs_spec {cstrs} : + forall c, UnivConstraintSet.In c cstrs <-> ZUnivConstraintSet.In (to_constraint c) (to_z_cstrs cstrs). + Proof. + intros c; split. + - by move/to_z_cstrs_spec_1 => [] cstrz [] hin heq; subst cstrz. + - move/to_z_cstrs_spec_2 => [] cstr [] hin heq. + destruct c as [[] ?], cstr as [[] ?]; cbn in heq. noconf heq. *) + + Lemma check_valid m c : check m c <-> entails_cstr (constraints m) c. Proof. @@ -973,28 +1014,39 @@ End ZUnivConstraint. Import Semilattice. + Definition rel := premises × premises. + Definition rels := list rel. + Record presentation := { V : LevelSet.t; C : list (NES.t × NES.t); }. - Inductive entails_L (p : presentation) : NES.t -> NES.t -> Prop := - | entails_c {l r} : List.In (l, r) p.(C) -> entails_L p l r - | entails_refl {x} : entails_L p x x - | entails_sym {x y} : entails_L p x y -> entails_L p y x - | entails_trans {x y z} : entails_L p x y -> entails_L p y z -> entails_L p x z - | entails_succ_congr {x y n} : entails_L p x y -> entails_L p (add_prems n x) (add_prems n y) - | entails_join_congr {x y r} : entails_L p x y -> entails_L p (x ∨ r) (y ∨ r) - | entails_assoc {x y z} : entails_L p ((x ∨ y) ∨ z) (x ∨ (y ∨ z)) - | entails_idem {x} : entails_L p (x ∨ x) x - | entails_comm {x y} : entails_L p (x ∨ y) (y ∨ x) - | entails_sub {x} : entails_L p (x ∨ succ_prems x) (succ_prems x) - | entails_succ_inj {x y n} : entails_L p (add_prems n x) (add_prems n y) -> - entails_L p x y - | entails_succ_join {x y} : entails_L p (succ_prems (x ∨ y)) (succ_prems x ∨ succ_prems y). - - Definition entails_L_curry p eq := entails_L p eq.1 eq.2. - - Lemma entails_join_congr_all {p} {x x' y y'} : entails_L p x x' -> entails_L p y y' -> entails_L p (x ∨ y) (x' ∨ y'). + Definition rel_eq (x y : premises) := (x, y). + Definition rel_le (x y : premises) := (x ∨ y, y). + + Delimit Scope rel_scope with rel. + Infix "≡" := rel_eq (at level 60, no associativity) : rel_scope. + Infix "≤" := rel_le (at level 50, no associativity) : rel_scope. + + Reserved Notation " p ⊢ℒ r " (at level 62, no associativity). + + Inductive entails_L (p : rels) : NES.t × NES.t -> Prop := + | entails_c {l r} : List.In (l, r) p -> p ⊢ℒ l ≡ r + | entails_refl {x} : p ⊢ℒ x ≡ x + | entails_sym {x y} : p ⊢ℒ x ≡ y -> p ⊢ℒ y ≡ x + | entails_trans {x y z} : p ⊢ℒ x ≡ y -> p ⊢ℒ y ≡ z -> p ⊢ℒ x ≡ z + | entails_succ_congr {x y n} : p ⊢ℒ x ≡ y -> p ⊢ℒ add_prems n x ≡ add_prems n y + | entails_join_congr {x y r} : p ⊢ℒ x ≡ y -> p ⊢ℒ (x ∨ r) ≡ (y ∨ r) + | entails_assoc {x y z} : p ⊢ℒ ((x ∨ y) ∨ z) ≡ (x ∨ (y ∨ z)) + | entails_idem {x} : p ⊢ℒ (x ∨ x) ≡ x + | entails_comm {x y} : p ⊢ℒ (x ∨ y) ≡ (y ∨ x) + | entails_sub {x} : p ⊢ℒ (x ∨ succ_prems x) ≡ (succ_prems x) + | entails_succ_inj {x y n} : p ⊢ℒ (add_prems n x) ≡ (add_prems n y) -> p ⊢ℒ x ≡ y + | entails_succ_join {x y} : p ⊢ℒ (succ_prems (x ∨ y)) ≡ (succ_prems x ∨ succ_prems y) + where " p ⊢ℒ r " := (entails_L p r%_rel). + + Lemma entails_join_congr_all {p} {x x' y y'} : + p ⊢ℒ x ≡ x' -> p ⊢ℒ y ≡ y' -> p ⊢ℒ (x ∨ y) ≡ (x' ∨ y'). Proof. intros he he'. eapply entails_trans with (x' ∨ y). @@ -1003,14 +1055,14 @@ End ZUnivConstraint. now apply entails_join_congr. Qed. - Lemma entails_join_congr_all_inv {p} {x x' y z} : entails_L p (x ∨ y) z -> entails_L p x x' -> entails_L p (x' ∨ y) z. + Lemma entails_join_congr_all_inv {p} {x x' y z} : p ⊢ℒ (x ∨ y) ≡ z -> p ⊢ℒ x ≡ x' -> p ⊢ℒ (x' ∨ y) ≡ z. Proof. intros he he'. eapply entails_trans with (x ∨ y) => //. apply entails_join_congr => //. now eapply entails_sym. Qed. - Lemma entails_join_congr_all_inv_r {p} {x y y' z} : entails_L p (x ∨ y) z -> entails_L p y y' -> entails_L p (x ∨ y') z. + Lemma entails_join_congr_all_inv_r {p} {x y y' z} : p ⊢ℒ (x ∨ y) ≡ z -> p ⊢ℒ y ≡ y' -> p ⊢ℒ (x ∨ y') ≡ z. Proof. intros he he'. eapply entails_trans with (x ∨ y) => //. @@ -1065,24 +1117,19 @@ End ZUnivConstraint. Qed. End pres_Semilattice. - Definition entails_L_le p l r := (entails_L p (l ∨ r) r). - Notation " p ⊢ℒ t ≼ u " := (entails_L_le p t u) (t, u at next level, at level 62, no associativity). - Notation " p ⊢ℒ t ≈ u " := (entails_L p t u) (t, u at next level, at level 62, no associativity). - Hint Constructors entails_L : entails_L. Lemma entails_L_le_refl p x : - p ⊢ℒ x ≼ x. + p ⊢ℒ x ≤ x. Proof. eapply entails_idem. Qed. Lemma entails_L_le_trans p x y z : - p ⊢ℒ x ≼ y -> p ⊢ℒ y ≼ z -> p ⊢ℒ x ≼ z. + p ⊢ℒ x ≤ y -> p ⊢ℒ y ≤ z -> p ⊢ℒ x ≤ z. Proof. intros le le'. eapply entails_trans. 2:exact le'. - red in le, le'. eapply entails_trans with (x ∨ y ∨ z). rewrite univ_union_assoc. eapply entails_sym. eapply entails_join_congr_all => //. apply entails_refl. @@ -1101,42 +1148,21 @@ End ZUnivConstraint. Qed. Lemma incl_entails_L {cls} {u u' : premises} : - u ⊂_leset u' -> cls ⊢ℒ u ≼ u'. + u ⊂_leset u' -> cls ⊢ℒ u ≤ u'. Proof. - move=> hincl; red. + move=> hincl. unfold rel_le. rewrite subset_univ_union //; auto with entails_L. Qed. Lemma entails_L_subset {cls} {prems prems' prems'' : premises} : - cls ⊢ℒ prems ≼ prems' -> + cls ⊢ℒ prems ≤ prems' -> prems' ⊂_leset prems'' -> - cls ⊢ℒ prems ≼ prems''. + cls ⊢ℒ prems ≤ prems''. Proof. move=> heq /(@incl_entails_L cls). now eapply entails_L_le_trans. Qed. - (* Section interp. - Context (p : presentation). - Let s := pres_semilattice p. - Definition interp_atom le := - let '(l, k) := le in - (singleton (l, 0)) (Z.to_nat k). - - Definition interp_univ l := - let '(e, u) := NES.to_nonempty_list l in - List.fold_left (fun acc a => s.(join) (interp_atom a) acc) u (interp_atom e). - - Definition interp_cstr c := - let '(l, d, r) := c in - match d with - | ConstraintType.Le => le s (interp_univ l) (interp_univ r) - | ConstraintType.Eq => s.(eq) (interp_univ l) (interp_univ r) - end. - - Definition interp_cstrs c := - ZUnivConstraintSet.For_all (fun c => interp_cstr c) c. - End interp. *) Definition relation_of_constraint c := let '(l, d, r) := c in @@ -1152,9 +1178,22 @@ End ZUnivConstraint. Definition relations_of_constraints c := ZUnivConstraintSet.fold (fun c acc => relation_of_constraint c :: acc) c []. - Lemma relations_of_constraints_spec {l r cstrs} : List.In (l, r) (relations_of_constraints cstrs) <-> - exists cl, ZUnivConstraintSet.In cl cstrs /\ (l, r) = relation_of_constraint cl. - Proof. Admitted. + Lemma relations_of_constraints_spec {r cstrs} : List.In r (relations_of_constraints cstrs) <-> + exists cl, ZUnivConstraintSet.In cl cstrs /\ r = relation_of_constraint cl. + Proof. + rewrite /relations_of_constraints. + eapply ZUnivConstraintSetProp.fold_rec. + - move=> s' he; split => //. + intros [cl []]. now apply he in H. + - move=> x a s' s'' hni hnin hadd. + split. + { cbn. move=> [] h. + * exists x. split => //. apply hadd. now left. + * apply H in h as [cl []]; eexists; split; tea. apply hadd. now right. } + { move=> [] cl [] /hadd[]. + * intros -> ->. now left. + * intros hin heq. right; apply H. exists cl; split => //. } + Qed. Definition levels_of_z_constraints c := ZUnivConstraintSet.fold (fun c acc => LevelSet.union (Zuniv_constraint_levels c) acc) c LevelSet.empty. @@ -1164,7 +1203,7 @@ End ZUnivConstraint. C := relations_of_constraints cstrs |}. Definition entails_L_clause p cl := - entails_L_le p (singleton (concl cl)) (premise cl). + p ⊢ℒ singleton (concl cl) ≤ premise cl. Definition relations_of_clauses c := Clauses.fold (fun '(prems, concl) acc => (singleton concl ∨ prems, prems) :: acc) c []. @@ -1281,7 +1320,7 @@ End ZUnivConstraint. Lemma entails_L_idem_gen {le} {prems : premises} {p} : LevelExprSet.In le prems -> - entails_L p ((singleton le) ∨ prems) prems. + p ⊢ℒ (singleton le) ∨ prems ≡ prems. Proof. move: prems; apply: NES.elim. - move=> le' /LevelExprSet.singleton_spec <-. @@ -1309,10 +1348,10 @@ End ZUnivConstraint. Lemma in_pred_closure_entails_L {cls} cl : in_pred_closure cls cl -> - entails_L_clause (presentation_of_clauses cls) cl. + entails_L_clause (relations_of_clauses cls) cl. Proof. induction 1. - - rewrite /entails_L_clause /entails_L_le. + - rewrite /entails_L_clause /rel_le. destruct cl as [prems concl]; cbn. rewrite -add_prems_singleton -add_prems_univ_union. apply entails_succ_congr. @@ -1322,44 +1361,44 @@ End ZUnivConstraint. eapply entails_sub. Qed. - Lemma entails_L_le_eq {cls l r} : cls ⊢ℒ l ≼ r -> cls ⊢ℒ l ∨ r ≈ r. + Lemma entails_L_le_eq {cls l r} : cls ⊢ℒ l ≤ r -> cls ⊢ℒ l ∨ r ≡ r. Proof. trivial. Qed. - Lemma entails_L_eq_le_1 {cls} {l r} : cls ⊢ℒ l ≈ r -> cls ⊢ℒ l ≼ r. + Lemma entails_L_eq_le_1 {cls} {l r} : cls ⊢ℒ l ≡ r -> cls ⊢ℒ l ≤ r. Proof. - intros eq; red. + intros eq; unfold rel_le. eapply (entails_join_congr_all_inv (x := r)). eapply entails_idem. now eapply entails_sym. Qed. - Lemma entails_L_eq_le_2 {cls} {l r} : cls ⊢ℒ l ≈ r -> cls ⊢ℒ r ≼ l. + Lemma entails_L_eq_le_2 {cls} {l r} : cls ⊢ℒ l ≡ r -> cls ⊢ℒ r ≤ l. Proof. - intros eq; red. + intros eq; unfold rel_le. eapply entails_sym in eq. now eapply entails_L_eq_le_1 in eq. Qed. - Lemma entails_L_eq_antisym {cls} {l r} : cls ⊢ℒ r ≼ l -> cls ⊢ℒ l ≼ r -> cls ⊢ℒ l ≈ r. + Lemma entails_L_eq_antisym {cls} {l r} : cls ⊢ℒ r ≤ l -> cls ⊢ℒ l ≤ r -> cls ⊢ℒ l ≡ r. Proof. - unfold entails_L_le. intros le le'. + unfold rel_le. intros le le'. eapply entails_trans with (l ∨ r) => //. apply entails_sym. now rewrite univ_union_comm. Qed. Lemma entails_L_le_join_l {p x x' r} : - p ⊢ℒ x ≼ x' -> - p ⊢ℒ x ∨ r ≼ x' ∨ r. + p ⊢ℒ x ≤ x' -> + p ⊢ℒ (x ∨ r) ≤ (x' ∨ r). Proof. intros le. - red in le |- *. + unfold rel_le in le |- *. rewrite univ_union_assoc (@univ_union_comm r) univ_union_assoc -univ_union_assoc. eapply entails_join_congr_all => //. apply entails_idem. Qed. Lemma entails_L_le_congr {p x y x' y'} : - p ⊢ℒ x ≼ x' -> - p ⊢ℒ y ≼ y' -> - p ⊢ℒ x ∨ y ≼ x' ∨ y'. + p ⊢ℒ x ≤ x' -> + p ⊢ℒ y ≤ y' -> + p ⊢ℒ x ∨ y ≤ x' ∨ y'. Proof. move/(entails_L_le_join_l (r:=y)) => le le'. eapply entails_L_le_trans; tea. @@ -1368,15 +1407,15 @@ End ZUnivConstraint. Qed. Lemma entails_L_le_idem {p x} : - p ⊢ℒ x ∨ x ≼ x. + p ⊢ℒ x ∨ x ≤ x. Proof. eapply entails_L_eq_le_1, entails_idem. Qed. Lemma entails_L_le_join {p x y z} : - p ⊢ℒ x ≼ z -> - p ⊢ℒ y ≼ z -> - p ⊢ℒ x ∨ y ≼ z. + p ⊢ℒ x ≤ z -> + p ⊢ℒ y ≤ z -> + p ⊢ℒ x ∨ y ≤ z. Proof. move=> le le'. have := entails_L_le_congr le le' => comb. @@ -1386,7 +1425,7 @@ End ZUnivConstraint. Lemma entails_clause_pres {cls} cl : entails cls cl -> - entails_L_clause (presentation_of_clauses cls) cl. + entails_L_clause (relations_of_clauses cls) cl. Proof. intros h; induction h. - red. @@ -1400,19 +1439,19 @@ End ZUnivConstraint. move/entails_L_eq_le_1: hsub. now rewrite univ_union_comm. Qed. - Definition entails_L_clauses cls cls' := - Clauses.For_all (entails_L_clause (presentation_of_clauses cls)) cls'. + Definition entails_L_clauses p cls := + Clauses.For_all (entails_L_clause p) cls. Lemma entails_clauses_pres {cls} cls' : cls ⊢ℋ cls' -> - entails_L_clauses cls cls'. + entails_L_clauses (relations_of_clauses cls) cls'. Proof. move=> h cl /h. apply entails_clause_pres. Qed. - Lemma entails_L_clauses_eq {cls s t} : - entails_L_clauses cls (s ≡ t) <-> - entails_L_clauses cls (s ⋞ t) /\ entails_L_clauses cls (t ⋞ s). + Lemma entails_L_clauses_eq {p s t} : + entails_L_clauses p (s ≡ t) <-> + entails_L_clauses p (s ⋞ t) /\ entails_L_clauses p (t ⋞ s). Proof. rewrite /entails_L_clauses /clauses_of_eq. split. @@ -1423,8 +1462,8 @@ End ZUnivConstraint. Qed. Lemma entails_L_split p (s t : premises) : - (forall le, LevelExprSet.In le s -> p ⊢ℒ singleton le ≼ t) -> - p ⊢ℒ s ≼ t. + (forall le, LevelExprSet.In le s -> p ⊢ℒ singleton le ≤ t) -> + p ⊢ℒ s ≤ t. Proof. move: s; apply: NES.elim. - intros [l k] ih. eapply ih. @@ -1440,21 +1479,21 @@ End ZUnivConstraint. Qed. Lemma entails_L_le_left {p x y} : - p ⊢ℒ x ≼ x ∨ y. + p ⊢ℒ x ≤ x ∨ y. Proof. red. rewrite -univ_union_assoc. eapply entails_join_congr_all. apply entails_idem. apply entails_refl. Qed. Lemma entails_L_le_right {p x y} : - p ⊢ℒ y ≼ x ∨ y. + p ⊢ℒ y ≤ x ∨ y. Proof. rewrite univ_union_comm; apply entails_L_le_left. Qed. Lemma entails_L_in p l (t : premises) : LevelExprSet.In l t -> - p ⊢ℒ NES.singleton l ≼ t. + p ⊢ℒ NES.singleton l ≤ t. Proof. move: t; apply: NES.elim. - move=>[l' k] /LevelExprSet.singleton_spec => ->. @@ -1469,8 +1508,8 @@ End ZUnivConstraint. Qed. Lemma entails_L_clauses_all {cstrs s t} : - (presentation_of_clauses (of_z_constraints cstrs)) ⊢ℒ s ≈ t -> - (presentation_of cstrs) ⊢ℒ s ≈ t. + (relations_of_clauses (of_z_constraints cstrs)) ⊢ℒ s ≡ t -> + (relations_of_constraints cstrs) ⊢ℒ s ≡ t. Proof. induction 1; try solve [econstructor; eauto]. cbn in H. move/relations_of_clauses_spec: H => [prems [concl [hin heq]]]. @@ -1499,8 +1538,8 @@ End ZUnivConstraint. Qed. Lemma entails_L_clauses_le {cstrs s t} : - entails_L_clauses (of_z_constraints cstrs) (s ⋞ t) -> - presentation_of cstrs ⊢ℒ s ≼ t. + entails_L_clauses (relations_of_clauses (of_z_constraints cstrs)) (s ⋞ t) -> + relations_of_constraints cstrs ⊢ℒ s ≤ t. Proof. intros hf. do 2 red in hf. rw_in clauses_of_le_spec hf. eapply entails_L_split. @@ -1512,8 +1551,8 @@ End ZUnivConstraint. Qed. Lemma entails_L_clauses_of_eq {cstrs s t} : - entails_L_clauses (of_z_constraints cstrs) (s ≡ t) -> - presentation_of cstrs ⊢ℒ s ≈ t. + entails_L_clauses (relations_of_clauses (of_z_constraints cstrs)) (s ≡ t) -> + relations_of_constraints cstrs ⊢ℒ s ≡ t. Proof. intros hf. do 2 red in hf. eapply entails_L_eq_antisym. @@ -1524,8 +1563,53 @@ End ZUnivConstraint. rewrite /clauses_of_eq. clsets. Qed. + Definition entails_L_cstr p c := + let '(l, d, r) := c in + match d with + | ConstraintType.Le => p ⊢ℒ l ≤ r + | ConstraintType.Eq => p ⊢ℒ l ≡ r + end. + + Lemma entails_L_clauses_cstr {cstrs c} : + entails_L_clauses (relations_of_clauses (of_z_constraints cstrs)) (LoopCheck.to_clauses c) -> + entails_L_cstr (relations_of_constraints cstrs) c. + Proof. + destruct c as [[l []] r]. + - cbn. apply entails_L_clauses_le. + - cbn. apply entails_L_clauses_of_eq. + Qed. + + Definition entails_L_cstrs p cstrs := + ZUnivConstraintSet.For_all (entails_L_cstr p) cstrs. + + Section interp. + Context (v : LevelMap.t nat). + + Definition interp_z_cstr c := + let '(l, d, r) := c in + match d with + | ConstraintType.Le => interp_prems v l <= interp_prems v r + | ConstraintType.Eq => interp_prems v l = interp_prems v r + end%Z. + + Definition interp_univ_cstr c := interp_z_cstr (to_constraint c). + + Definition interp_univ_cstrs c := + UnivConstraintSet.For_all interp_univ_cstr c. + + Definition interp_cstrs c := + List.Forall (fun '(l, r) => interp_prems v l = interp_prems v r) c. + End interp. + + Definition valid_constraint rels c := + (forall v, interp_cstrs v rels -> interp_z_cstr v c). + + Definition valid_cstrs p cstrs := + ZUnivConstraintSet.For_all (valid_constraint p) cstrs. + + Lemma completeness_eq cstrs s t : - presentation_of cstrs ⊢ℒ s ≈ t <-> + relations_of_constraints cstrs ⊢ℒ s ≡ t <-> entails_z_cstr cstrs (s, ConstraintType.Eq, t). Proof. unfold entails_z_cstr. @@ -1550,7 +1634,7 @@ End ZUnivConstraint. Qed. Lemma completeness_le cstrs s t : - presentation_of cstrs ⊢ℒ s ≼ t <-> + relations_of_constraints cstrs ⊢ℒ s ≤ t <-> entails_z_cstr cstrs (s, ConstraintType.Le, t). Proof. unfold entails_z_cstr. @@ -1563,4 +1647,511 @@ End ZUnivConstraint. Import LoopCheck.Impl.I.Model.Model.Clauses.FLS. + Definition presentation_entails cstrs c := + let '(l, d, r) := to_constraint c in + match d with + | ConstraintType.Le => relations_of_constraints (to_z_cstrs cstrs) ⊢ℒ l ≤ r + | ConstraintType.Eq => relations_of_constraints (to_z_cstrs cstrs) ⊢ℒ l ≡ r + end. + + Instance entils_claues_proper : Proper (Clauses.Equal ==> Clauses.Equal ==> iff) entails_clauses. + Proof. + intros cls cls' H cls0 cls0' H'. + rewrite /entails_clauses. + rewrite H'. split; intros hf l. now rewrite -H. now rewrite H. + Qed. + + Lemma to_clauses_of_z_constraints {cstrs} : + to_clauses cstrs =_clset of_z_constraints (to_z_cstrs cstrs). + Proof. + intros l. + rewrite to_clauses_spec of_z_constraints_spec. + split. + - intros [cstr [hin hin']]. + exists (to_constraint cstr). split. + apply to_z_cstrs_spec_1 in hin as [cstrz []]. + now subst cstrz. + assumption. + - intros [cstr [hin hin']]. + apply to_z_cstrs_spec_2 in hin as [cstr' [hin ->]]. + exists cstr'. split => //. + Qed. + + Lemma check_valid_pres m c : + check m c <-> presentation_entails (constraints m) c. + Proof. + rewrite check_valid. + destruct c as [[l []] r]; cbn. + - rewrite completeness_le. + rewrite /entails_cstr /entails_z_cstr. + now rewrite to_clauses_of_z_constraints. + - rewrite completeness_eq. + rewrite /entails_cstr /entails_z_cstr. + now rewrite to_clauses_of_z_constraints. + Qed. + + Lemma presentation_entails_valid_eq {p l r} : + p ⊢ℒ l ≡ r -> valid_constraint p (l, ConstraintType.Eq, r). + Proof. + rewrite /valid_constraint /interp_z_cstr //=. + induction 1; cbn; move=> v hv. + 1:by red in hv; rewrite Forall_forall in hv; eapply hv in H. + all:try specialize (IHentails_L _ hv). + all:try specialize (IHentails_L1 _ hv). + all:try specialize (IHentails_L2 _ hv). + all:try lia; eauto. + all:rewrite ?interp_add_prems ?interp_prems_union ?interp_add_prems; try lia. + rewrite ?interp_add_prems in IHentails_L. lia. + Qed. + + Lemma presentation_entails_valid_le {p l r} : + p ⊢ℒ l ≤ r -> valid_constraint p (l, ConstraintType.Le, r). + Proof. + rewrite /valid_constraint /interp_z_cstr //=. + move/presentation_entails_valid_eq => vc v hc. + specialize (vc v hc). cbn in vc. + rewrite interp_prems_union in vc. lia. + Qed. + + Lemma presentation_entails_valid {p c} : + entails_L_cstr p c -> valid_constraint p c. + Proof. + destruct c as [[l []] r]; cbn. + - apply presentation_entails_valid_le. + - apply presentation_entails_valid_eq. + Qed. + + Lemma presentation_entails_satisfies {p cstrs} : + entails_L_cstrs p cstrs -> valid_cstrs p cstrs. + Proof. + intros ha c hin. specialize (ha c hin). + now apply presentation_entails_valid. + Qed. + + (* Lemma entails_L_cstrs_spec {p cstrs} : + entails_L_cstrs p cstrs <-> entails_L_clauses p (of_z_constraints cstrs). + Proof. + rewrite /entails_L_cstrs. + split => //. + - intros hf cl hin. + eapply of_z_constraints_spec in hin as [cstr' [hin hin']]. + specialize (hf cstr' hin). + destruct cstr' as [[l []] r]. cbn in hf. + eapply LoopCheck.to_clauses_spec in hin'. + destruct hin' as [le [hin' eq]]. noconf eq. red. cbn. + apply entails_L_le_trans with l => //. now eapply entails_L_in. + cbn in hf. + eapply LoopCheck.to_clauses_spec in hin'. + destruct hin' as [[le [hin' eq]] | [le [hin' eq]]]; noconf eq; red; cbn. + apply entails_L_le_trans with l => //. now eapply entails_L_in. now apply entails_L_eq_le_1. + apply entails_L_le_trans with r => //. now eapply entails_L_in. now apply entails_L_eq_le_2. + - intros hf c hin. + admit. + Admitted. *) + + + (* Lemma model_valuation_of_cstrs : interp_cstrs (LoopCheck.valuation m) *) + + Lemma interp_cstrs_of_m m : interp_cstrs (LoopCheck.valuation (model m)) (relations_of_constraints (to_z_cstrs (constraints m))). + Proof. + have hv := (LoopCheck.model_valuation m.(model)). + red. + apply Forall_forall. move=> [l r] /relations_of_constraints_spec => -[cl [hin heq]]. + eapply to_z_cstrs_spec_2 in hin as [cstr [hin ->]]. + have hrepr := repr_constraints m _ hin. + destruct cstr as [[l' []] r']; cbn in heq; noconf heq. + - rewrite interp_prems_union. cbn in hrepr. + eapply clauses_sem_subset in hv; tea. + apply clauses_sem_clauses_of_le in hv. lia. + - cbn in hrepr. + eapply clauses_sem_subset in hv; tea. + rewrite /Clauses.clauses_of_eq in hv. + eapply clauses_sem_union in hv. destruct hv as [hv hv']. + apply clauses_sem_clauses_of_le in hv. + apply clauses_sem_clauses_of_le in hv'. lia. + Qed. + + Lemma interp_univ_cstrs_of_m m : + interp_univ_cstrs (LoopCheck.valuation (model m)) (constraints m). + Proof. + intros uc hin. red. + have h := repr_constraints m _ hin. + have hi := interp_cstrs_of_m m. + red in hi. rewrite Forall_forall in hi. + apply to_z_cstrs_spec_1 in hin as [cstrz [hin ->]]. + destruct uc as [[l []] r]; cbn. cbn in h. + - move: (hi (to_atoms l ∨ to_atoms r, to_atoms r)) => /fwd. + { apply relations_of_constraints_spec. exists (to_atoms l, ConstraintType.Le, to_atoms r). + cbn. split => //. } + by rewrite interp_prems_union; lia. + - move: (hi (to_atoms l, to_atoms r)) => /fwd. + { apply relations_of_constraints_spec. exists (to_atoms l, ConstraintType.Eq, to_atoms r). + cbn. split => //. } + by []. + Qed. + + Lemma interp_univ_cstrs_relations v cstrs : + interp_univ_cstrs v cstrs <-> + interp_cstrs v (relations_of_constraints (to_z_cstrs cstrs)). + Proof. + rewrite /interp_univ_cstrs. + split. + - intros hf. red in hf. red. + apply Forall_forall. move=> [l r] /relations_of_constraints_spec [[[l' d] r'] [hin heq]]. + cbn in heq; noconf heq. destruct d; noconf heq. + * eapply to_z_cstrs_spec_2 in hin as [cstr [hin heq]]. + destruct cstr as [[] ?]; noconf heq. specialize (hf _ hin). cbn in hf. + rewrite interp_prems_union. lia. + * eapply to_z_cstrs_spec_2 in hin as [cstr [hin heq]]. + destruct cstr as [[] ?]; noconf heq. specialize (hf _ hin). cbn in hf. + lia. + - intros hi uc hin. red in hi. rewrite Forall_forall in hi. + move: (hi (relation_of_constraint (to_constraint uc))) => /fwd. + rewrite relations_of_constraints_spec; exists (to_constraint uc); split => //. + now apply to_z_cstrs_spec_1 in hin as [cstrz [hin ->]]. + destruct uc as [[l []] r] => //=. + rewrite interp_prems_union //=; cbn. lia. + Qed. + + Lemma prop_dec (b : bool) P : b <-> P -> (b = false <-> ~ P). + Proof. intuition. now subst b. destruct b => //. destruct (H (H0 eq_refl)). Qed. + + Definition invalid_cstr v c := + let '(l, d, r) := c in + match d with + | ConstraintType.Eq => interp_prems v (to_atoms l) <> interp_prems v (to_atoms r) + | ConstraintType.Le => ~ (interp_prems v (to_atoms l) <= interp_prems v (to_atoms r))%Z + end. + + Section Completeness. + Definition consistent (r : rels) := + ~ (exists x, r ⊢ℒ x ≡ succ_prems x). + + Definition satisfiable (r : rels) := + exists v, interp_cstrs v r. + + Definition satisfiable_consistent {p} : + satisfiable p -> consistent p. + Proof. + intros [v it] [x hx]. + eapply presentation_entails_valid_eq in hx. red in hx. + specialize (hx _ it). + move: hx. cbn. + rewrite interp_add_prems. lia. + Qed. + + Definition add_presentation eq p := + {| V := p.(V); C := eq :: p.(C) |}. + + Definition relation_levels (r : rel) := NES.levels r.1 ∪ NES.levels r.2. + + Definition wf_presentation p := + forall r, List.In r p.(C) -> relation_levels r ⊂_lset p.(V). + + Definition maximally_consistent (r : rels) := + consistent r /\ forall x y, ~ consistent ((x, y) :: r) \/ r ⊢ℒ x ≡ y. + + Definition levels_position (l : Level.t) (ls : LevelSet.t) i := + List.nth_error (LevelSet.elements ls) i = Some l. + + Equations level_position (l : Level.t) (ls : list Level.t) : option nat := + level_position l [] := None ; + level_position l (x :: xs) with Level.eqb l x := + { | true => Some 0 + | false with level_position l xs := + | None => None + | Some n => Some (S n) }. + + Definition levelexpr_pos (l : LevelExpr.t) (ls : LevelSet.t) := + match level_position l.1 (LevelSet.elements ls) with + | None => 0 + | Some pos => LevelSet.cardinal ls * Z.to_nat l.2 + pos + end. + + Section Enum. + + Inductive enumeration : premises × premises -> Type := + | enum_single le le' : enumeration (singleton le, singleton le') + | enum_add_left le (u v : premises) : ~ LevelExprSet.In le u -> enumeration (u, v) -> enumeration (NES.add le u, v) + | enum_add_right le (u v : premises) : ~ LevelExprSet.In le v -> enumeration (u, v) -> enumeration (u, NES.add le v). + + Lemma acc_enum : forall r, enumeration r. + Proof. + intros [l r]. + move: l r. apply: NES.elim. + - intros le. + apply: NES.elim. + * intros le'. constructor. + * intros le' x. now constructor. + - intros le x ihr nin r. now constructor. + Qed. + End Enum. + Definition strict_subset (s s' : LevelExprSet.t) := + LevelExprSet.Subset s s' /\ ~ LevelExprSet.Equal s s'. + +(* Lemma strict_subset_incl (x y z : LevelSet.t) : LevelSet.Subset x y -> strict_subset y z -> strict_subset x z. +Proof. + intros hs []. split => //. lsets. + intros heq. apply H0. lsets. +Qed. *) + + Definition premises_strict_subset (x y : premises) := strict_subset x y. + + Definition ord := lexprod premises_strict_subset premises_strict_subset. + Derive Signature for lexprod. + + Lemma premises_incl_singleton (u : premises) le : + u ⊂_leset (singleton le) -> LevelExprSet.Equal u (singleton le). + Proof. + intros incl; split => //. + - apply incl. + - intros hin. eapply LevelExprSet.singleton_spec in hin. subst. + move: u incl. apply: NES.elim. + * intros le' hs. specialize (hs le'). forward hs. apply LevelExprSet.singleton_spec. lesets. + apply LevelExprSet.singleton_spec in hs. subst le'. + now apply LevelExprSet.singleton_spec. + * intros le' x ih hnin hadd. + rewrite LevelExprSet.add_spec. right; apply ih. + intros ? hin. apply hadd. now rewrite LevelExprSet.add_spec; right. + Qed. + + Lemma subset_add {a l x} : + ~ LevelExprSet.In l a -> a ⊂_leset NES.add l x -> a ⊂_leset x. + Proof. + intros hnin; rewrite -univ_union_add_singleton. + move=> hsub lk /[dup]/hsub. rewrite univ_union_spec. + intros [] => //. apply LevelExprSet.singleton_spec in H. subst. contradiction. + Qed. + + (* Lemma subset_add_2 {a l x} : + LevelExprSet.In l a -> a ⊂_leset NES.add l x -> a ⊂_leset x. + Proof. + intros hnin; rewrite -univ_union_add_singleton. + move=> hsub lk /[dup]/hsub. rewrite univ_union_spec. + intros [] => //. apply LevelExprSet.singleton_spec in H. subst. contradiction. + Qed. *) + + Section LevelExprSetCardinal. + + Import LevelExprSet. + Import LevelExprSetProp. + + Lemma cardinal_1_is_singleton a : cardinal a = 1 <-> exists x, Equal a (singleton x). + Proof. Admitted. + + Lemma premises_cardinal (p : premises) : cardinal p > 0. + Proof. Admitted. + + Lemma not_Equal_exists_diff (p p' : premises) : + p ⊂_leset p' -> ~ Equal p p' -> + exists le, (In le p' /\ ~ In le p). + Proof. + intros hsub neq. + pose c := choose (diff p' p). + case hc : c => [elt|]. move/choose_spec1: hc. + rewrite diff_spec => -[hin nin]. now exists elt. + move/choose_spec2: hc => hc. + have hsub' : p' ⊂_leset p. lesets. elim neq. + lesets. + Qed. + + Lemma premises_strict_subset_spec p p' : premises_strict_subset p p' <-> + p ⊂_leset p' /\ exists le, In le p' /\ ~ In le p. + Proof. + split. + - intros [hincl hneq]. split => //. + now apply not_Equal_exists_diff. + - intros [hincl [le [inp' ninp]]]. + split => // => he. rewrite -he in inp'. contradiction. + Qed. + + Lemma premises_strict_subset_cardinal (p p' : premises) : + premises_strict_subset p p' -> cardinal p < cardinal p'. + Proof. rewrite premises_strict_subset_spec => -[incl [le [inp' ninp]]]. + eapply subset_cardinal_lt; tea. + Qed. + + Lemma cardinal_add {le x} : ~ In le x -> cardinal (add le x) = 1 + cardinal x. + Proof. lesets. Qed. + + Lemma premises_eq_singleton {a : premises} {x} : a = singleton x :> LevelExprSet.t -> a = NES.singleton x. + Proof. + intros he. rewrite -equal_exprsets. cbn. now rewrite he. + Qed. + + Lemma premises_strict_subset_wf : well_founded premises_strict_subset. + Proof. + red. intros a. + have hr : LevelExprSet.cardinal a <= LevelExprSet.cardinal a by lesets. + revert hr. generalize a at 2 => a'. move: a' a. + apply: NES.elim. + - intros le a. rewrite NES.LevelExprSetProp.singleton_cardinal. + have carda := premises_cardinal a => cardle. + have : cardinal a = 1 by lia. + rewrite cardinal_1_is_singleton => -[x heq]. + move/eq_leibniz/premises_eq_singleton: heq. intros ->. + constructor. intros y hp. + destruct hp. eapply premises_incl_singleton in H. contradiction. + - intros le x accx hnin. + intros a asub. + constructor => y. + move/premises_strict_subset_cardinal => hc. + apply accx. rewrite cardinal_add // in asub. lia. + Qed. + End LevelExprSetCardinal. + + Lemma acc_ord r : Acc ord r. + Proof. + apply wf_lexprod; apply premises_strict_subset_wf. + Qed. + Instance ord_wf : WellFounded ord. + Proof. red. exact acc_ord. Qed. + + Definition clauses_of_relations (p : list (premises × premises)) := + List.fold_right (fun '(l, r) => Clauses.union (clauses_of_eq l r)) Clauses.empty p. + + Definition check_pres_clause p r := + LoopCheck.Impl.check_clauses (clauses_of_relations p) (clauses_of_eq r.1 r.2). + + Definition check_add p l r := + if check_pres_clause p (l, r) then (l, r) :: p + else p. + + Lemma premises_strict_subset_add {l} {u : premises} : + ~ LevelExprSet.In l u -> premises_strict_subset u (NES.add l u). + Proof. + intros hnin; rewrite premises_strict_subset_spec. + rewrite -univ_union_add_singleton. setoid_rewrite univ_union_spec. split. + - intros l'. rewrite univ_union_spec; lesets. + - exists l; split => //. right; now apply LevelExprSet.singleton_spec. + Qed. + + Parameter ϕ : nat -> rel. + Parameter ϕ_exists : forall r, exists n, ϕ n = r. + Parameter ϕ_inj : forall n n', ϕ n = ϕ n' -> n = n'. + + Inductive 𝒮 (r : rels) : rels -> nat -> Prop := + | S_0 Γ a : List.incl Γ r -> ~ consistent (a :: Γ) -> 𝒮 r (a :: Γ) 0 + | S_incl Γ n : 𝒮 r Γ n -> 𝒮 r Γ (S n) + | S_phi Γ n : 𝒮 r Γ n -> consistent (ϕ n :: Γ) -> 𝒮 r (ϕ n :: Γ) (S n). + + Definition 𝒮ω r rs := exists n Γ sn, 𝒮 rs sn n /\ sn ⊢ℒ r. + + + + Section S. + Context (p : rels). + + Fixpoint 𝖲 (n : nat) (a : rel) := + match n with + | 0 => List.In a p + | S n => 𝖲 n \/ ϕ n = a /\ (a :: 𝖲 n + + Equations? S (p : list (premises × premises)) (r : premises × premises) (e : enumeration r) : list (premises × premises) + by wf r ord := { + S p ?((singleton le, singleton le')) (enum_single le le') := + check_add p (NES.singleton le) (NES.singleton le') ; + S p _ (enum_add_left le u v nin e) := check_add (S p _ e) (NES.add le u) v; + S p _ (enum_add_right le u v nin e) := check_add (S p _ e) u (NES.add le v) }. + Proof. + - constructor; now apply premises_strict_subset_add. + - constructor; now apply premises_strict_subset_add. + Qed. + + Fixpoint S' (p : rels) n := + match n with + | 0 => p + | S n => S p rel (acc_enum rel) + end. + + Lemma extension p : consistent p -> exists p', maximally_consistent p'. + Proof. + intros con. + destruct p as [V C]. + exists {| V := V; C := (S' C) |}. + destruct C; cbn. + - red. split => //. + intros x y. left. intros hcon. red in hcon. admit. + - apply IHC. red in con. red. + intros [x hnc]. apply con. exists x. admit. + Admitted. + + + + *) +From Stdlib Require Import Logic.Classical. + Lemma contra_prop A B : (~ B -> ~ A) -> (A -> B). + Proof. intros he a. destruct (classic B). exact H. specialize (he H). contradiction. Qed. + + Lemma entails_L_completeness {p l r} : + (forall v, interp_cstrs v p.(C) -> interp_prems v l = interp_prems v r) -> + p ⊢ℒ l ≡ r. + Proof. + apply contra + intros hv. + + + + Lemma satisfies_entails_presentation {m c} : + check m c = false <-> exists v, interp_univ_cstrs v (constraints m) -> invalid_cstr v c. + Proof. + split; revgoals. + - intros [v hv]. + + have vm := LoopCheck.model_valuation (model m). + + intros he. eapply presentation_entails_valid in he. + red in he. intros v hv. apply (he v). cbn. + now rewrite -interp_univ_cstrs_relations. + - intros hv. + have hvm := (LoopCheck.model_valuation m.(model)). + red. + specialize (hv (LoopCheck.valuation m.(model))). + forward hv. apply interp_univ_cstrs_of_m. cbn in hv. + destruct c as [[l []] r]; cbn in *. + + eapply + + + + + + apply interp_univ_cstrs_of_m. + apply he. cbn. + apply interp_cstrs_of_m. + - move=> [v [ics ic]]. + + + Lemma satisfies_entails_presentation {m c} : + check m c <-> (forall v, interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + Proof. + destruct check eqn:hc. + - split => // _ v hu. + eapply check_valid_pres in hc. + destruct c as [[l []] r]; cbn in hc. + * have := presentation_entails_satisfies hc v => /fwd. + { admit. } + rewrite interp_prems_union. cbn. lia. + * have := presentation_entails_satisfies hc v => /fwd. + + + rewrite check_ + split. + - + intros hv. + have [v hc] : exists v, interp_cstrs v (C p). + admit. + specialize (hv _ hc). + + induction 1; cbn; move=> v hv. + 1:by red in hv; rewrite Forall_forall in hv; eapply hv in H. + all:try specialize (IHentails_L _ hv). + all:try specialize (IHentails_L1 _ hv). + all:try specialize (IHentails_L2 _ hv). + all:try lia; eauto. + all:rewrite ?interp_add_prems ?interp_prems_union ?interp_add_prems; try lia. + rewrite ?interp_add_prems in IHentails_L. lia. + Qed. + + End UnivLoopChecking. From 05121d6da31dada4fd15254015a7a45026d2f5b0 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 19 Sep 2025 15:49:30 +0200 Subject: [PATCH 058/164] WIP refactoring for generalization over semilattices --- .vscode/metarocq.code-workspace | 128 ++-- common/theories/LoopChecking/Common.v | 157 ++--- common/theories/LoopChecking/Deciders.v | 2 +- common/theories/LoopChecking/HornClauses.v | 181 ++---- common/theories/LoopChecking/Interfaces.v | 8 +- common/theories/LoopChecking/Model.v | 355 ++++++----- common/theories/Universes.v | 16 +- template-rocq/src/g_template_rocq.ml | 360 ----------- .../theories/LoopChecking/UnivLoopChecking.v | 595 +++++++++++++++--- template-rocq/theories/SemiLattice.v | 45 -- utils/_RocqProject | 2 + utils/theories/MRClasses.v | 13 + utils/theories/MRUtils.v | 1 + utils/theories/NonEmptyLevelExprSet.v | 92 ++- utils/theories/SemiLattice.v | 120 ++++ 15 files changed, 1153 insertions(+), 922 deletions(-) delete mode 100644 template-rocq/src/g_template_rocq.ml delete mode 100644 template-rocq/theories/SemiLattice.v create mode 100644 utils/theories/MRClasses.v create mode 100644 utils/theories/SemiLattice.v diff --git a/.vscode/metarocq.code-workspace b/.vscode/metarocq.code-workspace index 116df6b11..8efb022e3 100644 --- a/.vscode/metarocq.code-workspace +++ b/.vscode/metarocq.code-workspace @@ -10,88 +10,92 @@ "coqtop.args": [ // "-bt", // get backtraces from Rocq on errors - "-R", "utils/theories", "MetaRocq.Utils", - "-R", "common/theories", "MetaRocq.Common", - "-R", "template-rocq/theories", "MetaRocq.Template", + "-Q", "utils/theories", "MetaRocq.Utils", + "-Q", "common/theories", "MetaRocq.Common", + "-Q", "template-rocq/theories", "MetaRocq.Template", "-I", "template-rocq", "-I", "template-rocq/src", - "-R", "pcuic/theories", "MetaRocq.PCUIC", + "-Q", "pcuic/theories", "MetaRocq.PCUIC", "-I", "pcuic", "-I", "pcuic/src", - "-R", "template-pcuic/theories", "MetaRocq.TemplatePCUIC", - "-R", "safechecker/theories", "MetaRocq.SafeChecker", - "-R", "safechecker-plugin/theories", "MetaRocq.SafeCheckerPlugin", + "-Q", "template-pcuic/theories", "MetaRocq.TemplatePCUIC", + "-Q", "safechecker/theories", "MetaRocq.SafeChecker", + "-Q", "safechecker-plugin/theories", "MetaRocq.SafeCheckerPlugin", "-I", "safechecker-plugin", "-I", "safechecker-plugin/src", - "-R", "erasure/theories", "MetaRocq.Erasure", - "-R", "erasure-plugin/theories", "MetaRocq.ErasurePlugin", + "-Q", "erasure/theories", "MetaRocq.Erasure", + "-Q", "erasure-plugin/theories", "MetaRocq.ErasurePlugin", "-I", "erasure-plugin", "-I", "erasure-plugin/src", - "-R", "translations", "MetaRocq.Translations", - "-R", "quotation/theories", "MetaRocq.Quotation", - "-R", "test-suite", "MetaRocq.TestSuite", - "-R", "test-suite/plugin-demo/theories", "MetaRocq.ExtractedPluginDemo", + "-Q", "translations", "MetaRocq.Translations", + "-Q", "quotation/theories", "MetaRocq.Quotation", + "-Q", "test-suite", "MetaRocq.TestSuite", + "-Q", "test-suite/plugin-demo/theories", "MetaRocq.ExtractedPluginDemo", "-I", "test-suite/plugin-demo", "-I", "test-suite/plugin-demo/src", - "-R", "test-suite/loop-checking/theories", "MetaRocq.LoopChecking", + "-Q", "test-suite/loop-checking/theories", "MetaRocq.LoopChecking", "-I", "test-suite/loop-checking/src", - "-R", "examples", "MetaRocq.Examples", + "-Q", "examples", "MetaRocq.Examples", ], "vscoq.args": [ // "-bt", // get backtraces from Rocq on errors - "-R", "utils/theories", "MetaRocq.Utils", - "-R", "common/theories", "MetaRocq.Common", - "-R", "template-rocq/theories", "MetaRocq.Template", + "-Q", "utils/theories", "MetaRocq.Utils", + "-Q", "common/theories", "MetaRocq.Common", + "-Q", "template-rocq/theories", "MetaRocq.Template", "-I", "template-rocq", "-I", "template-rocq/src", - "-R", "pcuic/theories", "MetaRocq.PCUIC", + "-Q", "pcuic/theories", "MetaRocq.PCUIC", "-I", "pcuic", "-I", "pcuic/src", - "-R", "template-pcuic/theories", "MetaRocq.TemplatePCUIC", - "-R", "safechecker/theories", "MetaRocq.SafeChecker", - "-R", "safechecker-plugin/theories", "MetaRocq.SafeCheckerPlugin", + "-Q", "template-pcuic/theories", "MetaRocq.TemplatePCUIC", + "-Q", "safechecker/theories", "MetaRocq.SafeChecker", + "-Q", "safechecker-plugin/theories", "MetaRocq.SafeCheckerPlugin", "-I", "safechecker-plugin", "-I", "safechecker-plugin/src", - "-R", "erasure/theories", "MetaRocq.Erasure", - "-R", "erasure-plugin/theories", "MetaRocq.ErasurePlugin", + "-Q", "erasure/theories", "MetaRocq.Erasure", + "-Q", "erasure-plugin/theories", "MetaRocq.ErasurePlugin", "-I", "erasure-plugin", "-I", "erasure-plugin/src", - "-R", "translations", "MetaRocq.Translations", - "-R", "quotation/theories", "MetaRocq.Quotation", - "-R", "test-suite", "MetaRocq.TestSuite", - "-R", "test-suite/plugin-demo/theories", "MetaRocq.ExtractedPluginDemo", + "-Q", "translations", "MetaRocq.Translations", + "-Q", "quotation/theories", "MetaRocq.Quotation", + "-Q", "test-suite", "MetaRocq.TestSuite", + "-Q", "test-suite/plugin-demo/theories", "MetaRocq.ExtractedPluginDemo", "-I", "test-suite/plugin-demo", "-I", "test-suite/plugin-demo/src", - "-R", "examples", "MetaRocq.Examples", + "-Q", "examples", "MetaRocq.Examples", ], "coq-lsp.args": [ - // "-bt", // get backtraces from Rocq on errors - "-R", "utils/theories,MetaRocq.Utils", - "-R", "common/theories,MetaRocq.Common", - "-R", "template-rocq/theories,MetaRocq.Template", - "-I", "template-rocq", - "-I", "template-rocq/src", - "-R", "pcuic/theories,MetaRocq.PCUIC", - "-I", "pcuic", - "-I", "pcuic/src", - "-R", "template-pcuic/theories,MetaRocq.TemplatePCUIC", - "-R", "safechecker/theories,MetaRocq.SafeChecker", - "-R", "safechecker-plugin/theories,MetaRocq.SafeCheckerPlugin", - "-I", "safechecker-plugin", - "-I", "safechecker-plugin/src", - "-R", "erasure/theories,MetaRocq.Erasure", - "-R", "erasure-plugin/theories,MetaRocq.ErasurePlugin", - "-I", "erasure-plugin", - "-I", "erasure-plugin/src", - "-R", "translations,MetaRocq.Translations", - "-R", "quotation/theories,MetaRocq.Quotation", - "-R", "test-suite,MetaRocq.TestSuite", - "-R", "test-suite/plugin-demo/theories,MetaRocq.ExtractedPluginDemo", - "-I", "test-suite/plugin-demo", - "-I", "test-suite/plugin-demo/src", - "-R", "examples,MetaRocq.Examples", - ], + "-Q", + "utils/theories,MetaRocq.Utils", + "-Q", + "common/theories,MetaRocq.Common", + "-Q", + "template-rocq/theories,MetaRocq.Template", + "-Q", + "pcuic/theories,MetaRocq.PCUIC", + "-Q", + "template-pcuic/theories,MetaRocq.TemplatePCUIC", + "-Q", + "safechecker/theories,MetaRocq.SafeChecker", + "-Q", + "safechecker-plugin/theories,MetaRocq.SafeCheckerPlugin", + "-Q", + "erasure/theories,MetaRocq.Erasure", + "-Q", + "erasure-plugin/theories,MetaRocq.ErasurePlugin", + "-Q", + "translations,MetaRocq.Translations", + "-Q", + "quotation/theories,MetaRocq.Quotation", + "-Q", + "test-suite,MetaRocq.TestSuite", + "-Q", + "test-suite/plugin-demo/theories,MetaRocq.ExtractedPluginDemo", + "-Q", + "examples,MetaRocq.Examples", + "--ocamlpath=template-rocq,template-rocq/src,pcuic/src,safechecker-plugin/src,erasure-plugin/src,test-suite/plugin-demo/src" + ], // When enabled, will trim trailing whitespace when saving a file. "files.trimTrailingWhitespace": true, "vscoq.path": "_opam/bin/vscoqtop", @@ -105,16 +109,24 @@ "**/.git": true, "**/.svn": true, "**/.hg": true, - "**/CVS": true, "**/.DS_Store": true, - "**/Thumbs.db": true + "**/Thumbs.db": true, + "**/CVS": true }, - "coq-lsp.check_only_on_request": true, + "coq-lsp.check_only_on_request": false, "coqtop.binPath": "_opam/bin", "coqtop.coqtopExe": "coqtop", "coqtop.coqidetopExe": "coqidetop", "cSpell.enabledFileTypes": { "coq": false }, + "coq-lsp.show_universes_on_hover": false, + "coq-lsp.pp_type": 1, + "coq-lsp.heatmap.enabled": true, + "coq-lsp.goal_after_tactic": true, + "coq-lsp.messages_follow_goal": false, + "coq-lsp.send_perf_data": false, + "coq-lsp.admit_on_bad_qed": false, + "coq-lsp.max_errors": 1, } } diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v index 66dd24d9a..e5e86d80a 100644 --- a/common/theories/LoopChecking/Common.v +++ b/common/theories/LoopChecking/Common.v @@ -2,7 +2,7 @@ From Stdlib Require Import ssreflect ssrfun ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils. +From MetaRocq.Utils Require Import utils SemiLattice. From MetaRocq.Common Require Universes. From Equations Require Import Equations. @@ -59,8 +59,6 @@ Proof. now transitivity y. Qed. - -Class Commutative {A} (f : A -> A -> A) := comm : forall x y, f x y = f y x. Instance option_map_2_comm {A} f : @Commutative A f -> @Commutative (option A) (option_map2 f). Proof. intros com [x|] [y|] => //=. now rewrite comm. @@ -72,7 +70,6 @@ Instance Zmax_comm : Commutative Z.max := Z.max_comm. Instance nat_min_comm : Commutative Nat.min := Nat.min_comm. Instance nat_max_comm : Commutative Nat.max := Nat.max_comm. -Class Associative {A} (f : A -> A -> A) := assoc : forall x y z, f x (f y z) = f (f x y) z. Instance option_map_2_assoc {A} f : @Associative A f -> @Associative (option A) (option_map2 f). Proof. intros assoc [x|] [y|] [z|]; cbn => //. now rewrite assoc. @@ -237,78 +234,86 @@ Proof. now rewrite (assoc (f := option_map2 Z.max)) (comm (f := option_map2 Z.max) x y) -assoc. Qed. -Local Open Scope Z_scope. -Lemma fold_right_max_in {a l} n : In a l -> a <= fold_right Z.max n l. -Proof. - induction l. - - now cbn. - - intros [eq|inl]. subst a0. cbn. lia. - cbn. specialize (IHl inl). lia. -Qed. - -Lemma fold_right_max_acc {n l} : n <= fold_right Z.max n l. -Proof. - induction l. - - now cbn. - - cbn. lia. -Qed. - -Lemma fold_right_impl n l l' : - (forall x, In x l -> In x l') -> fold_right Z.max n l <= fold_right Z.max n l'. -Proof. - induction l in l' |- *. - - cbn. destruct l'; cbn. lia. - intros. have := @fold_right_max_acc n l'. lia. - - cbn; intros h. - have inal' := (h a (or_introl eq_refl)). - have := fold_right_max_in n inal'. - specialize (IHl l'). - forward IHl. - intros. apply h. now right. - lia. -Qed. - -Lemma fold_right_max_spec n l : - let fn := fold_right Z.max in - (forall x, In x (n :: l) -> x <= fn n l) /\ - (exists x, In x (n :: l) /\ fn n l = x). -Proof. - induction l; cbn. - - split. intros x [] => //. now subst. - exists n. firstorder. - - cbn in IHl. destruct IHl as [h h']. - split. - intros x [|[]]; subst. - * specialize (h x). forward h by auto. lia. - * lia. - * specialize (h x). forward h by auto. lia. - * destruct h' as [x []]. exists (Z.max a x). rewrite -{4}H0. split => //. - destruct H; subst. - destruct (Z.max_spec a x) as [[]|[]]; firstorder; subst. - destruct (Z.max_spec a (fold_right Z.max n l)) as [[]|[]]; firstorder; subst. rewrite H1. - auto. -Qed. - -Lemma fold_right_equivlist_all n n' l l' : - equivlistA eq (n :: l) (n' :: l') -> fold_right Z.max n l = fold_right Z.max n' l'. -Proof. - intros eq. - have [hla [maxl [inmaxl eqmaxl]]] := fold_right_max_spec n l. - have [hra [maxr [inmaxr eqmaxr]]] := fold_right_max_spec n' l'. - rewrite eqmaxl eqmaxr. - red in eq; setoid_rewrite InA_In_eq in eq. - apply (eq _) in inmaxl. apply hra in inmaxl. - apply eq in inmaxr. apply hla in inmaxr. lia. -Qed. - -Lemma fold_right_comm acc l : l <> [] -> fold_right Z.max acc l = Z.max acc (fold_right Z.max (List.hd acc l) (List.tl l)). -Proof. - induction l in acc |- *. - - intros; congruence. - - intros _. cbn. destruct l; cbn. lia. - cbn in IHl. rewrite (IHl acc). congruence. - rewrite (IHl a). congruence. lia. -Qed. +Section ForSemilattice. + Import Semilattice. + Context {A : Type} {SL : Semilattice A}. + Open Scope sl_scope. + + Lemma fold_right_max_in {a : A} {l : list A} n : In a l -> a ≤ (fold_right join n l). + Proof. + induction l. + - now cbn. + - intros [eq|inl]. subst a0. cbn. apply join_le_left. + cbn. specialize (IHl inl). etransitivity; tea. apply join_le_right. + Qed. + + Lemma fold_right_max_acc {n l} : n ≤ fold_right join n l. + Proof. + induction l. + - now cbn. + - cbn. etransitivity; tea. eapply join_le_right. + Qed. + + Lemma fold_right_impl n l l' : + (forall x, In x l -> In x l') -> fold_right join n l ≤ fold_right join n l'. + Proof. + induction l in l' |- *. + - cbn. destruct l'; cbn. reflexivity. + intros. have := @fold_right_max_acc n l'. + etransitivity; tea; eapply join_le_right. + - cbn; intros h. + have inal' := (h a (or_introl eq_refl)). + have := fold_right_max_in n inal'. + specialize (IHl l'). + forward IHl. + intros. apply h. now right. + lia. + Qed. + + Lemma fold_right_max_spec n l : + let fn := fold_right Z.max in + (forall x, In x (n :: l) -> x <= fn n l) /\ + (exists x, In x (n :: l) /\ fn n l = x). + Proof. + induction l; cbn. + - split. intros x [] => //. now subst. + exists n. firstorder. + - cbn in IHl. destruct IHl as [h h']. + split. + intros x [|[]]; subst. + * specialize (h x). forward h by auto. lia. + * lia. + * specialize (h x). forward h by auto. lia. + * destruct h' as [x []]. exists (Z.max a x). rewrite -{4}H0. split => //. + destruct H; subst. + destruct (Z.max_spec a x) as [[]|[]]; firstorder; subst. + destruct (Z.max_spec a (fold_right Z.max n l)) as [[]|[]]; firstorder; subst. rewrite H1. + auto. + Qed. + + Lemma fold_right_equivlist_all max n n' l l' : + equivlistA eq (n :: l) (n' :: l') -> fold_right Z.max n l = fold_right Z.max n' l'. + Proof. + intros eq. + have [hla [maxl [inmaxl eqmaxl]]] := fold_right_max_spec n l. + have [hra [maxr [inmaxr eqmaxr]]] := fold_right_max_spec n' l'. + rewrite eqmaxl eqmaxr. + red in eq; setoid_rewrite InA_In_eq in eq. + apply (eq _) in inmaxl. apply hra in inmaxl. + apply eq in inmaxr. apply hla in inmaxr. lia. + Qed. + + Lemma fold_right_comm acc l : l <> [] -> fold_right Z.max acc l = Z.max acc (fold_right Z.max (List.hd acc l) (List.tl l)). + Proof. + induction l in acc |- *. + - intros; congruence. + - intros _. cbn. destruct l; cbn. lia. + cbn in IHl. rewrite (IHl acc). congruence. + rewrite (IHl a). congruence. lia. + Qed. + + +End ForSemilattice. Lemma fold_left_map {A B C} (f : B -> A -> A) (g : C -> B) l acc : fold_left (fun acc l => f (g l) acc) l acc = diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index e3515e895..060d448ad 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -824,7 +824,7 @@ Module LoopChecking (LS : LevelSets). that make the enforced clauses valid. *) Definition valuation m := Model.valuation_of_model m.(Impl.Abstract.model).(Impl.CorrectModel.model_valid).(model_model). - Definition model_valuation m : clauses_sem (valuation m) (clauses m). + Definition model_valuation m : clauses_sem (to_val (valuation m)) (clauses m). Proof. destruct m as [levels clauses []]; cbn. apply valid_clauses_model; tea; cbn. diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 3659712e5..830a94e21 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -91,7 +91,11 @@ Ltac rw_in l H := rewrite_strat (topdown l) in H. Module Clauses (LS : LevelSets). Module Export FLS := FromLevelSets LS. + Import (notations) NES. Import NES (t_set, t_ne, level, levels, singleton, add, add_spec, + add_expr, add_prems, add_prems_0, add_prems_add_prems, add_prems_add, add_prems_inj, + inj_add_prems_sub, + add_expr_add_expr, add_expr_inj, In_add_prems, add_expr_0, map, map_spec, add_list, add_list_spec, equal_exprsets). Coercion t_set : NES.t >-> LevelExprSet.t. @@ -807,95 +811,17 @@ Module Clauses (LS : LevelSets). Local Open Scope Z_scope. - Definition add_expr n '((l, k) : LevelExpr.t) := (l, k + n). - - Lemma add_expr_add_expr n n' lk : add_expr n (add_expr n' lk) = add_expr (n + n') lk. - Proof. destruct lk; unfold add_expr. f_equal; lia. Qed. - Definition add_prems n s := NES.map (add_expr n) s. - - Lemma In_add_prems k (prems : premises): - forall le, LevelExprSet.In le (add_prems k prems) <-> - exists le', LevelExprSet.In le' prems /\ le = add_expr k le'. - Proof. - intros [l k']. - now rewrite /add_prems map_spec. - Qed. - - Lemma add_expr_inj {n e e'} : add_expr n e = add_expr n e' -> e = e'. - Proof. - destruct e, e'; cbn; intros [=]. - have eq: z = z0 by lia. - now subst z0. - Qed. - - Lemma add_prems_inj n prems prems' : add_prems n prems = add_prems n prems' -> prems = prems'. - Proof. - rewrite /add_prems => /NES.equal_exprsets hm. - apply NES.equal_exprsets. - intros [l k]. specialize (hm (l, k + n)). - rewrite !map_spec in hm. destruct hm as [hl hr]. - split; intros hin. - - forward hl. exists (l, k); split => //. - destruct hl as [[] [hin' eq]]. - apply (@add_expr_inj n (l, k)) in eq. now noconf eq. - - forward hr. exists (l, k); split => //. - destruct hr as [[] [hin' eq]]. - apply (@add_expr_inj n (l, k)) in eq. now noconf eq. - Qed. - - Lemma inj_add_prems_sub {n u u'} : add_prems n u ⊂_leset add_prems n u' -> u ⊂_leset u'. - Proof. - rewrite /add_prems. - intros hm [l k]. specialize (hm (l, k + n)). - rewrite !map_spec in hm. - intros hin. - forward hm. exists (l, k); split => //. - destruct hm as [[] [hin' eq]]. - apply (@add_expr_inj n (l, k)) in eq. now noconf eq. - Qed. - - Lemma add_prems_add_prems n n' lk : add_prems n (add_prems n' lk) = add_prems (n + n') lk. - Proof. destruct lk; unfold add_prems. - rewrite NES.map_map. apply NES.equal_exprsets. - intros x. rewrite !map_spec. cbn in *. - firstorder eauto. subst. exists x0. - firstorder eauto. now rewrite add_expr_add_expr. - subst. exists x0. - firstorder eauto. now rewrite add_expr_add_expr. - Qed. - - Lemma add_prems_add {n lk prems} : add_prems n (add lk prems) = add (add_expr n lk) (add_prems n prems). - Proof. - apply NES.equal_exprsets. intros x. - rewrite In_add_prems LevelExprSet.add_spec In_add_prems /LevelExprSet.E.eq; rw LevelExprSet.add_spec. - firstorder. subst. red in H; subst x0. now left. - Qed. - - Lemma add_expr_0 e : add_expr 0 e = e. - Proof. - destruct e => //=. lia_f_equal. - Qed. - - Lemma add_prems_0 u : add_prems 0 u = u. - Proof. - rewrite /add_prems. - apply NES.equal_exprsets. - intros x. rewrite map_spec. - split. - - intros[e [hin ->]]. now rewrite add_expr_0. - - intros inu; exists x. split => //. now rewrite add_expr_0. - Qed. Lemma add_prems_of_level_set k W k' prf : add_prems k (of_level_set W k' prf) = of_level_set W (k + k') prf. Proof. apply NES.equal_exprsets => [] [l n]. - rewrite In_add_prems /of_level_set //= levelexprset_of_levels_spec. + rewrite NES.In_add_prems /of_level_set //= levelexprset_of_levels_spec. split. - move=> [] [l' n']. rewrite levelexprset_of_levels_spec => [] [[inw eq] eq']. - subst n'. noconf eq'. split => //. lia. + subst n'. noconf eq'. split => //. - move=> [inW ->]. exists (l, k'). rewrite levelexprset_of_levels_spec. - split => //. cbn. f_equal; lia. + split => //. Qed. Definition add_clause n '((prems, concl) : clause) := (add_prems n prems, add_expr n concl). @@ -959,7 +885,7 @@ Module Clauses (LS : LevelSets). apply clause_levels_spec. left. apply NES.levels_spec. exists (k + n). destruct cl; cbn. apply In_add_prems. exists (l, k). - split => //. + split => //. rewrite /add_expr. lia_f_equal. * intros ->. exists (add_clause n cl); split => //. now apply add_clauses_spec. apply clause_levels_spec. right. destruct cl; cbn. destruct t0 => //. @@ -968,13 +894,7 @@ Module Clauses (LS : LevelSets). Lemma add_clause_0 cl : add_clause 0 cl = cl. Proof. destruct cl as [prems [concl k]]; cbn. - f_equal. 2:now rewrite Z.add_0_r. - unfold add_prems. - eapply NES.equal_exprsets. intros [l k']. - rewrite NES.map_spec. - unfold add_expr. split. - - intros [[] [hin heq]]. noconf heq. now rewrite Z.add_0_r. - - exists (l, k'); split => //. now rewrite Z.add_0_r. + now rewrite add_prems_0. Qed. Lemma add_clause_singleton n le concl k : add_clause n (singleton le, (concl, k)) = (singleton (add_expr n le), (concl, k + n)). @@ -982,7 +902,8 @@ Module Clauses (LS : LevelSets). rewrite /add_clause //=. f_equal. apply NES.equal_exprsets. intros le'. rewrite In_add_prems. rewrite_strat (topdown LevelExprSet.singleton_spec). - unfold LevelExprSet.E.eq. firstorder. subst. reflexivity. + unfold LevelExprSet.E.eq. firstorder; subst; try lia_f_equal. + f_equal. lia. Qed. Lemma add_prems_singleton n cl : add_prems n (singleton cl) = singleton (add_expr n cl). @@ -1078,6 +999,7 @@ Module Clauses (LS : LevelSets). Inductive entails (cls : clauses) : clause -> Prop := | clause_in (prems : premises) (concl : LevelExpr.t) : LevelExprSet.In concl prems -> entails cls (prems, concl) + | clause_cut prems' concl' prems concl : in_pred_closure cls (prems', concl') -> entails cls (add concl' prems, concl) -> @@ -1131,11 +1053,11 @@ Module Clauses (LS : LevelSets). split. { intros [? [hin ->]]. rewrite LevelExprSet.singleton_spec in hin. red in hin; subst x0. - reflexivity. } + red. rewrite /succ_expr. lia_f_equal. } { unfold LevelExprSet.E.eq. intros ->. exists (x, k + 1). split. - now rewrite LevelExprSet.singleton_spec. reflexivity. } } - rewrite eq. constructor 2. + now rewrite LevelExprSet.singleton_spec. rewrite /succ_expr. lia_f_equal. } } + rewrite eq /succ_expr. rewrite Z.add_comm !(Z.add_comm 1 k) (Z.add_comm 1). constructor. + unfold succ_clause in IHentails. eapply entails_equal; tea. intros x. rewrite /succ_prems. rewrite NES.map_spec NES.add_spec. @@ -1145,7 +1067,6 @@ Module Clauses (LS : LevelSets). intros [e [hin ->]]. exists e. firstorder. Qed. - Derive Signature for entails. Lemma entails_pred_closure {cls prems concl k} : @@ -1196,11 +1117,11 @@ Module Clauses (LS : LevelSets). Proof. destruct 1. - rewrite add_clause_add_clause. now constructor. - - cbn. eapply in_pred_closure_equal with (singleton (x, k + 1 + n)). + - cbn. eapply in_pred_closure_equal with (singleton (x, n + (k + 1))). { intros le. rewrite In_add_prems; rewrite_strat (topdown LevelExprSet.singleton_spec). intuition auto. exists (x, k + 1). split => //. now destruct H as [le' [-> ->]]. } - have -> : k + 1 + n = (k + n) + 1 by lia. + have -> : n + (k + 1) = (n + k) + 1 by lia. constructor. Qed. @@ -1446,6 +1367,7 @@ Module Clauses (LS : LevelSets). - now rewrite Z.add_0_r. - intros en. have hs := entails_shift 1 en. rewrite add_clause_singleton /= in hs. + rewrite Z.add_comm in hs. apply IHn in hs. eapply entails_trans; tea. now have -> : k + 1 + Z.of_nat (S n) = k + 1 + 1 + Z.of_nat n by lia. @@ -1592,6 +1514,7 @@ Module Clauses (LS : LevelSets). apply loop_any_successor. - intros _ [l k]. rewrite In_add_prems. intros [[] [hin heq]]. rewrite /add_expr in heq. noconf heq. + rewrite Z.add_comm. apply entails_pred_closure_neg. now constructor. Qed. @@ -1657,7 +1580,7 @@ Module Clauses (LS : LevelSets). Proof. intros cl hin. eapply Clauses.entails_succ; tea. - intros l k hin'. exists (k + 1). split => //; try lia. + intros l k hin'. exists (1 + k). split => //; try lia. eapply In_add_prems. exists (l, k); split => //. Qed. @@ -1691,7 +1614,7 @@ Module Clauses (LS : LevelSets). rewrite ih. right; firstorder. Qed. - Infix "∨" := univ_union (at level 10). + Infix "∨" := univ_union (at level 30). Notation succ x := (add_prems 1%Z x). Definition clauses_of_eq (u v : NES.t) := @@ -1873,8 +1796,8 @@ Module Clauses (LS : LevelSets). - apply join_right. Qed. - Lemma succ_join {cls s t} : - cls ⊢ℋ succ (s ∨ t) ≡ succ s ∨ succ t. + Lemma succ_join {cls n s t} : + cls ⊢ℋ add_prems n (s ∨ t) ≡ add_prems n s ∨ add_prems n t. Proof. rewrite add_prems_univ_union; auto with entails. Qed. @@ -1902,49 +1825,27 @@ Module Clauses (LS : LevelSets). End Theory. - Module Semilattice. - Reserved Notation "x ≌ y" (at level 90). - Record semilattice := - { carrier :> Type; - eq : carrier -> carrier -> Prop where "x ≌ y" := (eq x y); - succ : carrier -> carrier; - join : carrier -> carrier -> carrier; - join_assoc x y z : join (join x y) z ≌ join x (join y z); - join_comm x y : join x y ≌ join y x; - join_idem x : join x x ≌ x; - join_sub x : join x (succ x) ≌ succ x; - succ_inj : forall x y, succ x ≌ succ y -> x ≌ y; - succ_join : forall x y, succ (join x y) ≌ join (succ x) (succ y); - }. - - Notation "x ≌ y" := (eq _ x y). - Local Open Scope nat_scope. - Section Derived. - Context (s : semilattice). - Definition le (x y : s) := join s x y ≌ y. - - Fixpoint add (x : s) n : s := - match n with - | 0 => x - | S n => succ _ (add x n) - end. - End Derived. - End Semilattice. - Section prems_semi. Obligation Tactic := idtac. - Import Semilattice (semilattice, carrier, eq, succ, join). + Import Semilattice (Semilattice, eq, add, join). Context (cls : Clauses.t). - Equations? leset_sl : semilattice := - leset_sl := {| carrier := NES.t; + Equations? horn_semi : Semilattice NES.t := + horn_semi := {| eq x y := cls ⊢ℋ x ≡ y; - succ := add_prems 1; + add := add_prems; join := univ_union |}. Proof. all: intros. + - split; red. + * intros x. apply Theory.eq_refl. + * intros x y. apply Theory.eq_sym. + * intros x y z. apply Theory.eq_trans. + - rewrite add_prems_add_prems. apply Theory.eq_refl. + - now rewrite add_prems_0; apply Theory.eq_refl. - cbn. apply Theory.join_assoc. - apply Theory.join_comm. + - now apply Theory.join_congr_left. - apply Theory.join_idem. - apply Theory.join_succ. - now eapply Theory.succ_inj. @@ -1954,18 +1855,20 @@ Module Clauses (LS : LevelSets). Import Semilattice. Section Morphism. - Context (s s' : semilattice). - Context (f : s -> s'). + Context (A B : Type). + Context (s : Semilattice A). + Context (s' : Semilattice B). + Context (f : A -> B). Class respects := - { of_succ x : f (succ s x) = succ s' (f x); - of_join x y : f (join _ x y) = join _ (f x) (f y) }. + { of_succ n (x : A) : f (add n x) = add n (f x); + of_join (x : A) (y : A) : f (join x y) = join (f x) (f y) }. - Lemma respects_assoc {r : respects} x y z : f (join s (join s x y) z) ≌ join s' (f x) (join s' (f y) (f z)). + Lemma respects_assoc {r : respects} x y z : f (join (join x y) z) ≡ join (f x) (join (f y) (f z)). Proof. rewrite !of_join. apply join_assoc. Qed. - Lemma respects_comm {r : respects} x y : f (join s x y) ≌ join s' (f y) (f x). + Lemma respects_comm {r : respects} x y : f (join x y) ≡ join (f y) (f x). Proof. rewrite !of_join. apply join_comm. Qed. End Morphism. diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 90b0a4397..2f0ad9536 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -46,6 +46,13 @@ End FMapOTInterface. Module Q <: Quantity. Include OrdersEx.Z_as_OT. + + Program Instance comm_monoid : CommutativeMonoid Z.zero Z.add. + Solve Obligations with red; tc; program_simpl; lia. + + Program Instance add_inj z : Injective (Z.add z). + Next Obligation. lia. Qed. + Definition reflect_eq : ReflectEq t := _. Definition eq_leibniz x y : eq x y -> x = y := fun e => e. End Q. @@ -79,7 +86,6 @@ Ltac lsets := LevelSetDecide.fsetdec. Notation "(=_lset)" := LevelSet.Equal (at level 0) : levels_scope. Infix "=_lset" := LevelSet.Equal (at level 30) : levels_scope. Infix "⊂_lset" := LevelSet.Subset (at level 70) : levels_scope. -Infix "⊂_leset" := LevelExprSet.Subset (at level 70) : levels_scope. Infix "∪" := LevelSet.union (at level 70) : levels_scope. Infix "=m" := LevelMap.Equal (at level 50) : levels_scope. Notation "#| V |" := (LevelSet.cardinal V) : levels_scope. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 9a59774e6..81cd30686 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -242,6 +242,8 @@ Module Model (LS : LevelSets). | update_one m cl m' : Clauses.In cl cls -> s =_lset (LevelSet.singleton (clause_conclusion cl)) -> strict_update m cl m' -> strictly_updates cls s m m' + + | update_trans {ls ls' m m' m''} : strictly_updates cls ls m m' -> strictly_updates cls ls' m' m'' -> @@ -1235,7 +1237,7 @@ Module Model (LS : LevelSets). Proof. intros l k; rewrite /to_positive. rewrite In_add_prems. split. - - move=> hin; exists (l, k). split => //. + - move=> hin; exists (l, k). split => //. rewrite /add_expr; lia_f_equal. - move=> [] [l' k'] [] hin heq. noconf heq. now have -> : k = k' by lia. Qed. @@ -1245,7 +1247,7 @@ Module Model (LS : LevelSets). intros l k; rewrite /to_positive. rewrite In_add_prems. split. - move=> [] [l' k'] [] hin heq. noconf heq. - now have <- : k' = k' + - premise_min s + premise_min s by lia. + now have <- : k' = - premise_min s + k' + premise_min s by lia. - move=> hin; exists (l, k + premise_min s). split => //. cbn. lia_f_equal. Qed. @@ -2838,7 +2840,9 @@ Lemma is_update_of_empty cls m : eapply (entails_all_one (concl := add_prems (z - mink) prems)) => //. eapply level_value_MapsTo' in hminprem. rewrite -hypss in hminprem. - eapply hyps_entails; tea. red in eq; subst. exact entailscl. + eapply hyps_entails; tea. red in eq; subst. + have -> : (k + (z - mink) = z - mink + k)%Z by lia. + exact entailscl. constructor. now rewrite of_level_map_spec. - have hnemid : defined_map m'. by exact: strictly_updates_defined_map su. specialize (ihsu hne hnemid). @@ -2901,7 +2905,8 @@ Lemma is_update_of_empty cls m : cls ⊢a of_level_map m nem → succ_prems (of_level_map m nem). Proof. intros tot cla mp [l k]. - rewrite In_add_prems => [] [[l' k']] [] /of_level_map_spec hm [=] -> ->. + rewrite In_add_prems => [] [[l' k']] [] /of_level_map_spec hm. + rewrite /succ_expr => he. noconf he. rewrite Z.add_comm. eapply entails_any_one; tea. exact tot. apply tot. now exists (Some k'). Qed. @@ -2939,59 +2944,199 @@ Lemma is_update_of_empty cls m : Qed. Section Semantics. - + Import Semilattice. Section Interpretation. - Context (V : LevelMap.t nat). + Context {A : Type} {s : Semilattice A}. + Context (V : Level.t -> A). - Definition interp_level l := - match LevelMap.find l V with - | Some x => x - | None => 0%nat - end. - - Definition interp_expr '(l, k) := (Z.of_nat (interp_level l) + k)%Z. + Definition interp_expr '(l, k) := (add k (V l))%Z. Definition interp_prems prems := let '(hd, tl) := to_nonempty_list prems in - fold_right (fun lk acc => Z.max (interp_expr lk) acc) (interp_expr hd) tl. + fold_right (fun lk acc => join (interp_expr lk) acc) (interp_expr hd) tl. Definition clause_sem (cl : clause) : Prop := let '(prems, concl) := cl in - (interp_prems prems >= interp_expr concl)%Z. + le (interp_prems prems) (interp_expr concl). Definition clauses_sem (cls : clauses) : Prop := Clauses.For_all clause_sem cls. End Interpretation. - (* There exists a valuation making all clauses true in the natural numbers *) - Definition satisfiable (cls : clauses) := - exists V, clauses_sem V cls. - - (* Any valuation making all clauses valid in the natural numbers also satisfies the clause cl *) - Definition entails_sem (cls : clauses) (cl : clause) := - forall V, clauses_sem V cls -> clause_sem V cl. - - Lemma interp_add_expr V n e : interp_expr V (add_expr n e) = n + interp_expr V e. - Proof. - destruct e as [l k]; cbn. lia. - Qed. - - Lemma interp_prems_singleton V e : - interp_prems V (NES.singleton e) = interp_expr V e. - Proof. - rewrite /interp_prems. - now rewrite singleton_to_nonempty_list /=. - Qed. - + Section OfSL. + Context {A} {SL : Semilattice A}. + Declare Scope sl_scope. + Infix "≤" := le : sl_scope. + Infix "≡" := eq : sl_scope. + Local Open Scope sl_scope. + + (* There exists a valuation making all clauses true in the natural numbers *) + Definition satisfiable (cls : clauses) := + exists V, clauses_sem V cls. + + (* Any valuation making all clauses valid in the given semilattice also satisfies the clause cl *) + Definition entails_sem (cls : clauses) (cl : clause) := + forall V, clauses_sem V cls -> clause_sem V cl. + + Lemma interp_add_expr V n e : + interp_expr V (add_expr n e) ≡ add n (interp_expr V e). + Proof. + destruct e as [l k]; cbn. now rewrite add_distr. + Qed. + + Lemma interp_prems_singleton V e : + interp_prems V (NES.singleton e) = interp_expr V e. + Proof. + rewrite /interp_prems. + now rewrite singleton_to_nonempty_list /=. + Qed. + + Lemma interp_prems_ge v (prems : premises) : + forall prem, LevelExprSet.In prem prems -> + interp_expr v prem ≤ interp_prems v prems. + Proof. + intros. + unfold interp_prems. + have he := to_nonempty_list_spec prems. + destruct to_nonempty_list. + pose proof to_nonempty_list_spec'. + rewrite In_elements in H. rewrite -he in H. clear H0 he. clear -H. + destruct H. subst p. + - induction l. cbn. auto. + cbn. red. eapply join_idem. cbn. + etransitivity; tea. + apply join_le_right. + - induction l in H |- *. + now cbn in H. + cbn in H. destruct H; subst; cbn. + * cbn. apply join_le_left. + * specialize (IHl H). etransitivity; tea. apply join_le_right. + Qed. + + Lemma interp_prems_elements V u : + interp_prems V u = fold_right join (interp_expr V (to_nonempty_list u).1) (List.map (interp_expr V) (to_nonempty_list u).2). + Proof. + rewrite /interp_prems. + have he := to_nonempty_list_spec u. + destruct to_nonempty_list. + now rewrite Universes.fold_right_map. + Qed. + + Lemma fold_right_interp {V : Level.t -> A} {x l x' l'} : + equivlistA Logic.eq (x :: l) (x' :: l') -> + fold_right join (interp_expr V x) (List.map (interp_expr V) l) = fold_right join (interp_expr V x') (List.map (interp_expr V) l'). + Proof. + intros eq. apply fold_right_equivlist_all. + intros a. rewrite !InA_In_eq. + rewrite !(in_map_iff (interp_expr V) (_ :: _)). + setoid_rewrite <-InA_In_eq. + split. + - move=> [b [<- ]]. + eexists; split; trea. now apply eq in b0. + - move=> [b [<- ]]. + eexists; split; trea. now apply eq in b0. + Qed. + + Lemma equivlistA_add le u : let l := to_nonempty_list (NES.add le u) in + equivlistA eq (l.1 :: l.2) (le :: LevelExprSet.elements u). + Proof. + have he := to_nonempty_list_spec (NES.add le u). + destruct to_nonempty_list. cbn. + intros x. rewrite he. + rewrite !LevelExprSet.elements_spec1. + split. + - move/LevelExprSet.add_spec => [->|hin]. + now constructor. constructor 2. now apply LevelExprSet.elements_spec1. + - intros h; depelim h; subst. now apply LevelExprSet.add_spec; left. + apply LevelExprSet.add_spec. now apply LevelExprSet.elements_spec1 in h. + Qed. + + Lemma interp_prems_add V le (u : premises) : + interp_prems V (NES.add le u) = Z.max (interp_expr V le) (interp_prems V u). + Proof. + rewrite 2!interp_prems_elements. + erewrite fold_right_interp. 2:apply equivlistA_add. + rewrite fold_right_comm. + { apply map_nil, elements_not_empty. } + f_equal. eapply fold_right_equivlist_all. + have he := to_nonempty_list_spec u. + destruct to_nonempty_list. rewrite -he //=. + Qed. + + Lemma interp_prems_elim (P : premises -> Z -> Prop) V : + (forall le, P (NES.singleton le) (interp_expr V le)) -> + (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (NES.add le u) (Z.max (interp_expr V le) k)) -> + forall u, P u (interp_prems V u). + Proof. + intros hs hadd. + eapply elim. + - intros le. rewrite interp_prems_singleton. apply hs. + - intros le prems ih hnin. + rewrite interp_prems_add. now apply hadd. + Qed. + + Local Open Scope Z_scope. + Lemma interp_add_prems V n e : interp_prems V (add_prems n e) = n + interp_prems V e. + Proof. + revert e. + refine (interp_prems_elim (fun u z => interp_prems V (add_prems n u) = n + z) _ _ _). + - intros le. + rewrite add_prems_singleton interp_prems_singleton //=. + destruct le; cbn. lia. + - intros le u k heq hnin. + rewrite add_prems_add. + rewrite interp_prems_add heq interp_add_expr. lia. + Qed. + + + Lemma interp_prems_in {V le} {u : premises} : LevelExprSet.In le u -> interp_prems V u >= interp_expr V le. + Proof. + revert u. + refine (interp_prems_elim (fun u z => LevelExprSet.In le u -> z >= interp_expr V le) V _ _). + - intros le' u'. + apply LevelExprSet.singleton_spec in u'. red in u'; subst. lia. + - move=> le' u z hz hnin /LevelExprSet.add_spec [->|hin]. lia. + specialize (hz hin). lia. + Qed. + + Lemma clauses_sem_subset {u u' : premises} : u ⊂_leset u' -> + forall V, interp_prems V u' >= interp_prems V u. + Proof. + intros hsub V. + revert u u' hsub. + refine (interp_prems_elim (fun u z => forall u' : premises, u ⊂_leset u' -> interp_prems V u' >= z) V _ _). + - intros le u' hsing. + specialize (hsing le). forward hsing by now apply LevelExprSet.singleton_spec. + now apply interp_prems_in. + - intros le u k ih hin u' sub. + have hle := sub le. + specialize (ih u'). + forward ih. intros x hin'. apply sub. now apply LevelExprSet.add_spec; right. + forward hle by now apply LevelExprSet.add_spec; left. + have hi := interp_prems_in (V := V) hle. lia. + Qed. + + + End OfSL. End Semantics. Definition enabled_clause (m : model) (cl : clause) := - exists z, min_premise m (premise cl) = Some z. + exists z, min_premise m (premise cl) = Some z. Definition enabled_clauses (m : model) (cls : clauses) := Clauses.For_all (enabled_clause m) cls. - Definition correct_model (cls : clauses) (m : model) := - enabled_clauses m cls /\ clauses_sem (valuation_of_model m) cls. + + Import Semilattice. + + Definition to_val (v : LevelMap.t nat) l := + match LevelMap.find l v with + | Some n => n + | None => 0%nat + end. + + (* Interprest in a nat semilattice only *) + Definition correct_model {SL : Semilattice nat} (cls : clauses) (m : model) := + enabled_clauses m cls /\ clauses_sem (to_val (valuation_of_model m)) cls. Lemma enabled_clause_ext {m m' cl} : m ⩽ m' -> enabled_clause m cl -> enabled_clause m' cl. @@ -3011,101 +3156,6 @@ Lemma is_update_of_empty cls m : now apply enabled_clause_ext. Qed. - Lemma interp_prems_ge v (prems : premises) : - forall prem, LevelExprSet.In prem prems -> - interp_expr v prem <= interp_prems v prems. - Proof. - intros. - unfold interp_prems. - have he := to_nonempty_list_spec prems. - destruct to_nonempty_list. - pose proof to_nonempty_list_spec'. - rewrite In_elements in H. rewrite -he in H. clear H0 he. clear -H. - destruct H. subst p. - - induction l. cbn. auto. - cbn. lia. cbn. lia. - - induction l in H |- *. - now cbn in H. - cbn in H. destruct H; subst; cbn. - * cbn. lia. - * specialize (IHl H). lia. - Qed. - - Lemma interp_prems_elements V u : - interp_prems V u = fold_right Z.max (interp_expr V (to_nonempty_list u).1) (List.map (interp_expr V) (to_nonempty_list u).2). - Proof. - rewrite /interp_prems. - have he := to_nonempty_list_spec u. - destruct to_nonempty_list. - now rewrite Universes.fold_right_map. - Qed. - - Lemma fold_right_interp {V x l x' l'} : - equivlistA eq (x :: l) (x' :: l') -> - fold_right Z.max (interp_expr V x) (List.map (interp_expr V) l) = fold_right Z.max (interp_expr V x') (List.map (interp_expr V) l'). - Proof. - intros eq. apply fold_right_equivlist_all. - intros a. rewrite !InA_In_eq. - rewrite !(in_map_iff (interp_expr V) (_ :: _)). - setoid_rewrite <-InA_In_eq. - split. - - move=> [b [<- ]]. - eexists; split; trea. now apply eq in b0. - - move=> [b [<- ]]. - eexists; split; trea. now apply eq in b0. - Qed. - - Lemma equivlistA_add le u : let l := to_nonempty_list (NES.add le u) in - equivlistA eq (l.1 :: l.2) (le :: LevelExprSet.elements u). - Proof. - have he := to_nonempty_list_spec (NES.add le u). - destruct to_nonempty_list. cbn. - intros x. rewrite he. - rewrite !LevelExprSet.elements_spec1. - split. - - move/LevelExprSet.add_spec => [->|hin]. - now constructor. constructor 2. now apply LevelExprSet.elements_spec1. - - intros h; depelim h; subst. now apply LevelExprSet.add_spec; left. - apply LevelExprSet.add_spec. now apply LevelExprSet.elements_spec1 in h. - Qed. - - Lemma interp_prems_add V le (u : premises) : - interp_prems V (NES.add le u) = Z.max (interp_expr V le) (interp_prems V u). - Proof. - rewrite 2!interp_prems_elements. - erewrite fold_right_interp. 2:apply equivlistA_add. - rewrite fold_right_comm. - { apply map_nil, elements_not_empty. } - f_equal. eapply fold_right_equivlist_all. - have he := to_nonempty_list_spec u. - destruct to_nonempty_list. rewrite -he //=. - Qed. - - Lemma interp_prems_elim (P : premises -> Z -> Prop) V : - (forall le, P (NES.singleton le) (interp_expr V le)) -> - (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (NES.add le u) (Z.max (interp_expr V le) k)) -> - forall u, P u (interp_prems V u). - Proof. - intros hs hadd. - eapply elim. - - intros le. rewrite interp_prems_singleton. apply hs. - - intros le prems ih hnin. - rewrite interp_prems_add. now apply hadd. - Qed. - - Local Open Scope Z_scope. - Lemma interp_add_prems V n e : interp_prems V (add_prems n e) = n + interp_prems V e. - Proof. - revert e. - refine (interp_prems_elim (fun u z => interp_prems V (add_prems n u) = n + z) _ _ _). - - intros le. - rewrite add_prems_singleton interp_prems_singleton //=. - destruct le; cbn. lia. - - intros le u k heq hnin. - rewrite add_prems_add. - rewrite interp_prems_add heq interp_add_expr. lia. - Qed. - Lemma in_pred_closure_entails cls cl : in_pred_closure cls cl -> (forall V, clauses_sem V cls -> clause_sem V cl). @@ -3123,38 +3173,11 @@ Lemma is_update_of_empty cls m : cbn. lia. Qed. - Lemma interp_prems_in {V le} {u : premises} : LevelExprSet.In le u -> interp_prems V u >= interp_expr V le. - Proof. - revert u. - refine (interp_prems_elim (fun u z => LevelExprSet.In le u -> z >= interp_expr V le) V _ _). - - intros le' u'. - apply LevelExprSet.singleton_spec in u'. red in u'; subst. lia. - - move=> le' u z hz hnin /LevelExprSet.add_spec [->|hin]. lia. - specialize (hz hin). lia. - Qed. - - Lemma clauses_sem_subset {u u' : premises} : u ⊂_leset u' -> - forall V, interp_prems V u' >= interp_prems V u. - Proof. - intros hsub V. - revert u u' hsub. - refine (interp_prems_elim (fun u z => forall u' : premises, u ⊂_leset u' -> interp_prems V u' >= z) V _ _). - - intros le u' hsing. - specialize (hsing le). forward hsing by now apply LevelExprSet.singleton_spec. - now apply interp_prems_in. - - intros le u k ih hin u' sub. - have hle := sub le. - specialize (ih u'). - forward ih. intros x hin'. apply sub. now apply LevelExprSet.add_spec; right. - forward hle by now apply LevelExprSet.add_spec; left. - have hi := interp_prems_in (V := V) hle. lia. - Qed. - (** Enabled and valid clauses are satisfied by valuation *) Lemma valid_clause_model model cl : enabled_clause model cl -> valid_clause model cl -> - clause_sem (valuation_of_model model) cl. + clause_sem (to_val (valuation_of_model model)) cl. Proof. unfold enabled_clause, valid_clause. destruct min_premise eqn:hmin => //= => //. @@ -3163,13 +3186,13 @@ Lemma is_update_of_empty cls m : destruct cl as [prems [concl k]]; cbn. unfold level_value_above. destruct level_value eqn:hl => //. - unfold interp_level. unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. + unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. move/Z.leb_le => hrel. eapply LevelMap.find_2 in hfind. have conclm := valuation_of_model_spec _ _ _ hfind. set (v := (model_max _ - _)) in *. cbn in conclm. - eapply LevelMap.find_1 in conclm. rewrite conclm. + eapply LevelMap.find_1 in conclm. subst v. pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. rewrite hmin in premeq. @@ -3183,8 +3206,7 @@ Lemma is_update_of_empty cls m : intros [= <-]. eapply LevelMap.find_2 in findp. have premm := valuation_of_model_spec _ _ _ findp. - unfold interp_level. - eapply LevelMap.find_1 in premm. rewrite premm. + eapply LevelMap.find_1 in premm. assert (z1 - k' <= z0 - k). lia. have hm : z0 <= model_max model. { eapply model_max_spec in hfind; tea. now depelim hfind. } @@ -3196,13 +3218,14 @@ Lemma is_update_of_empty cls m : { eapply model_min_spec; tea. } assert (0 <= model_max model)%Z by apply model_max_spec2. assert (model_min model <= 0)%Z by apply model_min_spec2. + rewrite /to_val premm conclm. lia. Qed. Lemma valid_clauses_model model cls : enabled_clauses model cls -> is_model cls model -> - clauses_sem (valuation_of_model model) cls. + clauses_sem (to_val (valuation_of_model model)) cls. Proof. move=> en ism cl hin. apply valid_clause_model. diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 4f72563c8..d424b8ef3 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -1,6 +1,6 @@ From Stdlib Require Import OrdersAlt Structures.OrdersEx MSetList MSetAVL MSetFacts MSetProperties MSetDecide FMapAVL. From Equations Require Import Equations. -From MetaRocq.Utils Require Import utils MRMSets MRFSets NonEmptyLevelExprSet. +From MetaRocq.Utils Require Import utils MRMSets MRFSets NonEmptyLevelExprSet MRClasses. From MetaRocq.Common Require Import BasicAst config UnivConstraintType. From Stdlib Require Import ssreflect. @@ -383,6 +383,20 @@ Module Universe. - non empty *) Module Q <: Quantity. Include OrdersEx.Nat_as_OT. + + #[program] + Instance comm_monoid : CommutativeMonoid 0%nat add. + Next Obligation. + apply add_assoc. + Qed. + Next Obligation. + apply add_comm. + Qed. + Instance add_inj n : Injective (add n). + Proof. + red. intros x y; lia. + Qed. + Definition reflect_eq : ReflectEq t := _. Definition eq_leibniz x y : eq x y -> x = y := fun e => e. End Q. diff --git a/template-rocq/src/g_template_rocq.ml b/template-rocq/src/g_template_rocq.ml deleted file mode 100644 index a9187abbd..000000000 --- a/template-rocq/src/g_template_rocq.ml +++ /dev/null @@ -1,360 +0,0 @@ -let _ = Mltop.add_known_module "rocq-metarocq-template-rocq.plugin" - -# 4 "src/g_template_rocq.mlg" - - -open Attributes -open Ltac_plugin -open Names - -(** Calling Ltac **) - -let ltac_lcall tac args = - let (location, name) = Loc.tag (Names.Id.of_string tac) - (* Loc.tag @@ Names.Id.of_string tac *) - in - CAst.make ?loc:location (Tacexpr.TacArg(Tacexpr.TacCall - (CAst.make (Locus.ArgVar (CAst.make ?loc:location name),args)))) - -open Tacexpr -open Tacinterp -open Stdarg -open Tacarg -open Redexpr - -(* If strict unquote universe mode is on then fail when unquoting a non *) -(* declared universe / an empty list of level expressions. *) -(* Otherwise, add it / a fresh level the global environnment. *) - -let _ = - let open Goptions in - declare_bool_option - { optdepr = None; - optstage = Interp; - optkey = ["MetaRocq"; "Strict"; "Unquote"; "Universe"; "Mode"]; - optread = (fun () -> !Denoter.strict_unquote_universe_mode); - optwrite = (fun b -> Denoter.strict_unquote_universe_mode := b) } - -let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) = - let fold arg (i, vars, lfun) = - let id = Names.Id.of_string ("x" ^ string_of_int i) in - let (l,n) = (Loc.tag id) in - let x = Reference (Locus.ArgVar (CAst.make ?loc:l n)) in - (succ i, x :: vars, Id.Map.add id arg lfun) - in - let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in - let lfun = Id.Map.add (Id.of_string "F") f lfun in - let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in - Tacinterp.eval_tactic_ist ist (ltac_lcall "F" args) - -let to_ltac_val c = Tacinterp.Value.of_constr c - -let run_template_program ~pm env evm ~poly pgm = - Run_template_monad.run_template_program_rec ~poly (fun ~st _ _ _ -> st) ~st:pm env (evm, pgm) - -let fresh_env () = - let env = Global.env () in - let sigma = Evd.from_env env in - env, sigma - -let to_constr_evars sigma c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c - - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Test_Quote" ~classifier:(fun _ -> Vernacextend.classify_as_query) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Test", - Vernacextend.TyTerminal - ("Quote", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))), - (let coqpp_body def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 67 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmTestQuote) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, - [|Constr.mkRel 0; to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun def ?loc ~atts () -> - coqpp_body def (Attributes.parse -# 66 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Quote", - Vernacextend.TyTerminal - ("Definition", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), - Vernacextend.TyTerminal - (":=", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))))), - (let coqpp_body name def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 77 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteDefinition) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; - to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun name def ?loc ~atts () -> - coqpp_body name def (Attributes.parse -# 76 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Definition_Eval" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Quote", - Vernacextend.TyTerminal - ("Definition", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), - Vernacextend.TyTerminal - (":=", - Vernacextend.TyTerminal - ("Eval", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_red_expr), - Vernacextend.TyTerminal - ("in", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil))))))))), - (let coqpp_body name rd def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 87 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - (* TODO : implem quoting of tactic reductions so that we can use ptmQuoteDefinitionRed *) - let (evm, rd) = Redexpr.interp_redexp_no_ltac env evm rd in - let (evm, def) = Plugin_core.reduce env evm rd (to_constr_evars evm def) in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteDefinition) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun name rd def ?loc ~atts () -> - coqpp_body name rd def (Attributes.parse -# 86 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Recursively_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Quote", - Vernacextend.TyTerminal - ("Recursively", - Vernacextend.TyTerminal - ("Definition", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), - Vernacextend.TyTerminal - (":=", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil))))))), - (let coqpp_body name def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 99 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteRecDefinition) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; - to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun name def ?loc ~atts () -> - coqpp_body name def (Attributes.parse -# 98 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Test_Unquote" ~classifier:(fun _ -> Vernacextend.classify_as_query) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Test", - Vernacextend.TyTerminal - ("Unquote", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))), - (let coqpp_body def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 109 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmTestUnquote) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, - [|to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun def ?loc ~atts () -> - coqpp_body def (Attributes.parse -# 108 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Make_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Unquote", - Vernacextend.TyTerminal - ("Definition", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), - Vernacextend.TyTerminal - (":=", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))))), - (let coqpp_body name def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 119 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmMkDefinition) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, - [|Constr_quoter.quote_ident name; - to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun name def ?loc ~atts () -> - coqpp_body name def (Attributes.parse -# 118 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Make_Inductive" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Unquote", - Vernacextend.TyTerminal - ("Inductive", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))), - (let coqpp_body def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 130 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmMkInductive) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, - [|Constr_quoter.quote_bool false; to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun def ?loc ~atts () -> - coqpp_body def (Attributes.parse -# 129 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Run_Template_Program" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Run", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil))), - (let coqpp_body def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 140 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (pgm, ctx) = Constrintern.interp_constr env evm def in - let evm = Evd.from_ctx ctx in - let pgm = EConstr.to_constr ~abort_on_undefined_evars:true evm pgm in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun def ?loc ~atts () -> - coqpp_body def (Attributes.parse -# 139 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_quote_term" ~level:0 - [(Tacentries.TyML (Tacentries.TyIdent ("quote_term", Tacentries.TyArg ( - Extend.TUentry (Genarg.get_arg_tag wit_constr), - Tacentries.TyArg ( - Extend.TUentry (Genarg.get_arg_tag wit_tactic), - Tacentries.TyNil))), - (fun c tac ist -> -# 152 "src/g_template_rocq.mlg" - (* quote the given term, pass the result to t *) - Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let c = to_constr_evars sigma c in - let c = Constr_quoter.quote_term env sigma c in - ltac_apply tac (List.map to_ltac_val [EConstr.of_constr c]) - end - )))] - -let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_denote_term" ~level:0 - [(Tacentries.TyML (Tacentries.TyIdent ("denote_term", Tacentries.TyArg ( - Extend.TUentry (Genarg.get_arg_tag wit_constr), - Tacentries.TyArg ( - Extend.TUentry (Genarg.get_arg_tag wit_tactic), - Tacentries.TyNil))), - (fun c tac ist -> -# 164 "src/g_template_rocq.mlg" - Proofview.Goal.enter (begin fun gl -> - let env = Proofview.Goal.env gl in - let evm = Proofview.Goal.sigma gl in - let evm, c = Constr_denoter.denote_term env evm (to_constr_evars evm c) in - let evm, _ = Typing.type_of env evm (EConstr.of_constr c) in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) - (ltac_apply tac (List.map to_ltac_val [EConstr.of_constr c])) - end) - )))] - -let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_run_template_program" ~level:0 - [(Tacentries.TyML (Tacentries.TyIdent ("run_template_program", - Tacentries.TyArg (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Tacentries.TyArg (Extend.TUentry (Genarg.get_arg_tag wit_tactic), - Tacentries.TyNil))), (fun c tac ist -> -# 176 "src/g_template_rocq.mlg" - let open Proofview.Notations in - Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (name, poly) -> - Proofview.Goal.enter (begin fun gl -> - let env = Proofview.Goal.env gl in - let evm = Proofview.Goal.sigma gl in - let ret = ref None in - (* We don't allow opening obligations / updating the vernacular inside proofs / as tactics *) - let pm = Declare.OblState.empty in - let _pm = Run_template_monad.run_template_program_rec - ~poly ~intactic:true ~st:pm (fun ~st env evm t -> ret := Some (env,evm,t); st) - env (evm, to_constr_evars evm c) - in - match !ret with - | Some (env, evm, t) -> - Proofview.tclTHEN - (Proofview.Unsafe.tclEVARS evm) - (ltac_apply tac (List.map to_ltac_val [EConstr.of_constr t])) - | None -> Proofview.tclUNIT () - end) - )))] - diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v index 7d1bef180..56ccf02ff 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -626,9 +626,9 @@ End ZUnivConstraint. - clear H Heqcall. reflexivity. Qed. - Definition to_valuation (v : LevelMap.t nat) : valuation := - {| valuation_mono := fun s => Pos.of_nat (option_get 0 (LevelMap.find (Level.level s) v)); - valuation_poly := fun i => option_get 0 (LevelMap.find (Level.lvar i) v) + Definition to_valuation (v : Level.t -> nat) : valuation := + {| valuation_mono := fun s => Pos.of_nat (v (Level.level s)); + valuation_poly := fun i => v (Level.lvar i); |}. Definition of_valuation V (v : valuation) : LevelMap.t nat := @@ -693,14 +693,13 @@ End ZUnivConstraint. rewrite Universes.LevelExprSet.add_spec. now right. Qed. - Lemma interp_prem_to_atom v le : interp_expr v (to_atom le) = Z.of_nat (val (to_valuation v) le). + Lemma interp_prem_to_atom v le : interp_expr v (to_atom le) = Z.of_nat (val (to_valuation v) le). Proof. destruct le => //=. cbn. destruct t0. - (* lzero is forced to have value 0, has it should stay maximal *) todo "handle lzero". - todo "handle monos". - - cbn. unfold interp_level. destruct LevelMap.find eqn:he => //=. lia. - lia. + - cbn. lia. Qed. Lemma clauses_sem_union v cls cls' : clauses_sem v (Clauses.Clauses.union cls cls') <-> @@ -727,16 +726,17 @@ End ZUnivConstraint. Qed. Lemma clauses_sem_val m l r : - clauses_sem (LoopCheck.valuation m) (clauses_of_le (to_atoms l) (to_atoms r)) -> - Universes.val (to_valuation (LoopCheck.valuation m)) l <= Universes.val (to_valuation (LoopCheck.valuation m)) r. + clauses_sem (to_val (LoopCheck.valuation m)) (clauses_of_le (to_atoms l) (to_atoms r)) -> + Universes.val (to_valuation (to_val (LoopCheck.valuation m))) l <= + Universes.val (to_valuation (to_val (LoopCheck.valuation m))) r. Proof. move/clauses_sem_clauses_of_le. - have he := interp_prems_to_atoms (LoopCheck.valuation m) l. - have he' := interp_prems_to_atoms (LoopCheck.valuation m) r. lia. + have he := interp_prems_to_atoms (to_val (LoopCheck.valuation m)) l. + have he' := interp_prems_to_atoms (to_val (LoopCheck.valuation m)) r. lia. Qed. Lemma model_satisfies m : - satisfies (to_valuation (LoopCheck.valuation (model m))) (constraints m). + satisfies (to_valuation (to_val (LoopCheck.valuation (model m)))) (constraints m). Proof. destruct m as [m cstrs repr repr_inv]. cbn. have val := LoopCheck.model_valuation m. @@ -749,12 +749,13 @@ End ZUnivConstraint. Qed. Lemma to_of_valuation V v : - forall l, LevelSet.In l.1 V -> val (to_valuation (of_valuation V v)) l = val v l. + forall l, LevelSet.In l.1 V -> val (to_valuation (to_val (of_valuation V v))) l = val v l. Proof. Admitted. Lemma to_of_valuation_univ V v : - forall u : Universe.t, LevelSet.Subset (Universe.levels u) V -> val (to_valuation (of_valuation V v)) u = val v u. + forall u : Universe.t, LevelSet.Subset (Universe.levels u) V -> + val (to_valuation (to_val (of_valuation V v))) u = val v u. Proof. Admitted. @@ -776,10 +777,10 @@ End ZUnivConstraint. Lemma interp_level_of_valuation {V v l} : LevelSet.In l V -> - interp_level (of_valuation V v) l = val v l. + to_val (of_valuation V v) l = val v l. Proof. move=> hin. - rewrite /interp_level. + rewrite /to_val. elim: find_spec => [k /of_valuation_spec []|] => //. elim. exists (val v l). rewrite [LevelMap.Raw.MapsTo _ _ _]of_valuation_spec. split => //. @@ -802,7 +803,7 @@ End ZUnivConstraint. LevelSet.Subset (univ_constraint_levels (l, ConstraintType.Le, r)) V -> val v l <= val v r -> forall cl, LevelExprSet.Exists (fun lk : LevelExprSet.elt => cl = (to_atoms r, lk)) (to_levelexprzset l) -> - clause_sem (of_valuation V v) cl. + clause_sem (to_val (of_valuation V v)) cl. Proof. move=> hlev leq [prems concl]. move=> [] [l'' k'] [] /to_levelexprzset_spec_2 [] inl' pos ->. @@ -821,7 +822,7 @@ End ZUnivConstraint. Lemma satisfies_clauses_sem v m V : LoopCheck.levels (model m) ⊂_lset V -> satisfies v (constraints m) -> - clauses_sem (of_valuation V v) (LoopCheck.clauses (model m)). + clauses_sem (to_val (of_valuation V v)) (LoopCheck.clauses (model m)). Proof. have repr := repr_constraints_inv m. have repr_inv := repr_constraints m. @@ -853,7 +854,7 @@ End ZUnivConstraint. Lemma clauses_sem_satisfies {v V c} : univ_constraint_levels c ⊂_lset V -> - clauses_sem (of_valuation V v) (LoopCheck.to_clauses (to_constraint c)) -> + clauses_sem (to_val (of_valuation V v)) (LoopCheck.to_clauses (to_constraint c)) -> satisfies0 v c. Proof. intros hin hsem. destruct c as [[l []] r]; cbn in *. @@ -956,7 +957,7 @@ End ZUnivConstraint. eapply (repr_constraints m); tea. Qed. - Section Nat_Semilattice. + (* Section Nat_Semilattice. Import Semilattice. Equations? nat_semilattice : semilattice := nat_semilattice := @@ -967,7 +968,7 @@ End ZUnivConstraint. Proof. all:lia. Qed. - End Nat_Semilattice. + End Nat_Semilattice. *) Section Z_Semilattice. Import Semilattice. @@ -975,7 +976,7 @@ End ZUnivConstraint. Z_semilattice := {| carrier := Z; eq := Logic.eq; - succ x := Z.succ x; + add := Z.add; join x y := Z.max x y |}. Proof. all:lia. @@ -994,7 +995,7 @@ End ZUnivConstraint. Lemma val_respects cls v : respects (leset_sl cls) Z_semilattice (fun u => interp_prems v u). Proof. split; cbn. - - intros x. rewrite interp_add_prems. lia. + - intros n x. rewrite interp_add_prems. lia. - intros x y. rewrite interp_prems_union. lia. Qed. @@ -1093,14 +1094,30 @@ End ZUnivConstraint. split; apply univ_le_refl; tea. now symmetry. Qed. + Lemma univ_eq_sym u u' : univ_eq u u' -> univ_eq u' u. + Proof. + move=> [] le le'. split; auto. + Qed. + + Lemma univ_eq_trans u u' u'' : univ_eq u u' -> univ_eq u' u'' -> univ_eq u u''. + Proof. + move=> [] le le' [] le0 le0'. split; auto. + Qed. + Equations? pres_semilattice : semilattice := pres_semilattice := {| carrier := NES.t; eq x y := relations p.(C) -> univ_eq x y; - succ x := add_prems 1 x; + add := add_prems; join x y := univ_union x y |}. Proof. all:intros. + - split; red; intros. + * now apply univ_eq_refl. + * now apply univ_eq_sym, H. + * now eapply univ_eq_trans; eauto. + - rewrite add_prems_add_prems. now apply univ_eq_refl. + - rewrite add_prems_0. now apply univ_eq_refl. - apply univ_eq_refl. now rewrite univ_union_assoc. - apply univ_eq_refl. now rewrite univ_union_comm. - split. intros l k; rewrite !LevelExprSet.union_spec. @@ -1163,6 +1180,13 @@ End ZUnivConstraint. now eapply entails_L_le_trans. Qed. + Lemma entails_L_rels_subset {rels rels' r} : + rels ⊢ℒ r -> + incl rels rels' -> + rels' ⊢ℒ r. + Proof. + induction 1; try solve [econstructor; eauto]. + Qed. Definition relation_of_constraint c := let '(l, d, r) := c in @@ -1208,6 +1232,41 @@ End ZUnivConstraint. Definition relations_of_clauses c := Clauses.fold (fun '(prems, concl) acc => (singleton concl ∨ prems, prems) :: acc) c []. + Definition clauses_of_relations r := + List.fold_right (fun '(l, r) acc => Clauses.union (clauses_of_eq l r) acc) Clauses.empty r. + + Lemma clauses_of_relations_spec {rels} : + forall cl, Clauses.In cl (clauses_of_relations rels) -> + exists r, In r rels /\ Clauses.In cl (clauses_of_eq r.1 r.2). + Proof. + rewrite /clauses_of_relations. + induction rels; cbn. + - clsets. + - move=> cl. destruct a as [l r]; cbn in *. + rewrite Clauses.union_spec => -[]. + * rewrite /clauses_of_eq Clauses.union_spec => -[inl|inr]; cbn; + rw Clauses.union_spec; cbn. + exists (l, r). split => //. now left. cbn. now left. + exists (l, r). split => //. now left. cbn. now right. + * move/IHrels => [[l' r'] [hin]]; cbn in *. + rewrite /clauses_of_eq Clauses.union_spec => -[inl|inr]; cbn; + rw Clauses.union_spec; now exists (l', r'); split => //. + Qed. + + + Lemma clauses_of_relations_spec_inv {rels} : + forall r, In r rels -> + Clauses.Subset (clauses_of_eq r.1 r.2) (clauses_of_relations rels). + Proof. + rewrite /clauses_of_relations. + induction rels; cbn. + - clsets. + - move=> [l r] //= []. + * move=> -> ?. rewrite Clauses.union_spec; now left. + * move/IHrels => //= hin ?. destruct a as [l' r']. + rewrite Clauses.union_spec; now right. + Qed. + Lemma relations_of_clauses_spec {cls} : forall eq, In eq (relations_of_clauses cls) -> exists prems concl, Clauses.In (prems, concl) cls /\ @@ -1433,7 +1492,7 @@ End ZUnivConstraint. - move: IHh; rewrite -!univ_union_add_singleton. eapply in_pred_closure_entails_L in H. rewrite /entails_L_clause in H |- *; cbn in *. - have hsub:= entails_L_subset H H0. red in hsub. + have hsub:= entails_L_subset H H0. move=> h'. eapply entails_L_le_trans. tea. move/entails_L_eq_le_1: hsub. now rewrite univ_union_comm. @@ -1481,7 +1540,7 @@ End ZUnivConstraint. Lemma entails_L_le_left {p x y} : p ⊢ℒ x ≤ x ∨ y. Proof. - red. rewrite -univ_union_assoc. + rewrite /rel_le. rewrite -univ_union_assoc. eapply entails_join_congr_all. apply entails_idem. apply entails_refl. Qed. @@ -1537,6 +1596,27 @@ End ZUnivConstraint. eexists; split; tea. cbn. now cbn. Qed. + Lemma entails_L_clauses_pres_all {p s t} : + (relations_of_clauses (clauses_of_relations p)) ⊢ℒ s ≡ t -> + p ⊢ℒ s ≡ t. + Proof. + induction 1; try solve [econstructor; eauto]. cbn in H. + move/relations_of_clauses_spec: H => [prems [concl [hin heq]]]. + noconf heq. + move/clauses_of_relations_spec: hin => [[l r]] [] hin //=. + rewrite /clauses_of_eq Clauses.union_spec => -[] hin'; + eapply entails_L_le_eq; + rewrite clauses_of_le_spec in hin'. + - destruct hin' as [? [hin' heq]]. noconf heq. + eapply entails_L_le_trans with l. + * now eapply entails_L_in. + * eapply entails_L_eq_le_1. now constructor. + - destruct hin' as [? [hin' heq]]; noconf heq. + eapply entails_L_le_trans with r. + + now eapply entails_L_in. + + eapply entails_L_eq_le_1. eapply entails_sym. now constructor. + Qed. + Lemma entails_L_clauses_le {cstrs s t} : entails_L_clauses (relations_of_clauses (of_z_constraints cstrs)) (s ⋞ t) -> relations_of_constraints cstrs ⊢ℒ s ≤ t. @@ -1583,7 +1663,7 @@ End ZUnivConstraint. ZUnivConstraintSet.For_all (entails_L_cstr p) cstrs. Section interp. - Context (v : LevelMap.t nat). + Context (v : Level.t -> nat). Definition interp_z_cstr c := let '(l, d, r) := c in @@ -1597,24 +1677,133 @@ End ZUnivConstraint. Definition interp_univ_cstrs c := UnivConstraintSet.For_all interp_univ_cstr c. + Definition interp_cstr r := + let '(l, r) := r in + interp_prems v l = interp_prems v r. + Definition interp_cstrs c := - List.Forall (fun '(l, r) => interp_prems v l = interp_prems v r) c. + List.Forall interp_cstr c. + End interp. + Module SemilatticeInterp. + Import Semilattice. + + Section interp_gen. + Context (s : semilattice). + Context (v : Level.t -> s). + + Definition interp_expr '(l, k) := (add s k (v l))%Z. + Definition interp_prems_s prems := + let '(hd, tl) := to_nonempty_list prems in + fold_right (fun lk acc => join s (interp_expr lk) acc) (interp_expr hd) tl. + + Definition interp_rel r := + let '(l, r) := r in + eq s (interp_prems_s l) (interp_prems_s r). + + Definition interp_rels c := + List.Forall interp_rel c. + End interp_gen. + + Definition valid_relation s rels c := + (forall v, interp_rels s v rels -> interp_rel s v c). + End SemilatticeInterp. + Definition valid_constraint rels c := (forall v, interp_cstrs v rels -> interp_z_cstr v c). Definition valid_cstrs p cstrs := ZUnivConstraintSet.For_all (valid_constraint p) cstrs. + Lemma entails_clauses_pres_eq_left {p l r} : + In (l, r) p -> + clauses_of_relations p ⊢a r → l. + Proof. + intros hin l' cl. + eapply in_pred_closure_entails_clause, incls0. + eapply clauses_of_relations_spec_inv. tea. cbn. + rewrite /clauses_of_eq Clauses.union_spec. left. + apply clauses_of_le_spec. now exists l'. + Qed. + + Lemma entails_clauses_pres_eq_right {p l r} : + In (l, r) p -> + clauses_of_relations p ⊢a l → r. + Proof. + intros hin l' cl. + eapply in_pred_closure_entails_clause, incls0. + eapply clauses_of_relations_spec_inv. tea. cbn. + rewrite /clauses_of_eq Clauses.union_spec. right. + apply clauses_of_le_spec. now exists l'. + Qed. + + Lemma entails_clauses_eq_pres {p l r} : + In (l, r) p -> + clauses_of_relations p ⊢ℋ l ≡ r. + Proof. + intros hin. + apply Theory.eq_antisym. + split. + - rewrite Theory.to_entails_all. now apply entails_clauses_pres_eq_left. + - rewrite Theory.to_entails_all. now apply entails_clauses_pres_eq_right. + Qed. + + Lemma entails_L_clauses_pres_le {p s t} : + entails_L_clauses (relations_of_clauses (clauses_of_relations p)) (s ⋞ t) -> + p ⊢ℒ s ≤ t. + Proof. + intros hf. do 2 red in hf. + rw_in clauses_of_le_spec hf. + eapply entails_L_split. + move=> le hin. + move: (hf (t, le)) => /fwd. + { exists le; split => //. } + move=> h; red in h. cbn in h. + now eapply entails_L_clauses_pres_all in h. + Qed. + + Lemma entails_L_clauses_of_relations_eq {p s t} : + entails_L_clauses (relations_of_clauses (clauses_of_relations p)) (s ≡ t) -> + p ⊢ℒ s ≡ t. + Proof. + intros hf. do 2 red in hf. + eapply entails_L_eq_antisym. + all: apply entails_L_clauses_pres_le. + - intros cl hin; red. eapply hf. + rewrite /clauses_of_eq. clsets. + - intros cl hin; red. eapply hf. + rewrite /clauses_of_eq. clsets. + Qed. + + Lemma completeness_eq p s t : + p ⊢ℒ s ≡ t <-> + clauses_of_relations p ⊢ℋ clauses_of_eq s t. + Proof. + split. + - intros h; depind h; cbn. + * now eapply entails_clauses_eq_pres. + * eapply Theory.eq_refl. + * now eapply Theory.eq_sym. + * now eapply Theory.eq_trans. + * now eapply Theory.succ_congr. + * now eapply Theory.join_congr_left. + * eapply Theory.join_assoc. + * eapply Theory.join_idem. + * eapply Theory.join_comm. + * eapply Theory.join_succ. + * now eapply Theory.succ_inj. + * eapply Theory.succ_join. + - move/entails_clauses_pres. apply entails_L_clauses_of_relations_eq. + Qed. - Lemma completeness_eq cstrs s t : + Lemma completeness_eq_cstrs cstrs s t : relations_of_constraints cstrs ⊢ℒ s ≡ t <-> entails_z_cstr cstrs (s, ConstraintType.Eq, t). Proof. unfold entails_z_cstr. split. - - induction 1; cbn. + - intros h; depind h; cbn. move: H => //=; rewrite relations_of_constraints_spec => -[] [[l' []] r'] [hin heq]; noconf heq. * eapply Theory.le_spec. now apply entails_clauses_le_cstr. @@ -1639,7 +1828,7 @@ End ZUnivConstraint. Proof. unfold entails_z_cstr. split. - - move/completeness_eq. cbn. + - move/completeness_eq_cstrs. cbn. intros h; red in h. cbn in h. eapply Theory.le_spec. now rewrite /C.le. - move/entails_clauses_pres. apply entails_L_clauses_le. @@ -1654,7 +1843,7 @@ End ZUnivConstraint. | ConstraintType.Eq => relations_of_constraints (to_z_cstrs cstrs) ⊢ℒ l ≡ r end. - Instance entils_claues_proper : Proper (Clauses.Equal ==> Clauses.Equal ==> iff) entails_clauses. + Instance entails_clauses_proper : Proper (Clauses.Equal ==> Clauses.Equal ==> iff) entails_clauses. Proof. intros cls cls' H cls0 cls0' H'. rewrite /entails_clauses. @@ -1685,23 +1874,38 @@ End ZUnivConstraint. - rewrite completeness_le. rewrite /entails_cstr /entails_z_cstr. now rewrite to_clauses_of_z_constraints. - - rewrite completeness_eq. + - rewrite completeness_eq_cstrs. rewrite /entails_cstr /entails_z_cstr. now rewrite to_clauses_of_z_constraints. Qed. + Section SemiLatticeInterp. + Import SemilatticeInterp. + Import Semilattice. + Lemma presentation_entails_valid_rel {p r s} : + p ⊢ℒ r -> valid_relation s p r. + Proof. + rewrite /valid_relation //=. + destruct r as [l r] => //=. + intros h; depind h; cbn; move=> v hv. + 1:{ red in hv. rewrite Forall_forall in hv; eapply hv in H. exact H. } + all:try specialize (IHh _ _ s eq_refl _ hv). + all:try specialize (IHh1 _ _ s eq_refl _ hv). + all:try specialize (IHh2 _ _ s eq_refl _ hv). + all:try lia; eauto. + all:rewrite ?interp_add_prems ?interp_prems_union ?interp_add_prems; try lia. + - eapply reflexivity. + - now eapply symmetry, IHh. + - eapply transitivity; [eapply IHh1|eapply IHh2] => //. + - rewrite interp_add_prems. + rewrite ?interp_add_prems in IHh. lia. + Qed. + Lemma presentation_entails_valid_eq {p l r} : p ⊢ℒ l ≡ r -> valid_constraint p (l, ConstraintType.Eq, r). Proof. - rewrite /valid_constraint /interp_z_cstr //=. - induction 1; cbn; move=> v hv. - 1:by red in hv; rewrite Forall_forall in hv; eapply hv in H. - all:try specialize (IHentails_L _ hv). - all:try specialize (IHentails_L1 _ hv). - all:try specialize (IHentails_L2 _ hv). - all:try lia; eauto. - all:rewrite ?interp_add_prems ?interp_prems_union ?interp_add_prems; try lia. - rewrite ?interp_add_prems in IHentails_L. lia. + move/presentation_entails_valid_rel. + rewrite /valid_relation /valid_constraint /interp_z_cstr //=. Qed. Lemma presentation_entails_valid_le {p l r} : @@ -1824,21 +2028,6 @@ End ZUnivConstraint. end. Section Completeness. - Definition consistent (r : rels) := - ~ (exists x, r ⊢ℒ x ≡ succ_prems x). - - Definition satisfiable (r : rels) := - exists v, interp_cstrs v r. - - Definition satisfiable_consistent {p} : - satisfiable p -> consistent p. - Proof. - intros [v it] [x hx]. - eapply presentation_entails_valid_eq in hx. red in hx. - specialize (hx _ it). - move: hx. cbn. - rewrite interp_add_prems. lia. - Qed. Definition add_presentation eq p := {| V := p.(V); C := eq :: p.(C) |}. @@ -1848,9 +2037,6 @@ End ZUnivConstraint. Definition wf_presentation p := forall r, List.In r p.(C) -> relation_levels r ⊂_lset p.(V). - Definition maximally_consistent (r : rels) := - consistent r /\ forall x y, ~ consistent ((x, y) :: r) \/ r ⊢ℒ x ≡ y. - Definition levels_position (l : Level.t) (ls : LevelSet.t) i := List.nth_error (LevelSet.elements ls) i = Some l. @@ -2013,9 +2199,8 @@ Qed. *) Definition check_pres_clause p r := LoopCheck.Impl.check_clauses (clauses_of_relations p) (clauses_of_eq r.1 r.2). - Definition check_add p l r := - if check_pres_clause p (l, r) then (l, r) :: p - else p. + Lemma check_pres_clause_spec p r : p ⊢ℒ r \/ ~ (p ⊢ℒ r). + Proof. Admitted. Lemma premises_strict_subset_add {l} {u : premises} : ~ LevelExprSet.In l u -> premises_strict_subset u (NES.add l u). @@ -2026,19 +2211,265 @@ Qed. *) - exists l; split => //. right; now apply LevelExprSet.singleton_spec. Qed. - Parameter ϕ : nat -> rel. + Lemma clauses_of_relations_cons {l r rels} : + clauses_of_relations ((l, r) :: rels) =_clset + Clauses.union (clauses_of_eq l r) (clauses_of_relations rels). + Proof. + cbn. reflexivity. + Qed. + + Instance entails_all_proper : Proper (Clauses.Equal ==> Logic.eq ==> Logic.eq ==> iff) entails_all. + Proof. + intros cls cls' H ? ? <- ? ? <-. + split; intros ? ? hin. rewrite -H. now apply H0. + rewrite H; now apply H0. + Qed. + + Instance entails_equiv_proper : Proper (Clauses.Equal ==> Logic.eq ==> Logic.eq ==> iff) entails_equiv. + Proof. + intros cls cls' H ? ? <- ?? <-. + split. + - intros []; split; now rewrite -H. + - intros []; split; now rewrite H. + Qed. +(* + Lemma entails_deduction {cls prems prems' concl} : + entails cls (univ_union prems prems', concl) <-> + entails (Clauses.add (prems, concl) cls) (prems', concl). + Proof. + split. + - intros entc. + depind entc. + * *) + + + Lemma entails_cut {cls cl cl'} : + entails cls cl -> + entails (Clauses.add cl cls) cl' -> + entails cls cl'. + Proof. + intros ent ent'. + induction ent'. + - now constructor. + - depelim H. + * eapply Clauses.add_spec in H as [->|hin]. + destruct cl as [prems2 concl2]. noconf H0. + + apply: (@entails_add cls prems (add_expr n concl2) _ _ IHent'). + eapply entails_subset; tea. + now eapply (@entails_shift _ (_, _) n). + + destruct cl0 as [prems'' concl'']; noconf H0. + have h := (@entails_add cls prems (add_expr n concl'') _ _ IHent'). + apply h. + eapply entails_subset; tea. + eapply (@entails_shift _ (_, _) n). + now eapply entails_in. + * apply: (@entails_add cls prems (x, k)). + eapply clause_cut; tea. + { constructor 2; tea. } + { constructor. now rewrite LevelExprSet.add_spec. } + assumption. + Qed. + + Lemma entails_clauses_cut_one {cls cls0 cl} : + cls ⊢ℋ cls0 -> + entails (Clauses.union cls0 cls) cl -> + entails cls cl. + Proof. + move: cls0 cls cl. apply: ClausesProp.set_induction. + - intros s he cls0 cl ent. + have -> : Clauses.union s cls0 =_clset cls0. + { clsets. } + by []. + - move=> s0 s1 ih x hin hadd s2 cl ent. + have s0ent : s2 ⊢ℋ s0. + { move=> cl' hin'. apply ent, hadd. now right. } + specialize (ih s2 cl s0ent). + rewrite ClausesProp.Add_Equal in hadd. + rewrite hadd in ent. do 2 red in ent. + rewrite hadd ClausesProp.add_union_singleton ClausesProp.union_assoc -ClausesProp.add_union_singleton. + move: (ent x) => /fwd. now apply Clauses.add_spec. + move=> entx. destruct x as [prems concl]. + eapply (entails_clauses_subset _ (Clauses.union s0 s2)) in entx. + 2:{ clsets. } + move=> ent'. apply ih. + eapply entails_cut; tea. + Qed. + + Lemma entails_clauses_cut {cls cls0 cls1} : + cls ⊢ℋ cls0 -> + Clauses.union cls0 cls ⊢ℋ cls1 -> + cls ⊢ℋ cls1. + Proof. + move=> ent ent' cl /ent' hin. + eapply entails_clauses_cut_one; tea. + Qed. + + Lemma entails_L_cut {Γ r r'} : + Γ ⊢ℒ r -> + r :: Γ ⊢ℒ r' -> + Γ ⊢ℒ r'. + Proof. + destruct r as [l r], r' as [l' r']. + move/completeness_eq => h1. + move/completeness_eq => h2. + apply completeness_eq. + rewrite clauses_of_relations_cons in h2. + eapply entails_clauses_cut; tea. + Qed. + + Parameter ϕ : nat -> rel. Parameter ϕ_exists : forall r, exists n, ϕ n = r. Parameter ϕ_inj : forall n n', ϕ n = ϕ n' -> n = n'. + Definition neg_r p e := + p ⊢ℒ add_prems 1 e.1 ≤ e.2 \/ p ⊢ℒ add_prems 1 e.2 ≤ e.1. + + (* Definition consistent (r : rels) := + ~ (exists e, r ⊢ℒ e /\ neg_r r e). + + Definition satisfiable (r : rels) := + exists v, interp_cstrs v r. + + Definition satisfiable_consistent {p} : + satisfiable p -> consistent p. + Proof. + move=> [v it] [[l r] [hx [hnl|hnl]]]; + eapply presentation_entails_valid_eq in hx; + eapply presentation_entails_valid_le in hnl; + move: (hx _ it); move: (hnl _ it); cbn; + rewrite !interp_add_prems; lia. + Qed. *) + + (* Definition consistent' (Γ : rels) := + exists r, ~ (Γ ⊢ℒ r). *) + + Definition consistent Γ := + ~ exists e, Γ ⊢ℒ e ≡ add_prems 1 e. + Inductive 𝒮 (r : rels) : rels -> nat -> Prop := - | S_0 Γ a : List.incl Γ r -> ~ consistent (a :: Γ) -> 𝒮 r (a :: Γ) 0 - | S_incl Γ n : 𝒮 r Γ n -> 𝒮 r Γ (S n) + | S_0 Γ : List.incl Γ r -> 𝒮 r Γ 0 + | S_incl Γ n : 𝒮 r Γ n -> + (* ~ consistent (ϕ n :: Γ) -> *) + 𝒮 r Γ (S n) | S_phi Γ n : 𝒮 r Γ n -> consistent (ϕ n :: Γ) -> 𝒮 r (ϕ n :: Γ) (S n). - Definition 𝒮ω r rs := exists n Γ sn, 𝒮 rs sn n /\ sn ⊢ℒ r. + Definition 𝒮ω rs (Γ : rels) := exists (n: nat), 𝒮 rs Γ n. + + Definition in𝒮ω rs r := exists (n: nat) Γ, 𝒮 rs Γ n /\ Γ ⊢ℒ r. + + (* /\ Γ ⊢ℒ r *) + + Definition maximally_consistent (Γ : rels) := + consistent Γ /\ forall r, (~ consistent (r :: Γ) \/ Γ ⊢ℒ r). + + Definition satisfiable (r : rels) := + exists v, interp_cstrs v r. + + Lemma consistent_satisfiable Γ : + satisfiable Γ -> consistent Γ. + Proof. + move=> [v sat] [e]. + move/presentation_entails_valid_rel/(_ v sat). cbn. + rewrite interp_add_prems. lia. + Qed. + + Section MaximallyConsistent. + + Lemma 𝒮ω_consistent_maximal Γ Γ' n : consistent Γ -> 𝒮 Γ Γ' n -> consistent Γ'. + (* /\ (consistent' (ϕ n :: Γ') \/ Γ' ⊢ℒ ϕ n). *) + Proof. + move=> con sprf. induction sprf. + - intros [e pe]. apply con. exists e. + eapply entails_L_rels_subset; tea. + - exact IHsprf. + - intros [e neq]. + destruct H. now exists e. + Qed. + + Definition 𝒮ω_exists rs (crs : consistent rs) n : exists Γ, 𝒮 rs Γ n. + Proof. + induction n. + - exists rs. by constructor. + - destruct IHn as [Γ' sn]. + destruct (check_pres_clause_spec Γ' (ϕ n)). + * exists (ϕ n :: Γ'). apply S_phi => //. + intros [e he]. apply 𝒮ω_consistent_maximal in sn => //. + eapply entails_L_cut in H; tea. + apply sn. now exists e. + * exists Γ'. apply S_incl => //. + Qed. + + Definition inSw rs r := exists n Γ, 𝒮 rs Γ n /\ Γ ⊢ℒ r. + + Import Semilattice. + Import SemilatticeInterp. + + Lemma axiom_inSw {rs r} : rs ⊢ℒ r -> inSw rs r. + Proof. + intros hs. exists 0, rs; split. constructor. red; auto. + exact: hs. + Qed. + + Section M0. + Context (rs : rels). + + Equations? M0 : semilattice := + M0 := + {| carrier := NES.t; + eq x y := inSw rs (x, y); + add := add_prems; + join := univ_union |}. + Proof. + all:intros. 1-4:apply axiom_inSw. + - eapply entails_assoc. + - eapply entails_comm. + - eapply entails_idem. + - eapply entails_sub. + - destruct H as [n [Γ [insw ent]]]. + exists n, Γ. split => //. + now eapply (@entails_succ_inj _ _ _ 1%Z). + - apply axiom_inSw. apply entails_succ_join. + Qed. + End M0. + + Definition valid (s : semilattice) v r := + interp_rel s v r. + + Definition ids := (fun l : Level.t => singleton (l, 0%Z)). + + Lemma interp_triv rs l : interp_prems_s (M0 rs) ids l = l. + Proof. + move: l; apply: elim. + - intros [l k]. + * rewrite /interp_prems_s; cbn. + induction k; cbn; auto. + destruct p. + rewrite /add. + rewrite /interp_expr. + + Qed. + + Lemma syntax_model rs r : valid (M0 rs) ids r <-> inSw rs r. + Proof. + rewrite /valid. + destruct r as [l r]. cbn. + + + Qed. + +(* + Lemma 𝒮ω_maximal Γ (conΓ : consistent Γ) Γ' : 𝒮ω Γ Γ' -> maximally_consistent Γ'. + Proof. + intros [n sw]; red. + eapply 𝒮ω_consistent_maximal in sw. split => //. + move=> r. destruct (check_pres_clause_spec Γ' r). + now right. left. intros con. [e he]. + Qed. *) + +(* Section S. Context (p : rels). @@ -2075,22 +2506,40 @@ Qed. *) - apply IHC. red in con. red. intros [x hnc]. apply con. exists x. admit. Admitted. +*) + + Class Decidable (A : Prop) := dec : A \/ ~ A. + Instance dec_entails_L {p s t} : Decidable (p ⊢ℒ s ≡ t). + Proof. + red. eapply check_pres_clause_spec. + Qed. + Lemma contra_prop A B (dec : Decidable B) : (~ B -> ~ A) -> (A -> B). + Proof. intros he a. destruct (dec B). exact H. specialize (he H). contradiction. Qed. + + + Lemma not_provable_neg p l r : ~ (p ⊢ℒ l ≡ r) -> neg_r p l r. + Proof. + intros np. red. + Admitted. - *) -From Stdlib Require Import Logic.Classical. - Lemma contra_prop A B : (~ B -> ~ A) -> (A -> B). - Proof. intros he a. destruct (classic B). exact H. specialize (he H). contradiction. Qed. Lemma entails_L_completeness {p l r} : - (forall v, interp_cstrs v p.(C) -> interp_prems v l = interp_prems v r) -> + (forall v, interp_cstrs v p -> interp_prems v l = interp_prems v r) -> p ⊢ℒ l ≡ r. Proof. - apply contra - intros hv. + apply contra_prop. + apply dec_entails_L. + intros np hv. + apply not_provable_neg in np. destruct np. + have hp := @presentation_entails_satisfies p . + move/presentation_entails_valid_le: H. + rewrite /valid_constraint. cbn. + Qed. + Lemma satisfies_entails_presentation {m c} : check m c = false <-> exists v, interp_univ_cstrs v (constraints m) -> invalid_cstr v c. diff --git a/template-rocq/theories/SemiLattice.v b/template-rocq/theories/SemiLattice.v deleted file mode 100644 index 88c8e5343..000000000 --- a/template-rocq/theories/SemiLattice.v +++ /dev/null @@ -1,45 +0,0 @@ -(* Distributed under the terms of the MIT license. *) -From Stdlib Require Import ssreflect ssrbool ZArith. -From Stdlib Require Import Program RelationClasses Morphisms. -From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils NonEmptyLevelExprSet. - -From MetaRocq.Common Require Universes HornClauses. -From Equations Require Import Equations. -Set Equations Transparent. - -End Completeness. - -Section Presentation. - - Definition term (V : Type) : Type := list (V * nat). - Definition relation (V : Type) := term V -> term V -> Prop. - - Record presented (V : Type) := { - terms : term V -> Prop; - relations : relation V }. - - Definition valid (V : Type) (C : presented V) (t u : term V) := relations _ C t u. - - Section Terms. - Context (V : Type) (pres : presented V). - Definition succV (t : term V) := map (fun '(x, n) => (x, S n)) t. - Definition maxV (t u : term V) := t ++ u. - - Definition presents : semilattice. - Proof. - unshelve refine {| carrier := term V; eq := relations _ pres; succ := succV; join := maxV |}. - (* - intros x y z. *) - all:apply (todo "laws"). - Defined. - - Definition interp_exp (vn : V * nat) : presents := let '(v, n) := vn in [(v, n)]. - Definition interp_term (t : term V) : presents := - match t with - | [] => [] - | hd :: tl => List.fold_left (fun n x => maxV n (interp_exp x)) tl (interp_exp hd) - end. - - Lemma all_terms (x : s) : exists t : term, - - diff --git a/utils/_RocqProject b/utils/_RocqProject index d86f3b3f5..1d965812f 100644 --- a/utils/_RocqProject +++ b/utils/_RocqProject @@ -33,6 +33,8 @@ theories/ReflectEq.v theories/monad_utils.v theories/Show.v theories/utils.v +theories/MRClasses.v +theories/SemiLattice.v theories/NonEmptyLevelExprSet.v diff --git a/utils/theories/MRClasses.v b/utils/theories/MRClasses.v new file mode 100644 index 000000000..43032d84c --- /dev/null +++ b/utils/theories/MRClasses.v @@ -0,0 +1,13 @@ + +Class Neutral {A} (f : A -> A -> A) (z : A) := neutral x : f z x = x. + +Class Commutative {A} (f : A -> A -> A) := comm : forall x y, f x y = f y x. + +Class Associative {A} (f : A -> A -> A) := assoc : forall x y z, f x (f y z) = f (f x y) z. + +Class CommutativeMonoid {A} (zero : A) (add : A -> A -> A) := + { add_assoc :: Associative add; + add_comm :: Commutative add; + add_neutral :: Neutral add zero }. + +Class Injective {A B} (f : A -> B) := inj : forall x y, f x = f y -> x = y. diff --git a/utils/theories/MRUtils.v b/utils/theories/MRUtils.v index d30b00ff8..ea3e90404 100644 --- a/utils/theories/MRUtils.v +++ b/utils/theories/MRUtils.v @@ -1,6 +1,7 @@ From Stdlib Require Import Nat ZArith Bool. From MetaRocq.Utils Require Export MRPrelude + MRClasses MRReflect All_Forall MRArith diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v index 579d5284d..a156a804f 100644 --- a/utils/theories/NonEmptyLevelExprSet.v +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -3,7 +3,7 @@ From Equations Require Import Equations. Set Equations Transparent. From Corelib Require Import ssreflect ssrfun ssrbool. From Stdlib Require Import SetoidList Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import MRPrelude ReflectEq MRString MRList. +From MetaRocq.Utils Require Import MRPrelude ReflectEq MRString MRList MRClasses. Module Type OrderedTypeWithLeibniz. Include UsualOrderedType. @@ -21,6 +21,8 @@ Module Type Quantity. Include OrderedTypeWithLeibniz. Parameter zero : t. Parameter add : t -> t -> t. + Declare Instance comm_monoid : CommutativeMonoid zero add. + Declare Instance add_inj n : Injective (add n). End Quantity. Module Type LevelExprT (Level : OrderedTypeWithLeibniz) (Q : Quantity). @@ -58,7 +60,9 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) Module LevelExprSetExtraDecide := MSetDecide.Decide LevelExprSet. Ltac lesets := LevelExprSetDecide.fsetdec. - Import LevelExprSet. + Import -(notations) LevelExprSet. + Infix "⊂_leset" := LevelExprSet.Subset (at level 90). + Infix "=_leset" := LevelExprSet.Equal (at level 90). Definition level : LevelExpr.t -> Level.t := fst. @@ -74,6 +78,8 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) Record t := { t_set :> LevelExprSet.t ; t_ne : is_empty t_set = false }. Existing Instance LevelExprSet.reflect_eq. + Existing Instance Q.comm_monoid. + Existing Instance Q.add_inj. (* We use uip on the is_empty condition *) #[export, program] Instance reflect_eq : ReflectEq t := @@ -484,4 +490,86 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) firstorder eauto. subst. firstorder. Qed. + Definition add_expr n '((l, k) : LevelExpr.t) := (l, Q.add n k). + + Lemma add_expr_add_expr n n' lk : add_expr n (add_expr n' lk) = add_expr (Q.add n n') lk. + Proof. destruct lk; unfold add_expr. f_equal. symmetry. now rewrite (MRClasses.assoc (f:=Q.add)). Qed. + Definition add_prems n s := map (add_expr n) s. + + Lemma In_add_prems k (prems : t): + forall le, LevelExprSet.In le (add_prems k prems) <-> + exists le', LevelExprSet.In le' prems /\ le = add_expr k le'. + Proof. + intros [l k']. + now rewrite /add_prems map_spec. + Qed. + + Lemma add_expr_inj {n e e'} : add_expr n e = add_expr n e' -> e = e'. + Proof. + destruct e, e'; cbn; rewrite /add_expr. + move=> [=] ->. + now move/(inj (f:=Q.add n)) => ->. + Qed. + + Lemma add_prems_inj n prems prems' : add_prems n prems = add_prems n prems' -> prems = prems'. + Proof. + rewrite /add_prems => /equal_exprsets hm. + apply equal_exprsets. + intros [l k]. specialize (hm (l, Q.add n k)). + rewrite !map_spec in hm. destruct hm as [hl hr]. + split; intros hin. + - forward hl. exists (l, k); split => //. + destruct hl as [[] [hin' eq]]. + apply (@add_expr_inj n (l, k)) in eq. + now noconf eq. + - forward hr. exists (l, k); split => //. + destruct hr as [[] [hin' eq]]. + apply (@add_expr_inj n (l, k)) in eq. now noconf eq. + Qed. + + Lemma inj_add_prems_sub {n u u'} : add_prems n u ⊂_leset add_prems n u' -> u ⊂_leset u'. + Proof. + rewrite /add_prems. + intros hm [l k]. specialize (hm (l, Q.add n k)). + rewrite !map_spec in hm. + intros hin. + forward hm. exists (l, k); split => //. + destruct hm as [[] [hin' eq]]. + apply (@add_expr_inj n (l, k)) in eq. now noconf eq. + Qed. + + Lemma add_prems_add_prems n n' lk : add_prems n (add_prems n' lk) = add_prems (Q.add n n') lk. + Proof. destruct lk; unfold add_prems. + rewrite map_map. apply equal_exprsets. + intros x. rewrite !map_spec. cbn in *. + firstorder eauto. subst. exists x0. + firstorder eauto. now rewrite add_expr_add_expr. + subst. exists x0. + firstorder eauto. now rewrite add_expr_add_expr. + Qed. + + Lemma add_prems_add {n lk prems} : add_prems n (add lk prems) = add (add_expr n lk) (add_prems n prems). + Proof. + apply equal_exprsets. intros x. + rewrite In_add_prems LevelExprSet.add_spec In_add_prems /LevelExprSet.E.eq; + setoid_rewrite LevelExprSet.add_spec. + firstorder. subst. red in H; subst x0. now left. + Qed. + + Lemma add_expr_0 e : add_expr Q.zero e = e. + Proof. + destruct e => //=. now rewrite neutral. + Qed. + + Lemma add_prems_0 u : add_prems Q.zero u = u. + Proof. + rewrite /add_prems. + apply equal_exprsets. + intros x. rewrite map_spec. + split. + - intros[e [hin ->]]. now rewrite add_expr_0. + - intros inu; exists x. split => //. now rewrite add_expr_0. + Qed. + + End NonEmptyLevelExprSet. diff --git a/utils/theories/SemiLattice.v b/utils/theories/SemiLattice.v new file mode 100644 index 000000000..1a6f71adf --- /dev/null +++ b/utils/theories/SemiLattice.v @@ -0,0 +1,120 @@ +(* Distributed under the terms of the MIT license. *) +From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils NonEmptyLevelExprSet. + +Module Semilattice. + Declare Scope sl_scope. + Open Scope sl_scope. + + Reserved Notation "x ≡ y" (at level 90). + Class Semilattice (carrier : Type) := + { eq : carrier -> carrier -> Prop where "x ≡ y" := (eq x y) : sl_scope; + eq_equiv :: Equivalence eq; + add : Z -> carrier -> carrier; + join : carrier -> carrier -> carrier; + add_distr n m x : add n (add m x) ≡ add (n + m) x; + add_neutral x : add 0 x ≡ x; + join_assoc x y z : join (join x y) z ≡ join x (join y z); + join_comm x y : join x y ≡ join y x; + join_congr x x' y : x ≡ x' -> join x y ≡ join x' y; + join_idem x : join x x ≡ x; + join_sub x : join x (add 1 x) ≡ add 1 x; + succ_inj : forall n x y, add n x ≡ add n y -> x ≡ y; + succ_join : forall n x y, add n (join x y) ≡ join (add n x) (add n y); + }. + + Notation "x ≡ y" := (eq x y) (at level 90) : sl_scope. + + Definition le {A} {SL : Semilattice A} (x y : A) := join x y ≡ y. + + Infix "≤" := le (at level 50) : sl_scope. + Infix "∨" := join (at level 30) : sl_scope. + + Local Open Scope nat_scope. + Section Derived. + Context {A : Type} {SL : Semilattice A}. + + Lemma join_congr_r x y y' : y ≡ y' -> join x y ≡ join x y'. + Proof. + intros he; etransitivity. apply join_comm. + etransitivity. 2:apply join_comm. now apply join_congr. + Qed. + + #[export] Instance proper_join : Proper (eq ==> eq ==> eq) join. + Proof. intros x y ? x0 y0 ?. transitivity (join y x0). + now apply join_congr. now apply join_congr_r. + Qed. + + Lemma le_refl x : x ≤ x. + Proof. apply join_idem. Qed. + Lemma le_trans x y z : x ≤ y -> y ≤ z -> x ≤ z. + Proof. + unfold le; intros le le'. now rewrite -le' -join_assoc le. + Qed. + #[export] Instance le_preorder : PreOrder le. + Proof. + split. + - intros ?; apply le_refl. + - intros ? ? ?. apply le_trans. + Qed. + + Lemma eq_antisym {x y} : x ≡ y <-> x ≤ y /\ y ≤ x. + Proof. + split. + - intros he. split. + red. rewrite -he. apply join_idem. + red. rewrite -he. apply join_idem. + - intros [le le']. + red in le, le'. rewrite -le. rewrite -{1}le'. + apply join_comm. + Qed. + + #[export] Instance proper_le : Proper (eq ==> eq ==> iff) le. + Proof. intros x y ? x0 y0 ?. + apply eq_antisym in H0 as []. + apply eq_antisym in H as []. + split. + - intros leq. transitivity x => //. transitivity x0 => //. + - intros le. transitivity y => //. transitivity y0 => //. + Qed. + + #[export] Instance po : PartialOrder eq le. + Proof. + split. + - intros eq; split. now rewrite eq. red. + now rewrite eq. + - intros []. red in H0. apply eq_antisym. split => //. + Qed. + + Lemma join_le_left {s t} : s ≤ s ∨ t. + Proof. + red. now rewrite -join_assoc join_idem. + Qed. + + Lemma join_le_right {s t} : t ≤ s ∨ t. + Proof. + rewrite join_comm; apply join_le_left. + Qed. + + Lemma join_le_left_eq {s t u} : + s ∨ t ≤ u <-> s ≤ u /\ t ≤ u. + Proof. + split. + - intros le; split; transitivity (s ∨ t) => //. apply join_le_left. + apply join_le_right. + - intros [le le']. red in le, le'. red. + now rewrite join_assoc le' le. + Qed. + + Lemma join_le_right_impl {s t u} : + s ≤ t \/ s ≤ u -> s ≤ t ∨ u. + Proof. + intros [le|le]; red in le; red. + now rewrite -join_assoc le. + now rewrite (join_comm t) -join_assoc le. + Qed. + + End Derived. +End Semilattice. From 0d3375b163c7cb2b8c4de206c5ec4f740061ddf9 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 22 Sep 2025 00:48:18 +0200 Subject: [PATCH 059/164] Continue refactoring --- common/theories/LoopChecking/Common.v | 119 +++++++++++++----- common/theories/LoopChecking/Deciders.v | 17 ++- common/theories/LoopChecking/HornClauses.v | 24 ++-- common/theories/LoopChecking/Interfaces.v | 3 +- common/theories/LoopChecking/Model.v | 105 +++++++++------- .../theories/LoopChecking/UnivLoopChecking.v | 101 ++++++--------- utils/theories/SemiLattice.v | 72 +++++++++-- 7 files changed, 278 insertions(+), 163 deletions(-) diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v index e5e86d80a..f36229c81 100644 --- a/common/theories/LoopChecking/Common.v +++ b/common/theories/LoopChecking/Common.v @@ -78,10 +78,55 @@ Qed. Instance nat_min_assoc : Associative Nat.min := Nat.min_assoc. Instance nat_max_assoc : Associative Nat.max := Nat.max_assoc. - Instance Zmin_assoc : Associative Z.min := Z.min_assoc. Instance Zmax_assoc : Associative Z.max := Z.max_assoc. +Instance Zadd_assoc : Associative Z.add := Z.add_assoc. +Instance Zadd_comm : Commutative Z.add := Z.add_comm. + +Instance Nadd_assoc : Associative Nat.add := Nat.add_assoc. +Instance Nadd_comm : Commutative Nat.add := Nat.add_comm. + +Import CommutativeMonoid. + +Instance Zadd_neutral : Neutral Z.add 0%Z. +Proof. red. intros. lia. Qed. + +Instance Nadd_neutral : Neutral Nat.add 0%nat. +Proof. red. intros. lia. Qed. + +Instance Zadd_comm_monoid : CommutativeMonoid 0%Z Z.add := {}. +Instance Nadd_comm_monoid : CommutativeMonoid 0%nat Nat.add := {}. + +Instance Zadd_is_comm_monoid : IsCommMonoid Z := + { zero := 0%Z; + one := 1%Z; + add := Z.add }. + +Instance Nadd_is_comm_monoid : IsCommMonoid nat := + { zero := 0%nat; + one := 1%nat; + add := Nat.add }. + + +Section ZSemiLattice. + Import Semilattice. + + Program Definition Zsemilattice : Semilattice Z Z := + {| add := Z.add; + join := Z.max; |}. + Solve Obligations with program_simpl; try lia. + + Obligation Tactic := idtac. + Next Obligation. + Proof. + intros x; unfold one, Zadd_is_comm_monoid. lia. + Qed. + +End ZSemiLattice. + +#[export] Existing Instance Zsemilattice. + Lemma fold_left_comm {A B} (f : B -> A -> B) (l : list A) (x : A) (acc : B) : (forall x y z, f (f z x) y = f (f z y) x) -> fold_left f l (f acc x) = f (fold_left f l acc) x. @@ -236,7 +281,8 @@ Qed. Section ForSemilattice. Import Semilattice. - Context {A : Type} {SL : Semilattice A}. + Import CommutativeMonoid. + Context {A : Type} {V : Type} {CM : IsCommMonoid V} {SL : Semilattice A V}. Open Scope sl_scope. Lemma fold_right_max_in {a : A} {l : list A} n : In a l -> a ≤ (fold_right join n l). @@ -267,52 +313,64 @@ Section ForSemilattice. specialize (IHl l'). forward IHl. intros. apply h. now right. - lia. + intros hle; rewrite join_le_left_eq. now split. Qed. Lemma fold_right_max_spec n l : - let fn := fold_right Z.max in - (forall x, In x (n :: l) -> x <= fn n l) /\ - (exists x, In x (n :: l) /\ fn n l = x). + let fn := fold_right join in + (forall x, In x (n :: l) -> x ≤ fn n l). Proof. induction l; cbn. - - split. intros x [] => //. now subst. - exists n. firstorder. - - cbn in IHl. destruct IHl as [h h']. - split. + - intros x [] => //. now subst. + (* exists n. firstorder. reflexivity. *) + - cbn in IHl. intros x [|[]]; subst. - * specialize (h x). forward h by auto. lia. - * lia. - * specialize (h x). forward h by auto. lia. - * destruct h' as [x []]. exists (Z.max a x). rewrite -{4}H0. split => //. - destruct H; subst. - destruct (Z.max_spec a x) as [[]|[]]; firstorder; subst. - destruct (Z.max_spec a (fold_right Z.max n l)) as [[]|[]]; firstorder; subst. rewrite H1. - auto. + * specialize (IHl x). forward IHl by auto. + now apply join_le_right_trans. + * apply join_le_left. + * specialize (IHl x). forward IHl by auto. + now apply join_le_right_trans. Qed. - Lemma fold_right_equivlist_all max n n' l l' : - equivlistA eq (n :: l) (n' :: l') -> fold_right Z.max n l = fold_right Z.max n' l'. + Lemma fold_right_equivlist_all_le n n' l l' : + equivlistA Logic.eq (n :: l) (n' :: l') -> fold_right join n l ≤ fold_right join n' l'. Proof. intros eq. - have [hla [maxl [inmaxl eqmaxl]]] := fold_right_max_spec n l. - have [hra [maxr [inmaxr eqmaxr]]] := fold_right_max_spec n' l'. - rewrite eqmaxl eqmaxr. - red in eq; setoid_rewrite InA_In_eq in eq. - apply (eq _) in inmaxl. apply hra in inmaxl. - apply eq in inmaxr. apply hla in inmaxr. lia. + have hla := fold_right_max_spec n l. + have hra := fold_right_max_spec n' l'. + red in eq. + setoid_rewrite InA_In_eq in eq. + cbn in hra. setoid_rewrite <- eq in hra. clear -hra. + move: hra; generalize (fold_right join n' l'). + clear. + induction l. + - cbn. intros a heq. apply heq. now left. + - cbn. intros a' ih. + specialize (IHl a'). forward IHl. + { cbn; intros x []. subst. eapply ih. now left. + apply ih. auto. } + specialize (ih a). forward ih. { now right; left. } + eapply join_le_left_eq; now split. + Qed. + + Lemma fold_right_equivlist_all n n' l l' : + equivlistA Logic.eq (n :: l) (n' :: l') -> fold_right join n l ≡ fold_right join n' l'. + Proof. + intros eq. + apply eq_antisym; split; eapply fold_right_equivlist_all_le; auto. + now symmetry. Qed. - Lemma fold_right_comm acc l : l <> [] -> fold_right Z.max acc l = Z.max acc (fold_right Z.max (List.hd acc l) (List.tl l)). + Lemma fold_right_comm acc l : l <> [] -> fold_right join acc l ≡ join acc (fold_right join (List.hd acc l) (List.tl l)). Proof. induction l in acc |- *. - intros; congruence. - - intros _. cbn. destruct l; cbn. lia. + - intros _. cbn. destruct l; cbn. apply join_comm. cbn in IHl. rewrite (IHl acc). congruence. - rewrite (IHl a). congruence. lia. + rewrite (IHl a). congruence. + now rewrite -!join_assoc (join_comm a). Qed. - End ForSemilattice. Lemma fold_left_map {A B C} (f : B -> A -> A) (g : C -> B) l acc : @@ -387,6 +445,7 @@ Proof. unfold flip. now rewrite hf. Qed. +Local Open Scope Z_scope. Lemma nleq_optZ k k' : ~ k ≤ Some k' -> exists z, k = Some z /\ k' < z. Proof. destruct k. diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 060d448ad..444d5f2a1 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -2,7 +2,7 @@ From Stdlib Require Import ssreflect ssrfun ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils. +From MetaRocq.Utils Require Import utils MRClasses SemiLattice. From MetaRocq.Common Require UnivConstraintType Universes. From Equations Require Import Equations. @@ -134,6 +134,7 @@ Definition infer_correctness cls := | None => ~ exists v, clauses_sem v cls end. +Import Semilattice. Lemma infer_correct cls : infer_correctness cls. Proof. unfold infer_correctness. @@ -160,8 +161,11 @@ Proof. funelim (infer_model cls) => //. intros _. red in islooping. have sem := clauses_sem_entails_all islooping v0. - specialize (sem clssem). - rewrite interp_add_prems in sem. lia. + specialize (sem clssem). red in sem. + rewrite interp_add_prems in sem. + cbn [add Zsemilattice] in sem. + cbn [join Zadd_is_comm_monoid Zsemilattice] in sem. + Opaque Z.add. cbn in sem. lia. Transparent Z.add. Qed. Program Definition loop_check cls (cl : clause) : result (premises_model (clauses_levels cls) cl).1 LevelSet.empty cls (premises_model (clauses_levels cls) cl).2 := @@ -253,7 +257,7 @@ Lemma check_looping {cls cl v isl} : check cls cl = IsLooping v isl -> ~ (exists V, clauses_sem V cls). Proof. move/check_entails_looping/clauses_sem_entails_all => h [] V /h. - rewrite interp_add_prems. lia. + rewrite interp_add_prems. cbn -[Z.add]. lia. Qed. Lemma check_valid_looping {cls cl v isl m} : @@ -684,7 +688,8 @@ Module Abstract. intros [= <-]. clear -u. intros [V cs]. destruct u as [u loop]. eapply clauses_sem_entails_all in loop; tea. - now rewrite interp_add_prems in loop. + rewrite interp_add_prems in loop. + cbn -[Z.add] in loop. lia. Qed. Definition check_clauses m cls := @@ -824,7 +829,7 @@ Module LoopChecking (LS : LevelSets). that make the enforced clauses valid. *) Definition valuation m := Model.valuation_of_model m.(Impl.Abstract.model).(Impl.CorrectModel.model_valid).(model_model). - Definition model_valuation m : clauses_sem (to_val (valuation m)) (clauses m). + Definition model_valuation m : clauses_sem (to_Z_val (to_val (valuation m))) (clauses m). Proof. destruct m as [levels clauses []]; cbn. apply valid_clauses_model; tea; cbn. diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 830a94e21..fe7f9a7f3 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -79,7 +79,7 @@ From Stdlib Require Import ssreflect ssrfun ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils. +From MetaRocq.Utils Require Import utils SemiLattice. From MetaRocq.Common Require Universes. From MetaRocq.Common Require Import Common Interfaces. @@ -1620,11 +1620,15 @@ Module Clauses (LS : LevelSets). Definition clauses_of_eq (u v : NES.t) := Clauses.union (clauses_of_le u v) (clauses_of_le v u). - Notation " cls '⊢ℋ' cls' " := (entails_clauses cls cls') (at level 70). (* \mscrH *) - Notation " s ⋞ t " := (clauses_of_le s t) (at level 60). (* \curlyeqprec *) - Notation " s ≡ t " := (clauses_of_eq s t) (at level 60). (* \allequal *) + Declare Scope clauses_scope. + Delimit Scope clauses_scope with cls. + Bind Scope clauses_scope with Clauses.t. - Definition le (t u : NES.t) := t ∨ u ≡ u. + Notation " s ⋞ t " := (clauses_of_le s t) (at level 70) : clauses_scope. (* \curlyeqprec *) + Notation " s ≡ t " := (clauses_of_eq s t) (at level 70) : clauses_scope. (* \allequal *) + Notation " cls '⊢ℋ' cls' " := (entails_clauses cls cls') (at level 72). (* \mscrH *) + + Definition le (t u : NES.t) : Clauses.t := t ∨ u ≡ u. Module Theory. @@ -1827,10 +1831,11 @@ Module Clauses (LS : LevelSets). Section prems_semi. Obligation Tactic := idtac. + Import CommutativeMonoid. Import Semilattice (Semilattice, eq, add, join). Context (cls : Clauses.t). - Equations? horn_semi : Semilattice NES.t := + Equations? horn_semi : Semilattice NES.t Z := horn_semi := {| eq x y := cls ⊢ℋ x ≡ y; add := add_prems; @@ -1842,6 +1847,7 @@ Module Clauses (LS : LevelSets). * intros x y. apply Theory.eq_sym. * intros x y z. apply Theory.eq_trans. - rewrite add_prems_add_prems. apply Theory.eq_refl. + - now apply Theory.succ_congr. - now rewrite add_prems_0; apply Theory.eq_refl. - cbn. apply Theory.join_assoc. - apply Theory.join_comm. @@ -1855,9 +1861,9 @@ Module Clauses (LS : LevelSets). Import Semilattice. Section Morphism. - Context (A B : Type). - Context (s : Semilattice A). - Context (s' : Semilattice B). + Context (A B incr : Type). + Context `(s : Semilattice A incr). + Context `(s' : Semilattice B incr). Context (f : A -> B). Class respects := { of_succ n (x : A) : f (add n x) = add n (f x); diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 2f0ad9536..fb629ca5a 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -47,8 +47,7 @@ End FMapOTInterface. Module Q <: Quantity. Include OrdersEx.Z_as_OT. - Program Instance comm_monoid : CommutativeMonoid Z.zero Z.add. - Solve Obligations with red; tc; program_simpl; lia. + Instance comm_monoid : CommutativeMonoid Z.zero Z.add := _. Program Instance add_inj z : Injective (Z.add z). Next Obligation. lia. Qed. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 81cd30686..8e30799ce 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -69,7 +69,7 @@ From Stdlib Require Import ssreflect ssrbool ssrfun ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils. +From MetaRocq.Utils Require Import utils SemiLattice. From MetaRocq.Common Require Universes. From MetaRocq.Common Require Import Common Interfaces HornClauses. @@ -2946,24 +2946,24 @@ Lemma is_update_of_empty cls m : Section Semantics. Import Semilattice. Section Interpretation. - Context {A : Type} {s : Semilattice A}. + Context {A : Type} {s : Semilattice A Z}. Context (V : Level.t -> A). - Definition interp_expr '(l, k) := (add k (V l))%Z. + Definition interp_expr '(l, k) := add k (V l). Definition interp_prems prems := let '(hd, tl) := to_nonempty_list prems in fold_right (fun lk acc => join (interp_expr lk) acc) (interp_expr hd) tl. Definition clause_sem (cl : clause) : Prop := let '(prems, concl) := cl in - le (interp_prems prems) (interp_expr concl). + le (interp_expr concl) (interp_prems prems). Definition clauses_sem (cls : clauses) : Prop := Clauses.For_all clause_sem cls. End Interpretation. Section OfSL. - Context {A} {SL : Semilattice A}. + Context {A} {SL : Semilattice A Z}. Declare Scope sl_scope. Infix "≤" := le : sl_scope. Infix "≡" := eq : sl_scope. @@ -3023,7 +3023,7 @@ Lemma is_update_of_empty cls m : Lemma fold_right_interp {V : Level.t -> A} {x l x' l'} : equivlistA Logic.eq (x :: l) (x' :: l') -> - fold_right join (interp_expr V x) (List.map (interp_expr V) l) = fold_right join (interp_expr V x') (List.map (interp_expr V) l'). + fold_right join (interp_expr V x) (List.map (interp_expr V) l) ≡ fold_right join (interp_expr V x') (List.map (interp_expr V) l'). Proof. intros eq. apply fold_right_equivlist_all. intros a. rewrite !InA_In_eq. @@ -3037,7 +3037,7 @@ Lemma is_update_of_empty cls m : Qed. Lemma equivlistA_add le u : let l := to_nonempty_list (NES.add le u) in - equivlistA eq (l.1 :: l.2) (le :: LevelExprSet.elements u). + equivlistA Logic.eq (l.1 :: l.2) (le :: LevelExprSet.elements u). Proof. have he := to_nonempty_list_spec (NES.add le u). destruct to_nonempty_list. cbn. @@ -3051,59 +3051,69 @@ Lemma is_update_of_empty cls m : Qed. Lemma interp_prems_add V le (u : premises) : - interp_prems V (NES.add le u) = Z.max (interp_expr V le) (interp_prems V u). + interp_prems V (NES.add le u) ≡ join (interp_expr V le) (interp_prems V u). Proof. rewrite 2!interp_prems_elements. erewrite fold_right_interp. 2:apply equivlistA_add. rewrite fold_right_comm. { apply map_nil, elements_not_empty. } - f_equal. eapply fold_right_equivlist_all. + apply join_congr_r. eapply fold_right_equivlist_all. have he := to_nonempty_list_spec u. destruct to_nonempty_list. rewrite -he //=. Qed. - Lemma interp_prems_elim (P : premises -> Z -> Prop) V : + Lemma interp_prems_elim (P : premises -> A -> Prop) V : + Proper (Logic.eq ==> eq ==> iff) P -> (forall le, P (NES.singleton le) (interp_expr V le)) -> - (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (NES.add le u) (Z.max (interp_expr V le) k)) -> + (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (NES.add le u) (join (interp_expr V le) k)) -> forall u, P u (interp_prems V u). Proof. - intros hs hadd. + intros prop hs hadd. eapply elim. - intros le. rewrite interp_prems_singleton. apply hs. - intros le prems ih hnin. rewrite interp_prems_add. now apply hadd. Qed. - Local Open Scope Z_scope. - Lemma interp_add_prems V n e : interp_prems V (add_prems n e) = n + interp_prems V e. + Lemma interp_add_prems V n e : interp_prems V (add_prems n e) ≡ add n (interp_prems V e). Proof. revert e. - refine (interp_prems_elim (fun u z => interp_prems V (add_prems n u) = n + z) _ _ _). + refine (interp_prems_elim (fun u z => interp_prems V (add_prems n u) ≡ add n z) _ _ _ _). + - intros p p' eq a a' eq'. + subst p'. now rewrite eq'. - intros le. rewrite add_prems_singleton interp_prems_singleton //=. - destruct le; cbn. lia. + destruct le; cbn. now rewrite add_distr. - intros le u k heq hnin. rewrite add_prems_add. - rewrite interp_prems_add heq interp_add_expr. lia. + rewrite interp_prems_add heq interp_add_expr. + now rewrite add_join. Qed. - - Lemma interp_prems_in {V le} {u : premises} : LevelExprSet.In le u -> interp_prems V u >= interp_expr V le. + Lemma interp_prems_in {V le} {u : premises} : + LevelExprSet.In le u -> interp_expr V le ≤ interp_prems V u. Proof. revert u. - refine (interp_prems_elim (fun u z => LevelExprSet.In le u -> z >= interp_expr V le) V _ _). + refine (interp_prems_elim (fun u z => LevelExprSet.In le u -> interp_expr V le ≤ z) V _ _ _). + - intros ? ? <- x y eq. now rewrite eq. - intros le' u'. - apply LevelExprSet.singleton_spec in u'. red in u'; subst. lia. - - move=> le' u z hz hnin /LevelExprSet.add_spec [->|hin]. lia. - specialize (hz hin). lia. + apply LevelExprSet.singleton_spec in u'. red in u'; subst. + reflexivity. + - move=> le' u z hz hnin /LevelExprSet.add_spec [->|hin]. + * apply join_le_left. + * specialize (hz hin). + now apply join_le_right_trans. Qed. Lemma clauses_sem_subset {u u' : premises} : u ⊂_leset u' -> - forall V, interp_prems V u' >= interp_prems V u. + forall V, interp_prems V u ≤ interp_prems V u'. Proof. intros hsub V. revert u u' hsub. - refine (interp_prems_elim (fun u z => forall u' : premises, u ⊂_leset u' -> interp_prems V u' >= z) V _ _). + refine (interp_prems_elim (fun u z => forall u' : premises, u ⊂_leset u' -> + z ≤ interp_prems V u') V _ _ _). + - intros ?? <- ? ? eq. + now setoid_rewrite eq. - intros le u' hsing. specialize (hsing le). forward hsing by now apply LevelExprSet.singleton_spec. now apply interp_prems_in. @@ -3112,10 +3122,10 @@ Lemma is_update_of_empty cls m : specialize (ih u'). forward ih. intros x hin'. apply sub. now apply LevelExprSet.add_spec; right. forward hle by now apply LevelExprSet.add_spec; left. - have hi := interp_prems_in (V := V) hle. lia. + have hi := interp_prems_in (V := V) hle. + apply join_le_left_eq. split => //. Qed. - End OfSL. End Semantics. @@ -3125,7 +3135,6 @@ Lemma is_update_of_empty cls m : Definition enabled_clauses (m : model) (cls : clauses) := Clauses.For_all (enabled_clause m) cls. - Import Semilattice. Definition to_val (v : LevelMap.t nat) l := @@ -3134,9 +3143,11 @@ Lemma is_update_of_empty cls m : | None => 0%nat end. + Definition to_Z_val (v : Level.t -> nat) := fun l => Z.of_nat (v l). + (* Interprest in a nat semilattice only *) - Definition correct_model {SL : Semilattice nat} (cls : clauses) (m : model) := - enabled_clauses m cls /\ clauses_sem (to_val (valuation_of_model m)) cls. + Definition correct_model {SL : Semilattice Z Z} (cls : clauses) (m : model) := + enabled_clauses m cls /\ clauses_sem (to_Z_val (to_val (valuation_of_model m))) cls. Lemma enabled_clause_ext {m m' cl} : m ⩽ m' -> enabled_clause m cl -> enabled_clause m' cl. @@ -3156,7 +3167,7 @@ Lemma is_update_of_empty cls m : now apply enabled_clause_ext. Qed. - Lemma in_pred_closure_entails cls cl : + Lemma in_pred_closure_entails {A} {SL : Semilattice A Z} cls cl : in_pred_closure cls cl -> (forall V, clauses_sem V cls -> clause_sem V cl). Proof. @@ -3167,23 +3178,25 @@ Lemma is_update_of_empty cls m : destruct cl as [prems concl]. cbn. rewrite interp_add_prems. destruct concl as [concl conclk]. - rewrite /add_expr; cbn. lia. + rewrite /add_expr; cbn. + rewrite -add_distr => le. now apply (le_add (n:=n)) in le. - intros V clsm. cbn. rewrite interp_prems_singleton. - cbn. lia. + cbn. red. rewrite -!add_distr. rewrite -add_join. + now rewrite join_sub. Qed. (** Enabled and valid clauses are satisfied by valuation *) Lemma valid_clause_model model cl : enabled_clause model cl -> valid_clause model cl -> - clause_sem (to_val (valuation_of_model model)) cl. + clause_sem (to_Z_val (to_val (valuation_of_model model))) cl. Proof. unfold enabled_clause, valid_clause. destruct min_premise eqn:hmin => //= => //. 2:{ intros [k' eq]. congruence. } intros [k' eq]. noconf eq. - destruct cl as [prems [concl k]]; cbn. + destruct cl as [prems [concl k]]. cbn -[le]. unfold level_value_above. destruct level_value eqn:hl => //. unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. @@ -3196,8 +3209,7 @@ Lemma is_update_of_empty cls m : subst v. pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. rewrite hmin in premeq. - eapply Z.le_ge. - eapply Z.le_trans. 2:{ eapply interp_prems_ge; tea. } + eapply transitivity. 2:{ eapply interp_prems_ge; tea. } unfold interp_expr. destruct prem as [prem k']. symmetry in premeq. move: premeq. unfold min_atom_value. @@ -3218,14 +3230,14 @@ Lemma is_update_of_empty cls m : { eapply model_min_spec; tea. } assert (0 <= model_max model)%Z by apply model_max_spec2. assert (model_min model <= 0)%Z by apply model_min_spec2. - rewrite /to_val premm conclm. - lia. + rewrite /to_Z_val /to_val premm conclm. + cbn. lia. Qed. Lemma valid_clauses_model model cls : enabled_clauses model cls -> is_model cls model -> - clauses_sem (to_val (valuation_of_model model)) cls. + clauses_sem (to_Z_val (to_val (valuation_of_model model))) cls. Proof. move=> en ism cl hin. apply valid_clause_model. @@ -3262,8 +3274,8 @@ Lemma is_update_of_empty cls m : induction 1. - intros v clls. red. destruct concl0 as [concl k]. - have hge := interp_prems_ge v prems _ H. - by lia. + have hge := interp_prems_ge (SL := Zsemilattice) v prems _ H. + cbn in *. by lia. - move=> V Hcls. move: {IHentails} (IHentails _ Hcls). unfold clause_sem. unfold ge => hyp. @@ -3271,18 +3283,19 @@ Lemma is_update_of_empty cls m : rewrite interp_prems_add in hyp. eapply in_pred_closure_entails in H; tea. move: H; rewrite /clause_sem. unfold ge. - have ssub := clauses_sem_subset H1 V. lia. + have ssub := clauses_sem_subset (SL := Zsemilattice) H1 V. + cbn in *. lia. Qed. Lemma clauses_sem_entails_all {cls prems concl} : cls ⊢a prems → concl -> - (forall V, clauses_sem V cls -> interp_prems V prems >= interp_prems V concl). + (forall V, clauses_sem V cls -> interp_prems V concl ≤ interp_prems V prems). Proof. intros ha V hcls. red in ha. move: ha. revert concl. - refine (@interp_prems_elim (fun concl z => _ -> interp_prems V prems >= z) V _ _). + refine (@interp_prems_elim _ _ (fun concl z => _ -> z ≤ interp_prems V prems) V _ _ _). - move=> le //=. move/(_ le). intros h; forward h by now apply LevelExprSet.singleton_spec. now have ent := (clauses_sem_entails h _ hcls). @@ -3294,7 +3307,7 @@ Lemma is_update_of_empty cls m : forward hf by now apply LevelExprSet.add_spec; left. cbn in hf. have ent := (clauses_sem_entails hf _ hcls). cbn in ent. - lia. + cbn in *. lia. Qed. Lemma valid_clause_shift m n cl : diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v index 56ccf02ff..e2832ed9b 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -5,7 +5,7 @@ From Stdlib Require Import ssreflect ssrfun ssrbool. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils. +From MetaRocq.Utils Require Import utils SemiLattice. From MetaRocq.Common Require Import UnivConstraintType Universes. From MetaRocq.Common.LoopChecking Require Import Common Interfaces Deciders. From Equations Require Import Equations. @@ -640,9 +640,11 @@ End ZUnivConstraint. now move=> hall hsub cl /hsub. Qed. - Lemma clauses_sem_clauses_of_le V l r : + Import Semilattice. + + Lemma clauses_sem_clauses_of_le (V : Level.t -> Z) l r : clauses_sem V (clauses_of_le l r) -> - (interp_prems V l <= interp_prems V r)%Z. + (interp_prems V l ≤ interp_prems V r)%sl. Proof. rewrite /clauses_sem. intros hl. red in hl. @@ -659,7 +661,7 @@ End ZUnivConstraint. move: (ih' (r, x1)) => /fwd. exists x1. split => //. apply LevelExprSet.add_spec. now right. auto. move: (ih' (r, le)) => /fwd. exists le. split => //. apply LevelExprSet.add_spec. now left. - cbn. lia. + cbn. cbn in ih. lia. Qed. Lemma to_atoms_singleton l k : to_atoms (Universe.singleton (l, k)) = singleton (l, Z.of_nat k). @@ -668,7 +670,7 @@ End ZUnivConstraint. rewrite /to_atoms //=. Qed. - Lemma to_atoms_add le u : to_atoms (Universe.add le u) = add (to_atom le) (to_atoms u). + Lemma to_atoms_add le u : to_atoms (Universe.add le u) = NES.add (to_atom le) (to_atoms u). Proof. apply NES.equal_exprsets => //=. move=> [l k]. rewrite LevelExprSet.add_spec. @@ -693,15 +695,6 @@ End ZUnivConstraint. rewrite Universes.LevelExprSet.add_spec. now right. Qed. - Lemma interp_prem_to_atom v le : interp_expr v (to_atom le) = Z.of_nat (val (to_valuation v) le). - Proof. - destruct le => //=. cbn. - destruct t0. - - (* lzero is forced to have value 0, has it should stay maximal *) todo "handle lzero". - - todo "handle monos". - - cbn. lia. - Qed. - Lemma clauses_sem_union v cls cls' : clauses_sem v (Clauses.Clauses.union cls cls') <-> clauses_sem v cls /\ clauses_sem v cls'. Proof. @@ -711,7 +704,16 @@ End ZUnivConstraint. specialize (H cl). specialize (H0 cl). intros []; auto. Qed. - Lemma interp_prems_to_atoms v l : interp_prems v (to_atoms l) = Z.of_nat (Universes.val (to_valuation v) l). + Lemma interp_prem_to_atom v le : interp_expr (to_Z_val v) (to_atom le) = Z.of_nat (val (to_valuation v) le). + Proof. + destruct le => //=. cbn. + destruct t0. + - (* lzero is forced to have value 0, has it should stay maximal *) todo "handle lzero". + - todo "handle monos". + - cbn. unfold to_Z_val; cbn. lia. + Qed. + + Lemma interp_prems_to_atoms v l : interp_prems (to_Z_val v) (to_atoms l) = Z.of_nat (Universes.val (to_valuation v) l). Proof. move: l. apply Universe.elim. @@ -722,17 +724,18 @@ End ZUnivConstraint. - intros le x eq nin. rewrite to_atoms_add interp_prems_add. rewrite val_add. - rewrite interp_prem_to_atom. lia. + rewrite interp_prem_to_atom. cbn. lia. Qed. Lemma clauses_sem_val m l r : - clauses_sem (to_val (LoopCheck.valuation m)) (clauses_of_le (to_atoms l) (to_atoms r)) -> + clauses_sem (to_Z_val (to_val (LoopCheck.valuation m))) (clauses_of_le (to_atoms l) (to_atoms r)) -> Universes.val (to_valuation (to_val (LoopCheck.valuation m))) l <= Universes.val (to_valuation (to_val (LoopCheck.valuation m))) r. Proof. move/clauses_sem_clauses_of_le. have he := interp_prems_to_atoms (to_val (LoopCheck.valuation m)) l. - have he' := interp_prems_to_atoms (to_val (LoopCheck.valuation m)) r. lia. + have he' := interp_prems_to_atoms (to_val (LoopCheck.valuation m)) r. + cbn in *. lia. Qed. Lemma model_satisfies m : @@ -777,11 +780,12 @@ End ZUnivConstraint. Lemma interp_level_of_valuation {V v l} : LevelSet.In l V -> - to_val (of_valuation V v) l = val v l. + to_Z_val (to_val (of_valuation V v)) l = Z.of_nat (val v l). Proof. move=> hin. - rewrite /to_val. + rewrite /to_Z_val /to_val. elim: find_spec => [k /of_valuation_spec []|] => //. + { intros ? ->. reflexivity. } elim. exists (val v l). rewrite [LevelMap.Raw.MapsTo _ _ _]of_valuation_spec. split => //. Qed. @@ -803,26 +807,27 @@ End ZUnivConstraint. LevelSet.Subset (univ_constraint_levels (l, ConstraintType.Le, r)) V -> val v l <= val v r -> forall cl, LevelExprSet.Exists (fun lk : LevelExprSet.elt => cl = (to_atoms r, lk)) (to_levelexprzset l) -> - clause_sem (to_val (of_valuation V v)) cl. + clause_sem (to_Z_val (to_val (of_valuation V v))) cl. Proof. move=> hlev leq [prems concl]. move=> [] [l'' k'] [] /to_levelexprzset_spec_2 [] inl' pos ->. - cbn. rewrite interp_prems_to_atoms //=. + cbn -[le]. rewrite interp_prems_to_atoms. rewrite to_of_valuation_univ. { intros ? hin; apply hlev. cbn. lsets. } - transitivity (Z.of_nat (val v l)). lia. + transitivity (Z.of_nat (val v l)). rewrite interp_level_of_valuation. { apply hlev; cbn. eapply LevelSet.union_spec; left. eapply Universe.levels_spec. now eexists. } have vle := val_In_le l v _ inl'. cbn in vle. - by u; lia. + cbn; u; lia. + cbn; u; lia. Qed. Lemma satisfies_clauses_sem v m V : LoopCheck.levels (model m) ⊂_lset V -> satisfies v (constraints m) -> - clauses_sem (to_val (of_valuation V v)) (LoopCheck.clauses (model m)). + clauses_sem (to_Z_val (to_val (of_valuation V v))) (LoopCheck.clauses (model m)). Proof. have repr := repr_constraints_inv m. have repr_inv := repr_constraints m. @@ -854,20 +859,20 @@ End ZUnivConstraint. Lemma clauses_sem_satisfies {v V c} : univ_constraint_levels c ⊂_lset V -> - clauses_sem (to_val (of_valuation V v)) (LoopCheck.to_clauses (to_constraint c)) -> + clauses_sem (to_Z_val (to_val (of_valuation V v))) (LoopCheck.to_clauses (to_constraint c)) -> satisfies0 v c. Proof. intros hin hsem. destruct c as [[l []] r]; cbn in *. - constructor. move/clauses_sem_clauses_of_le: hsem. rewrite !interp_prems_to_atoms. - rewrite !to_of_valuation_univ. lsets. lsets. lia. + rewrite !to_of_valuation_univ. lsets. lsets. cbn; lia. - constructor. rewrite clauses_sem_union in hsem. destruct hsem as [hsem hsem']. move/clauses_sem_clauses_of_le: hsem. move/clauses_sem_clauses_of_le: hsem'. rewrite !interp_prems_to_atoms. - rewrite !to_of_valuation_univ. lsets. lsets. lia. + rewrite !to_of_valuation_univ. lsets. lsets. cbn; lia. Qed. Instance in_pred_closure_proper : Proper (Clauses.Equal ==> Logic.eq ==> impl) in_pred_closure. @@ -957,50 +962,26 @@ End ZUnivConstraint. eapply (repr_constraints m); tea. Qed. - (* Section Nat_Semilattice. - Import Semilattice. - Equations? nat_semilattice : semilattice := - nat_semilattice := - {| carrier := nat; - eq := Logic.eq; - succ x := S x; - join x y := Nat.max x y |}. - Proof. - all:lia. - Qed. - End Nat_Semilattice. *) - - Section Z_Semilattice. - Import Semilattice. - Equations? Z_semilattice : semilattice := - Z_semilattice := - {| carrier := Z; - eq := Logic.eq; - add := Z.add; - join x y := Z.max x y |}. - Proof. - all:lia. - Qed. - End Z_Semilattice. - - Lemma interp_prems_union {v x y} : interp_prems v (x ∨ y) = Z.max (interp_prems v x) (interp_prems v y). + Lemma interp_prems_union {v : Level.t -> Z} {x y : premises} : + interp_prems v (univ_union x y) = + join (interp_prems v x) (interp_prems v y). Proof. move: x; apply NES.elim. - intros []. rewrite univ_union_comm univ_union_add_singleton. now rewrite interp_prems_add interp_prems_singleton. - intros le' x ih hnin. - rewrite univ_union_add_distr !interp_prems_add ih. lia. + rewrite univ_union_add_distr !interp_prems_add ih. cbn; lia. Qed. - Lemma val_respects cls v : respects (leset_sl cls) Z_semilattice (fun u => interp_prems v u). + Lemma val_respects cls v : @respects _ _ Z _ (horn_semi cls) _ Zsemilattice (fun u => interp_prems v u). Proof. split; cbn. - - intros n x. rewrite interp_add_prems. lia. - - intros x y. rewrite interp_prems_union. lia. + - intros n x. rewrite interp_add_prems; cbn. lia. + - intros x y. rewrite interp_prems_union; cbn. lia. Qed. Definition valid_entailments cls cls' := - forall V, clauses_sem V cls -> clauses_sem V cls'. + forall A {SL : Semilattice A Z} V, clauses_sem V cls -> clauses_sem V cls'. Lemma entails_cstr_spec cstrs c : (exists V, clauses_sem V (of_z_constraints cstrs)) -> diff --git a/utils/theories/SemiLattice.v b/utils/theories/SemiLattice.v index 1a6f71adf..2c261282b 100644 --- a/utils/theories/SemiLattice.v +++ b/utils/theories/SemiLattice.v @@ -4,37 +4,60 @@ From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils NonEmptyLevelExprSet. +Module CommutativeMonoid. + Class IsCommMonoid (A : Type) := + { zero : A; + one : A; + add : A -> A -> A; + comm_mon :: CommutativeMonoid zero add }. + + Declare Scope comm_monoid. + Notation "0" := zero : comm_monoid. + Notation "1" := one : comm_monoid. + Notation "+" := add : comm_monoid. +End CommutativeMonoid. + Module Semilattice. Declare Scope sl_scope. Open Scope sl_scope. + Delimit Scope sl_scope with sl. + Import CommutativeMonoid. + Local Open Scope comm_monoid. - Reserved Notation "x ≡ y" (at level 90). - Class Semilattice (carrier : Type) := + Reserved Notation "x ≡ y" (at level 70). + Class Semilattice (carrier : Type) (incr : Type) `{CM : IsCommMonoid incr} := { eq : carrier -> carrier -> Prop where "x ≡ y" := (eq x y) : sl_scope; eq_equiv :: Equivalence eq; - add : Z -> carrier -> carrier; + add : incr -> carrier -> carrier; join : carrier -> carrier -> carrier; - add_distr n m x : add n (add m x) ≡ add (n + m) x; + add_distr n m x : add n (add m x) ≡ add (CommutativeMonoid.add n m) x; + add_congr n x y : x ≡ y -> add n x ≡ add n y; add_neutral x : add 0 x ≡ x; join_assoc x y z : join (join x y) z ≡ join x (join y z); join_comm x y : join x y ≡ join y x; join_congr x x' y : x ≡ x' -> join x y ≡ join x' y; join_idem x : join x x ≡ x; join_sub x : join x (add 1 x) ≡ add 1 x; - succ_inj : forall n x y, add n x ≡ add n y -> x ≡ y; - succ_join : forall n x y, add n (join x y) ≡ join (add n x) (add n y); + add_inj : forall n x y, add n x ≡ add n y -> x ≡ y; + add_join : forall n x y, add n (join x y) ≡ join (add n x) (add n y); }. - Notation "x ≡ y" := (eq x y) (at level 90) : sl_scope. + Notation "x ≡ y" := (eq x y) (at level 70) : sl_scope. - Definition le {A} {SL : Semilattice A} (x y : A) := join x y ≡ y. + Definition le {A incr} `{SL : Semilattice A incr} (x y : A) := join x y ≡ y. Infix "≤" := le (at level 50) : sl_scope. Infix "∨" := join (at level 30) : sl_scope. - Local Open Scope nat_scope. + Definition lt {A} `{SL : Semilattice A} (x y : A) := add 1 x ≤ y. + Infix "<" := lt (at level 70) : sl_scope. + + Class JoinDec (carrier : Type) `{SL : Semilattice carrier} := + { join_dec x y : (join x y ≡ x) \/ (join y x ≡ y) }. + + Local Open Scope sl_scope. Section Derived. - Context {A : Type} {SL : Semilattice A}. + Context {A : Type} {incr : Type} {CM : IsCommMonoid incr} {SL : Semilattice A incr}. Lemma join_congr_r x y y' : y ≡ y' -> join x y ≡ join x y'. Proof. @@ -47,6 +70,9 @@ Module Semilattice. now apply join_congr. now apply join_congr_r. Qed. + #[export] Instance proper_add : Proper (Logic.eq ==> eq ==> eq) add. + Proof. intros x y ? x0 y0 ?. subst y. now apply add_congr. Qed. + Lemma le_refl x : x ≤ x. Proof. apply join_idem. Qed. Lemma le_trans x y z : x ≤ y -> y ≤ z -> x ≤ z. @@ -93,11 +119,17 @@ Module Semilattice. red. now rewrite -join_assoc join_idem. Qed. + Lemma join_le_left_trans {s t u} : s ≤ t -> s ≤ t ∨ u. + Proof. transitivity t => //. apply join_le_left. Qed. + Lemma join_le_right {s t} : t ≤ s ∨ t. Proof. rewrite join_comm; apply join_le_left. Qed. + Lemma join_le_right_trans {s t u} : s ≤ u -> s ≤ t ∨ u. + Proof. transitivity u => //. apply join_le_right. Qed. + Lemma join_le_left_eq {s t u} : s ∨ t ≤ u <-> s ≤ u /\ t ≤ u. Proof. @@ -116,5 +148,25 @@ Module Semilattice. now rewrite (join_comm t) -join_assoc le. Qed. + Lemma join_dec_spec {JD : @JoinDec A incr CM SL} (x y : A) : + (x ≤ y /\ join x y ≡ y) \/ (y ≤ x /\ join x y ≡ x). + Proof. + destruct (join_dec x y). + - right. split => //. + red. now rewrite join_comm H. + - left. split => //. red. + rewrite join_comm H. reflexivity. + rewrite join_comm H. reflexivity. + Qed. + + Lemma le_add {n} {x y : A} : x ≤ y <-> add n x ≤ add n y. + Proof. + unfold le. + split. + - now rewrite -add_join => ->. + - rewrite -add_join => h. + now apply add_inj in h. + Qed. + End Derived. End Semilattice. From 74a867411c9437b9d68aab66c2c7dfb7b602f2f0 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 22 Sep 2025 13:01:52 +0200 Subject: [PATCH 060/164] Initiality proven for entails_L --- common/theories/LoopChecking/HornClauses.v | 48 +- common/theories/LoopChecking/Interfaces.v | 2 + oldLoopChecking.v | 48 +- .../theories/LoopChecking/UnivLoopChecking.v | 745 ++++++++++-------- utils/theories/NonEmptyLevelExprSet.v | 42 +- utils/theories/SemiLattice.v | 11 + 6 files changed, 492 insertions(+), 404 deletions(-) diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index fe7f9a7f3..9b5c775d9 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -727,7 +727,7 @@ Module Clauses (LS : LevelSets). Lemma of_level_set_union_spec {ls ls' n hne} hne' hne'' : of_level_set (ls ∪ ls') n hne = - NES.univ_union (of_level_set ls n hne') (of_level_set ls' n hne''). + NES.union (of_level_set ls n hne') (of_level_set ls' n hne''). Proof. apply NES.equal_exprsets. intros [l k]. rewrite /of_level_set //= !levelexprset_of_levels_spec LevelExprSet.union_spec. @@ -1208,26 +1208,26 @@ Module Clauses (LS : LevelSets). intros x; rewrite LevelExprSet.add_spec. firstorder. Qed. - Import NES (univ_union, univ_union_add_distr, univ_union_add_distr, univ_union_assoc, univ_union_spec, univ_union_comm, univ_union_add_singleton). + Import NES (union, union_add_distr, union_add_distr, union_assoc, union_spec, union_comm, union_add_singleton). Lemma entails_weak_union {cls prem concl concl'} : entails cls (prem, concl) -> - entails cls (NES.univ_union concl' prem, concl). + entails cls (NES.union concl' prem, concl). Proof. intros hyp. move: concl'. apply: NES.elim. - - intros le. rewrite univ_union_comm univ_union_add_singleton. + - intros le. rewrite union_comm union_add_singleton. now apply entails_weak. - intros le prems ih. - rewrite univ_union_add_distr. intros _. + rewrite union_add_distr. intros _. now eapply entails_weak. Qed. - Lemma add_prems_univ_union {n u u'} : add_prems n (univ_union u u') = univ_union (add_prems n u) (add_prems n u'). + Lemma add_prems_union {n u u'} : add_prems n (u ∪ u') = union (add_prems n u) (add_prems n u'). Proof. apply equal_exprsets => l. rewrite In_add_prems. - rw univ_union_spec. + rw union_spec. rewrite !In_add_prems. firstorder. Qed. @@ -1242,7 +1242,7 @@ Module Clauses (LS : LevelSets). Lemma entails_all_weak_union {cls prem concl concl'} : entails_all cls prem concl -> - entails_all cls (univ_union concl' prem) concl. + entails_all cls (union concl' prem) concl. Proof. intros hcl x hin. specialize (hcl _ hin). cbn in hcl. @@ -1313,7 +1313,7 @@ Module Clauses (LS : LevelSets). Lemma entails_cumul_one {cls prems prems' concl} : entails_all cls prems prems' -> - entails cls (univ_union prems prems', concl) -> + entails cls (union prems prems', concl) -> entails cls (prems, concl). Proof. revert prems' prems concl. @@ -1321,9 +1321,9 @@ Module Clauses (LS : LevelSets). - intros. specialize (H le). forward H by now apply LevelExprSet.singleton_spec. cbn in H. eapply entails_add; tea. - now rewrite -univ_union_add_singleton. + now rewrite -union_add_singleton. - intros le prems ih _ prem concl' hadd hadd'. - rewrite univ_union_comm univ_union_add_distr -univ_union_comm -univ_union_add_distr in hadd'. + rewrite union_comm union_add_distr -union_comm -union_add_distr in hadd'. eapply ih in hadd'. 2:{ apply entails_all_weak. apply entails_all_add in hadd as []. exact H0. } apply entails_all_add in hadd as []. eapply entails_add; tea. @@ -1331,7 +1331,7 @@ Module Clauses (LS : LevelSets). Lemma entails_all_cumul {cls prems prems' concl} : entails_all cls prems prems' -> - entails_all cls (univ_union prems prems') concl -> + entails_all cls (union prems prems') concl -> entails_all cls prems concl. Proof. intros hp hc. @@ -1388,25 +1388,25 @@ Module Clauses (LS : LevelSets). Qed. Lemma entails_all_concl_union {cls prems concl concl'} : - cls ⊢a prems → univ_union concl concl' <-> + cls ⊢a prems → union concl concl' <-> cls ⊢a prems → concl /\ cls ⊢a prems → concl'. Proof. split; revgoals. - move=> [] l r. rewrite /entails_all. - intros x. rewrite NES.univ_union_spec. intros []. now apply l. now apply r. + intros x. rewrite NES.union_spec. intros []. now apply l. now apply r. - intros hu; split; move=> le hin; move: (hu le) => /fwd //; - now rewrite NES.univ_union_spec. + now rewrite NES.union_spec. Qed. Lemma entails_all_union {cls prems concl prems' concl'} : cls ⊢a prems → concl -> cls ⊢a prems' → concl' -> - cls ⊢a univ_union prems prems' → univ_union concl concl'. + cls ⊢a union prems prems' → union concl concl'. Proof. move=> l r. rewrite entails_all_concl_union. split. - rewrite univ_union_comm. + rewrite union_comm. now eapply entails_all_weak_union. now eapply entails_all_weak_union. Qed. @@ -1614,7 +1614,7 @@ Module Clauses (LS : LevelSets). rewrite ih. right; firstorder. Qed. - Infix "∨" := univ_union (at level 30). + Infix "∨" := union (at level 30). Notation succ x := (add_prems 1%Z x). Definition clauses_of_eq (u v : NES.t) := @@ -1759,19 +1759,19 @@ Module Clauses (LS : LevelSets). Qed. Lemma join_comm {cls s t} : cls ⊢ℋ s ∨ t ≡ t ∨ s. - Proof. rewrite univ_union_comm; auto with entails. Qed. + Proof. rewrite union_comm; auto with entails. Qed. Lemma join_assoc {cls s t u} : cls ⊢ℋ s ∨ t ∨ u ≡ s ∨ (t ∨ u). Proof. - rewrite univ_union_assoc; auto with entails. + rewrite union_assoc; auto with entails. Qed. Lemma join_left {cls s t} : cls ⊢ℋ s ⋞ s ∨ t. Proof. eapply to_entails_all. - rewrite univ_union_comm;apply entails_all_weak_union; + rewrite union_comm;apply entails_all_weak_union; auto with entails. Qed. @@ -1803,7 +1803,7 @@ Module Clauses (LS : LevelSets). Lemma succ_join {cls n s t} : cls ⊢ℋ add_prems n (s ∨ t) ≡ add_prems n s ∨ add_prems n t. Proof. - rewrite add_prems_univ_union; auto with entails. + rewrite add_prems_union; auto with entails. Qed. Lemma join_congr_left {cls r s t} : @@ -1823,7 +1823,7 @@ Module Clauses (LS : LevelSets). cls ⊢ℋ r ∨ s ≡ r ∨ t. Proof. intros heq. - rewrite univ_union_comm [r ∨ _]univ_union_comm. + rewrite union_comm [r ∨ _]union_comm. now apply join_congr_left. Qed. @@ -1839,7 +1839,7 @@ Module Clauses (LS : LevelSets). horn_semi := {| eq x y := cls ⊢ℋ x ≡ y; add := add_prems; - join := univ_union |}. + join := union |}. Proof. all: intros. - split; red. diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index fb629ca5a..2e5352d6d 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -80,6 +80,8 @@ Module LevelSetDecide := LevelSetProp.Dec. Module LevelMapFact := FMapFacts.WProperties_fun LevelMap.OT LevelMap. Declare Scope levels_scope. +Delimit Scope levels_scope with levels. +Bind Scope levels_scope with LevelSet.t. Ltac lsets := LevelSetDecide.fsetdec. Notation "(=_lset)" := LevelSet.Equal (at level 0) : levels_scope. diff --git a/oldLoopChecking.v b/oldLoopChecking.v index b0ddf43c6..9770f3e12 100644 --- a/oldLoopChecking.v +++ b/oldLoopChecking.v @@ -444,7 +444,7 @@ Module NonEmptySetFacts. Qed. #[program] - Definition univ_union (prems prems' : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := + Definition union (prems prems' : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := {| t_set := LevelExprSet.union prems prems' |}. Next Obligation. destruct prems, prems'; cbn. @@ -454,32 +454,32 @@ Module NonEmptySetFacts. destruct t_ne0. lesets. Qed. - Lemma univ_union_spec u u' l : - LevelExprSet.In l (univ_union u u') <-> + Lemma union_spec u u' l : + LevelExprSet.In l (u ∪ u') <-> LevelExprSet.In l u \/ LevelExprSet.In l u'. Proof. - destruct u, u'; unfold univ_union; cbn. + destruct u, u'; unfold union; cbn. apply LevelExprSet.union_spec. Qed. - Lemma univ_union_add_singleton u le : univ_union u (singleton le) = add le u. + Lemma union_add_singleton u le : union u (singleton le) = add le u. Proof. apply eq_univ_equal. - intros x. rewrite univ_union_spec LevelExprSet.singleton_spec add_spec. + intros x. rewrite union_spec LevelExprSet.singleton_spec add_spec. intuition auto. Qed. - Lemma univ_union_comm {u u'} : univ_union u u' = univ_union u' u. + Lemma union_comm {u u'} : u ∪ u' = union u' u. Proof. apply eq_univ_equal. - intros x. rewrite !univ_union_spec. + intros x. rewrite !union_spec. intuition auto. Qed. - Lemma univ_union_add_distr {le u u'} : univ_union (add le u) u' = add le (univ_union u u'). + Lemma union_add_distr {le u u'} : union (add le u) u' = add le (u ∪ u'). Proof. apply eq_univ_equal. - intros x. rewrite !univ_union_spec !add_spec !univ_union_spec. + intros x. rewrite !union_spec !add_spec !union_spec. intuition auto. Qed. @@ -2885,15 +2885,15 @@ Qed. Lemma entails_weak_union {cls prem concl concl'} : entails cls (prem, concl) -> - entails cls (univ_union concl' prem, concl). + entails cls (union concl' prem, concl). Proof. intros hyp. move: concl'. apply: nonEmptyLevelExprSet_elim. - - intros le. rewrite univ_union_comm univ_union_add_singleton. + - intros le. rewrite union_comm union_add_singleton. now apply entails_weak. - intros le prems ih. - rewrite univ_union_add_distr. intros _. + rewrite union_add_distr. intros _. now eapply entails_weak. Qed. @@ -2908,7 +2908,7 @@ Qed. Lemma entails_all_weak_union {cls prem concl concl'} : entails_all cls prem concl -> - entails_all cls (univ_union concl' prem) concl. + entails_all cls (union concl' prem) concl. Proof. intros hcl x hin. specialize (hcl _ hin). cbn in hcl. @@ -2948,7 +2948,7 @@ Qed. (* Lemma entails_all_one {cls prems concl concl'} : entails_all cls prems concl -> - entails cls (univ_union concl prems, concl') -> + entails cls (union concl prems, concl') -> entails cls (prems, concl'). Proof. intros hall he; depind he. @@ -2990,7 +2990,7 @@ Qed. Lemma entails_cumul_one {cls prems prems' concl} : entails_all cls prems prems' -> - entails cls (univ_union prems prems', concl) -> + entails cls (union prems prems', concl) -> entails cls (prems, concl). Proof. revert prems' prems concl. @@ -2998,9 +2998,9 @@ Proof. - intros. specialize (H le). forward H by now apply LevelExprSet.singleton_spec. cbn in H. eapply entails_add; tea. - now rewrite -univ_union_add_singleton. + now rewrite -union_add_singleton. - intros le prems ih _ prem concl' hadd hadd'. - rewrite univ_union_comm univ_union_add_distr -univ_union_comm -univ_union_add_distr in hadd'. + rewrite union_comm union_add_distr -union_comm -union_add_distr in hadd'. eapply ih in hadd'. 2:{ apply entails_all_weak. apply entails_all_add in hadd as []. exact H0. } apply entails_all_add in hadd as []. eapply entails_add; tea. @@ -3008,7 +3008,7 @@ Qed. Lemma entails_all_cumul {cls prems prems' concl} : entails_all cls prems prems' -> - entails_all cls (univ_union prems prems') concl -> + entails_all cls (union prems prems') concl -> entails_all cls prems concl. Proof. intros hp hc. @@ -3063,21 +3063,21 @@ Qed. Lemma entails_all_concl_union {cls prems concl concl'} : cls ⊢a prems → concl -> cls ⊢a prems → concl' -> - cls ⊢a prems → univ_union concl concl'. + cls ⊢a prems → union concl concl'. Proof. intros l r. rewrite /entails_all. - intros x. rewrite univ_union_spec. intros []. now apply l. now apply r. + intros x. rewrite union_spec. intros []. now apply l. now apply r. Qed. Lemma entails_all_union {cls prems concl prems' concl'} : cls ⊢a prems → concl -> cls ⊢a prems' → concl' -> - cls ⊢a univ_union prems prems' → univ_union concl concl'. + cls ⊢a union prems prems' → union concl concl'. Proof. intros l r. apply entails_all_concl_union. - rewrite univ_union_comm. + rewrite union_comm. now eapply entails_all_weak_union. now eapply entails_all_weak_union. Qed. @@ -4903,7 +4903,7 @@ Qed. Lemma of_level_set_union_spec {ls ls' n hne} hne' hne'' : of_level_set (ls ∪ ls') n hne = - univ_union (of_level_set ls n hne') (of_level_set ls' n hne''). + union (of_level_set ls n hne') (of_level_set ls' n hne''). Proof. apply eq_univ_equal. intros [l k]. rewrite /of_level_set //= !levelexprset_of_levels_spec LevelExprSet.union_spec. diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v index e2832ed9b..1a00bb593 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -962,15 +962,16 @@ End ZUnivConstraint. eapply (repr_constraints m); tea. Qed. - Lemma interp_prems_union {v : Level.t -> Z} {x y : premises} : - interp_prems v (univ_union x y) = + Lemma interp_prems_union {S} {SL : Semilattice S Z} {v : Level.t -> S} {x y : premises} : + interp_prems v (x ∪ y) ≡ join (interp_prems v x) (interp_prems v y). Proof. move: x; apply NES.elim. - - intros []. rewrite univ_union_comm univ_union_add_singleton. + - intros []. rewrite union_comm union_add_singleton. now rewrite interp_prems_add interp_prems_singleton. - intros le' x ih hnin. - rewrite univ_union_add_distr !interp_prems_add ih. cbn; lia. + rewrite union_add_distr !interp_prems_add ih. cbn. + now rewrite join_assoc. Qed. Lemma val_respects cls v : @respects _ _ Z _ (horn_semi cls) _ Zsemilattice (fun u => interp_prems v u). @@ -997,35 +998,44 @@ End ZUnivConstraint. Import Semilattice. Definition rel := premises × premises. + + Declare Scope rel_scope. + Delimit Scope rel_scope with rel. + Bind Scope rel_scope with rel. + Open Scope rel_scope. + Definition rels := list rel. Record presentation := { V : LevelSet.t; C : list (NES.t × NES.t); }. - Definition rel_eq (x y : premises) := (x, y). - Definition rel_le (x y : premises) := (x ∨ y, y). + Infix "∨" := NES.union (at level 30) : nes_scope. + Open Scope nes_scope. - Delimit Scope rel_scope with rel. - Infix "≡" := rel_eq (at level 60, no associativity) : rel_scope. + Definition rel_eq (x y : premises) : rel := (x, y). + Definition rel_le (x y : premises) : rel := ((x ∨ y)%nes, y). + + Infix "≡" := rel_eq (at level 70, no associativity) : rel_scope. Infix "≤" := rel_le (at level 50, no associativity) : rel_scope. - Reserved Notation " p ⊢ℒ r " (at level 62, no associativity). + Reserved Notation " p ⊢ℒ r " (at level 72, no associativity). Inductive entails_L (p : rels) : NES.t × NES.t -> Prop := | entails_c {l r} : List.In (l, r) p -> p ⊢ℒ l ≡ r | entails_refl {x} : p ⊢ℒ x ≡ x | entails_sym {x y} : p ⊢ℒ x ≡ y -> p ⊢ℒ y ≡ x | entails_trans {x y z} : p ⊢ℒ x ≡ y -> p ⊢ℒ y ≡ z -> p ⊢ℒ x ≡ z - | entails_succ_congr {x y n} : p ⊢ℒ x ≡ y -> p ⊢ℒ add_prems n x ≡ add_prems n y + | entails_add_congr {x y n} : p ⊢ℒ x ≡ y -> p ⊢ℒ add_prems n x ≡ add_prems n y + | entails_add_inj {n x y} : p ⊢ℒ (add_prems n x) ≡ (add_prems n y) -> p ⊢ℒ x ≡ y | entails_join_congr {x y r} : p ⊢ℒ x ≡ y -> p ⊢ℒ (x ∨ r) ≡ (y ∨ r) | entails_assoc {x y z} : p ⊢ℒ ((x ∨ y) ∨ z) ≡ (x ∨ (y ∨ z)) | entails_idem {x} : p ⊢ℒ (x ∨ x) ≡ x | entails_comm {x y} : p ⊢ℒ (x ∨ y) ≡ (y ∨ x) | entails_sub {x} : p ⊢ℒ (x ∨ succ_prems x) ≡ (succ_prems x) - | entails_succ_inj {x y n} : p ⊢ℒ (add_prems n x) ≡ (add_prems n y) -> p ⊢ℒ x ≡ y - | entails_succ_join {x y} : p ⊢ℒ (succ_prems (x ∨ y)) ≡ (succ_prems x ∨ succ_prems y) + | entails_add_join {n x y} : p ⊢ℒ (add_prems n (x ∨ y)) ≡ (add_prems n x ∨ add_prems n y) where " p ⊢ℒ r " := (entails_L p r%_rel). + Derive Signature for entails_L. Lemma entails_join_congr_all {p} {x x' y y'} : p ⊢ℒ x ≡ x' -> p ⊢ℒ y ≡ y' -> p ⊢ℒ (x ∨ y) ≡ (x' ∨ y'). @@ -1033,7 +1043,7 @@ End ZUnivConstraint. intros he he'. eapply entails_trans with (x' ∨ y). now apply entails_join_congr. - rewrite (@univ_union_comm x' y) (@univ_union_comm x' y'). + rewrite (@union_comm x' y) (@union_comm x' y'). now apply entails_join_congr. Qed. @@ -1048,7 +1058,7 @@ End ZUnivConstraint. Proof. intros he he'. eapply entails_trans with (x ∨ y) => //. - rewrite !(@univ_union_comm x). + rewrite !(@union_comm x). apply entails_join_congr => //. now eapply entails_sym. Qed. @@ -1062,14 +1072,16 @@ End ZUnivConstraint. Definition univ_le (u u' : premises) := forall l k, LevelExprSet.In (l, k) u -> exists k', LevelExprSet.In (l, k') u /\ (k <= k')%Z. + Definition univ_eq u u' := + univ_le u u' /\ univ_le u' u. + + Infix "≌" := univ_eq (at level 70, no associativity). + Lemma univ_le_refl u u' : u = u' -> univ_le u u'. Proof. intros <- l k hin; exists k; split => //; lia. Qed. - Definition univ_eq u u' := - univ_le u u' /\ univ_le u' u. - Lemma univ_eq_refl u u' : u = u' -> univ_eq u u'. Proof. split; apply univ_le_refl; tea. now symmetry. @@ -1085,12 +1097,27 @@ End ZUnivConstraint. move=> [] le le' [] le0 le0'. split; auto. Qed. - Equations? pres_semilattice : semilattice := + Lemma univ_add_le_inj {n u v} : univ_le (add_prems n u) (add_prems n v) -> univ_le u v. + Proof. + intros hle l k hin. + move: (hle l (n + k)%Z) => /fwd. + { apply In_add_prems. exists (l, k); split => //. } + move=> [] k' [] /In_add_prems [] [] l' k2 [] inu [=] -> -> hle'. + exists k2. split => //. lia. + Qed. + + Lemma univ_add_inj {n u v} : univ_eq (add_prems n u) (add_prems n v) -> univ_eq u v. + Proof. + move=> [] le le'. split; eauto using univ_add_le_inj. + Qed. + + (* To model subsumption correctly, we need a larger relation than Leibniz equality. + In other words, (x ∨ add 1 x) <> add 1 x. *) + Equations? pres_semilattice : Semilattice NES.t Z := pres_semilattice := - {| carrier := NES.t; - eq x y := relations p.(C) -> univ_eq x y; + {| eq x y := relations p.(C) -> univ_eq x y; add := add_prems; - join x y := univ_union x y |}. + join x y := x ∪ y |}. Proof. all:intros. - split; red; intros. @@ -1098,20 +1125,27 @@ End ZUnivConstraint. * now apply univ_eq_sym, H. * now eapply univ_eq_trans; eauto. - rewrite add_prems_add_prems. now apply univ_eq_refl. + - specialize (H H0). destruct H as [le le']. + split; move=> l k /In_add_prems => -[[l' k'] [hin [=]]] -> ->. + * exists (n + k')%Z. split => //. apply In_add_prems. + exists (l', k'). split => //. reflexivity. + * exists (n + k')%Z; split => //. apply In_add_prems. + exists (l', k'); split => //. reflexivity. - rewrite add_prems_0. now apply univ_eq_refl. - - apply univ_eq_refl. now rewrite univ_union_assoc. - - apply univ_eq_refl. now rewrite univ_union_comm. + - apply univ_eq_refl. now rewrite union_assoc. + - apply univ_eq_refl. now rewrite union_comm. - split. intros l k; rewrite !LevelExprSet.union_spec. intros []; exists k; split => //; try lia; - now rewrite univ_union_spec. + now rewrite union_spec. intros l k hin. exists k. split => //. lia. - split. intros l k; rewrite !LevelExprSet.union_spec. intros []; exists k; split => //; try lia; - now rewrite univ_union_spec. + now rewrite union_spec. intros l k hin. exists k. split => //. lia. - split. intros l k hin. exists k. split => //. reflexivity. intros l k hin. exists k. split => //; reflexivity. - - apply univ_eq_refl. now rewrite add_prems_univ_union. + - specialize (H H0). now eapply univ_add_inj. + - apply univ_eq_refl. now rewrite add_prems_union. Qed. End pres_Semilattice. @@ -1129,27 +1163,27 @@ End ZUnivConstraint. intros le le'. eapply entails_trans. 2:exact le'. eapply entails_trans with (x ∨ y ∨ z). - rewrite univ_union_assoc. eapply entails_sym. + rewrite union_assoc. eapply entails_sym. eapply entails_join_congr_all => //. apply entails_refl. - rewrite univ_union_assoc. + rewrite union_assoc. eapply entails_trans with (x ∨ ((y ∨ y) ∨ z)). eapply entails_join_congr_all; auto with entails_L. - rewrite univ_union_assoc -univ_union_assoc. + rewrite union_assoc -union_assoc. now eapply entails_join_congr_all. Qed. - Lemma subset_univ_union {u u' : premises} : + Lemma subset_union {u u' : premises} : u ⊂_leset u' -> u ∨ u' = u'. Proof. intros hincl; apply equal_exprsets => l. - rewrite univ_union_spec. firstorder. + rewrite union_spec. firstorder. Qed. Lemma incl_entails_L {cls} {u u' : premises} : u ⊂_leset u' -> cls ⊢ℒ u ≤ u'. Proof. move=> hincl. unfold rel_le. - rewrite subset_univ_union //; auto with entails_L. + rewrite subset_union //; auto with entails_L. Qed. Lemma entails_L_subset {cls} {prems prems' prems'' : premises} : @@ -1172,7 +1206,7 @@ End ZUnivConstraint. Definition relation_of_constraint c := let '(l, d, r) := c in match d with - | ConstraintType.Le => (univ_union l r, r) + | ConstraintType.Le => (l ∪ r, r) | ConstraintType.Eq => (l, r) end. @@ -1367,10 +1401,10 @@ End ZUnivConstraint. apply entails_idem. - move=> le' x hin hnin /LevelExprSet.add_spec []. * intros eq; subst le'. - rewrite univ_union_comm univ_union_add_singleton. + rewrite union_comm union_add_singleton. rewrite add_idem. apply entails_refl. * move/hin => heq. - rewrite -!univ_union_add_singleton -univ_union_assoc. + rewrite -!union_add_singleton -union_assoc. now apply entails_join_congr. Qed. @@ -1393,12 +1427,13 @@ End ZUnivConstraint. induction 1. - rewrite /entails_L_clause /rel_le. destruct cl as [prems concl]; cbn. - rewrite -add_prems_singleton -add_prems_univ_union. - apply entails_succ_congr. + rewrite -add_prems_singleton -add_prems_union. + apply entails_add_congr. apply entails_c. now eapply presentation_of_clauses_spec. - - change (x, (k + 1)%Z) with (add_expr 1 (x, k)). + - replace (x, (k + 1)%Z) with (add_expr 1 (x, k)). rewrite -add_prems_singleton. red; cbn. eapply entails_sub. + now rewrite /succ_expr Z.add_comm. Qed. Lemma entails_L_le_eq {cls l r} : cls ⊢ℒ l ≤ r -> cls ⊢ℒ l ∨ r ≡ r. @@ -1421,7 +1456,7 @@ End ZUnivConstraint. Proof. unfold rel_le. intros le le'. eapply entails_trans with (l ∨ r) => //. - apply entails_sym. now rewrite univ_union_comm. + apply entails_sym. now rewrite union_comm. Qed. Lemma entails_L_le_join_l {p x x' r} : @@ -1430,7 +1465,7 @@ End ZUnivConstraint. Proof. intros le. unfold rel_le in le |- *. - rewrite univ_union_assoc (@univ_union_comm r) univ_union_assoc -univ_union_assoc. + rewrite union_assoc (@union_comm r) union_assoc -union_assoc. eapply entails_join_congr_all => //. apply entails_idem. Qed. @@ -1442,7 +1477,7 @@ End ZUnivConstraint. Proof. move/(entails_L_le_join_l (r:=y)) => le le'. eapply entails_L_le_trans; tea. - rewrite !(@univ_union_comm x'). + rewrite !(@union_comm x'). now eapply entails_L_le_join_l. Qed. @@ -1470,13 +1505,13 @@ End ZUnivConstraint. intros h; induction h. - red. now apply entails_L_idem_gen. - - move: IHh; rewrite -!univ_union_add_singleton. + - move: IHh; rewrite -!union_add_singleton. eapply in_pred_closure_entails_L in H. rewrite /entails_L_clause in H |- *; cbn in *. have hsub:= entails_L_subset H H0. move=> h'. eapply entails_L_le_trans. tea. - move/entails_L_eq_le_1: hsub. now rewrite univ_union_comm. + move/entails_L_eq_le_1: hsub. now rewrite union_comm. Qed. Definition entails_L_clauses p cls := @@ -1514,21 +1549,21 @@ End ZUnivConstraint. eapply LevelExprSet.add_spec. now right. } specialize (ih le); forward ih. eapply LevelExprSet.add_spec; now left. - rewrite -univ_union_add_singleton. + rewrite -union_add_singleton. now eapply entails_L_le_join. Qed. Lemma entails_L_le_left {p x y} : p ⊢ℒ x ≤ x ∨ y. Proof. - rewrite /rel_le. rewrite -univ_union_assoc. + rewrite /rel_le. rewrite -union_assoc. eapply entails_join_congr_all. apply entails_idem. apply entails_refl. Qed. Lemma entails_L_le_right {p x y} : p ⊢ℒ y ≤ x ∨ y. Proof. - rewrite univ_union_comm; apply entails_L_le_left. + rewrite union_comm; apply entails_L_le_left. Qed. Lemma entails_L_in p l (t : premises) : @@ -1539,10 +1574,10 @@ End ZUnivConstraint. - move=>[l' k] /LevelExprSet.singleton_spec => ->. apply entails_L_le_refl. - move=> le x h hnin /NES.add_spec []. - * intros ->. rewrite -univ_union_add_singleton. + * intros ->. rewrite -union_add_singleton. apply entails_L_le_right. * move/h => hle. - rewrite -univ_union_add_singleton. + rewrite -union_add_singleton. eapply entails_L_le_trans with x => //. apply entails_L_le_left. Qed. @@ -1644,13 +1679,15 @@ End ZUnivConstraint. ZUnivConstraintSet.For_all (entails_L_cstr p) cstrs. Section interp. - Context (v : Level.t -> nat). + Import Semilattice. + Context {S : Type} {SL : Semilattice S Z}. + Context (v : Level.t -> S). Definition interp_z_cstr c := let '(l, d, r) := c in match d with - | ConstraintType.Le => interp_prems v l <= interp_prems v r - | ConstraintType.Eq => interp_prems v l = interp_prems v r + | ConstraintType.Le => interp_prems v l ≤ interp_prems v r + | ConstraintType.Eq => interp_prems v l ≡ interp_prems v r end%Z. Definition interp_univ_cstr c := interp_z_cstr (to_constraint c). @@ -1658,41 +1695,29 @@ End ZUnivConstraint. Definition interp_univ_cstrs c := UnivConstraintSet.For_all interp_univ_cstr c. - Definition interp_cstr r := - let '(l, r) := r in - interp_prems v l = interp_prems v r. - - Definition interp_cstrs c := - List.Forall interp_cstr c. - - End interp. - - Module SemilatticeInterp. - Import Semilattice. - - Section interp_gen. - Context (s : semilattice). - Context (v : Level.t -> s). - - Definition interp_expr '(l, k) := (add s k (v l))%Z. - Definition interp_prems_s prems := - let '(hd, tl) := to_nonempty_list prems in - fold_right (fun lk acc => join s (interp_expr lk) acc) (interp_expr hd) tl. + Definition interp_expr '(l, k) := (add k (v l))%Z. Definition interp_rel r := let '(l, r) := r in - eq s (interp_prems_s l) (interp_prems_s r). + interp_prems v l ≡ interp_prems v r. Definition interp_rels c := List.Forall interp_rel c. - End interp_gen. + End interp. + + Structure semilattice := + { carrier :> Type; + sl : Semilattice carrier Z }. + + Definition Z_semilattice := {| carrier := Z; sl := _ |}. - Definition valid_relation s rels c := - (forall v, interp_rels s v rels -> interp_rel s v c). - End SemilatticeInterp. + Instance semlattice_Semilattice (s : semilattice) : Semilattice (carrier s) Z := sl s. + + Definition valid_relation rels c := + (forall (s : semilattice) (v : Level.t -> s), interp_rels v rels -> interp_rel v c). Definition valid_constraint rels c := - (forall v, interp_cstrs v rels -> interp_z_cstr v c). + (forall (s : semilattice) (v : Level.t -> s), interp_rels v rels -> interp_z_cstr v c). Definition valid_cstrs p cstrs := ZUnivConstraintSet.For_all (valid_constraint p) cstrs. @@ -1768,16 +1793,66 @@ End ZUnivConstraint. * now eapply Theory.eq_sym. * now eapply Theory.eq_trans. * now eapply Theory.succ_congr. + * now eapply Theory.succ_inj. * now eapply Theory.join_congr_left. * eapply Theory.join_assoc. * eapply Theory.join_idem. * eapply Theory.join_comm. * eapply Theory.join_succ. - * now eapply Theory.succ_inj. * eapply Theory.succ_join. - move/entails_clauses_pres. apply entails_L_clauses_of_relations_eq. Qed. + Instance entails_all_proper : Proper (Clauses.Equal ==> Logic.eq ==> Logic.eq ==> iff) entails_all. + Proof. + intros cls cls' H ? ? <- ? ? <-. + split; intros ? ? hin. rewrite -H. now apply H0. + rewrite H; now apply H0. + Qed. + + Instance entails_clauses_proper : Proper (Clauses.Equal ==> Clauses.Equal ==> iff) entails_clauses. + Proof. + intros cls cls' H ? ? H'. + split; intros ? ? hin. rewrite -H. apply H0. now rewrite H'. + rewrite H; apply H0. now rewrite -H'. + Qed. + + Instance entails_equiv_proper : Proper (Clauses.Equal ==> Logic.eq ==> Logic.eq ==> iff) entails_equiv. + Proof. + intros cls cls' H ? ? <- ?? <-. + split. + - intros []; split; now rewrite -H. + - intros []; split; now rewrite H. + Qed. + + Lemma to_clauses_of_z_constraints {cstrs} : + to_clauses cstrs =_clset of_z_constraints (to_z_cstrs cstrs). + Proof. + intros l. + rewrite to_clauses_spec of_z_constraints_spec. + split. + - intros [cstr [hin hin']]. + exists (to_constraint cstr). split. + apply to_z_cstrs_spec_1 in hin as [cstrz []]. + now subst cstrz. + assumption. + - intros [cstr [hin hin']]. + apply to_z_cstrs_spec_2 in hin as [cstr' [hin ->]]. + exists cstr'. split => //. + Qed. +(* + Lemma clauses_of_relations_of_z_constraints {cstrs} : + Clauses.eq (clauses_of_relations (relations_of_constraints cstrs)) (of_z_constraints cstrs). + Proof. + intros cl; split. rewrite of_z_constraints_spec. + - move/clauses_of_relations_spec => [[l r]] [] /relations_of_constraints_spec => -[] [[u []] v] [] hin heq //=. + * cbn in heq. noconf heq. + cbn. move/Clauses.union_spec. => -[] /clauses_of_le_spec => -[] le []. + rewrite LevelExprSet.union_spec => -[] hin' eq. + + rewrite eq. eexists; split; tea. rewrite LoopCheck.to_clauses_spec. exists le; split => //. + + subst cl. eexists (u, ConstraintType.Le, v); split; tea. rewrite LoopCheck.to_clauses_spec. exists le; split => //. *) + + Lemma completeness_eq_cstrs cstrs s t : relations_of_constraints cstrs ⊢ℒ s ≡ t <-> entails_z_cstr cstrs (s, ConstraintType.Eq, t). @@ -1785,20 +1860,20 @@ End ZUnivConstraint. unfold entails_z_cstr. split. - intros h; depind h; cbn. - move: H => //=; rewrite relations_of_constraints_spec => -[] [[l' []] r'] [hin heq]; noconf heq. - * eapply Theory.le_spec. + * move: H => //=; rewrite relations_of_constraints_spec => -[] [[l' []] r'] [hin heq]; noconf heq. + eapply Theory.le_spec. now apply entails_clauses_le_cstr. - * now eapply entails_clauses_eq_cstr. + now eapply entails_clauses_eq_cstr. * eapply Theory.eq_refl. * now eapply Theory.eq_sym. * now eapply Theory.eq_trans. * now eapply Theory.succ_congr. + * now eapply Theory.succ_inj. * now eapply Theory.join_congr_left. * eapply Theory.join_assoc. * eapply Theory.join_idem. * eapply Theory.join_comm. * eapply Theory.join_succ. - * now eapply Theory.succ_inj. * eapply Theory.succ_join. - move/entails_clauses_pres; apply entails_L_clauses_of_eq. Qed. @@ -1824,29 +1899,6 @@ End ZUnivConstraint. | ConstraintType.Eq => relations_of_constraints (to_z_cstrs cstrs) ⊢ℒ l ≡ r end. - Instance entails_clauses_proper : Proper (Clauses.Equal ==> Clauses.Equal ==> iff) entails_clauses. - Proof. - intros cls cls' H cls0 cls0' H'. - rewrite /entails_clauses. - rewrite H'. split; intros hf l. now rewrite -H. now rewrite H. - Qed. - - Lemma to_clauses_of_z_constraints {cstrs} : - to_clauses cstrs =_clset of_z_constraints (to_z_cstrs cstrs). - Proof. - intros l. - rewrite to_clauses_spec of_z_constraints_spec. - split. - - intros [cstr [hin hin']]. - exists (to_constraint cstr). split. - apply to_z_cstrs_spec_1 in hin as [cstrz []]. - now subst cstrz. - assumption. - - intros [cstr [hin hin']]. - apply to_z_cstrs_spec_2 in hin as [cstr' [hin ->]]. - exists cstr'. split => //. - Qed. - Lemma check_valid_pres m c : check m c <-> presentation_entails (constraints m) c. Proof. @@ -1861,25 +1913,31 @@ End ZUnivConstraint. Qed. Section SemiLatticeInterp. - Import SemilatticeInterp. Import Semilattice. - Lemma presentation_entails_valid_rel {p r s} : - p ⊢ℒ r -> valid_relation s p r. + Lemma presentation_entails_valid_rel {p r} : + p ⊢ℒ r -> valid_relation p r. Proof. rewrite /valid_relation //=. destruct r as [l r] => //=. - intros h; depind h; cbn; move=> v hv. + intros h; depind h; cbn; move=> s v hv. 1:{ red in hv. rewrite Forall_forall in hv; eapply hv in H. exact H. } - all:try specialize (IHh _ _ s eq_refl _ hv). - all:try specialize (IHh1 _ _ s eq_refl _ hv). - all:try specialize (IHh2 _ _ s eq_refl _ hv). + all:try specialize (IHh _ _ eq_refl s _ hv). + all:try specialize (IHh1 _ _ eq_refl s _ hv). + all:try specialize (IHh2 _ _ eq_refl s _ hv). all:try lia; eauto. all:rewrite ?interp_add_prems ?interp_prems_union ?interp_add_prems; try lia. - eapply reflexivity. - now eapply symmetry, IHh. - eapply transitivity; [eapply IHh1|eapply IHh2] => //. - - rewrite interp_add_prems. - rewrite ?interp_add_prems in IHh. lia. + - now apply add_congr. + - rewrite ?interp_add_prems in IHh. + now apply add_inj in IHh. + - now apply join_congr. + - apply join_assoc. + - apply join_idem. + - apply join_comm. + - apply (join_sub (Semilattice := sl s)). + - now apply add_join. Qed. Lemma presentation_entails_valid_eq {p l r} : @@ -1895,7 +1953,7 @@ End ZUnivConstraint. rewrite /valid_constraint /interp_z_cstr //=. move/presentation_entails_valid_eq => vc v hc. specialize (vc v hc). cbn in vc. - rewrite interp_prems_union in vc. lia. + rewrite interp_prems_union in vc. apply vc. Qed. Lemma presentation_entails_valid {p c} : @@ -1935,9 +1993,12 @@ End ZUnivConstraint. Admitted. *) - (* Lemma model_valuation_of_cstrs : interp_cstrs (LoopCheck.valuation m) *) + (* Lemma model_valuation_of_cstrs : interp_rels (LoopCheck.valuation m) *) + + Definition model_Z_val m := (to_Z_val (to_val (LoopCheck.valuation (model m)))). - Lemma interp_cstrs_of_m m : interp_cstrs (LoopCheck.valuation (model m)) (relations_of_constraints (to_z_cstrs (constraints m))). + + Lemma interp_rels_of_m m : interp_rels (model_Z_val m) (relations_of_constraints (to_z_cstrs (constraints m))). Proof. have hv := (LoopCheck.model_valuation m.(model)). red. @@ -1945,39 +2006,41 @@ End ZUnivConstraint. eapply to_z_cstrs_spec_2 in hin as [cstr [hin ->]]. have hrepr := repr_constraints m _ hin. destruct cstr as [[l' []] r']; cbn in heq; noconf heq. - - rewrite interp_prems_union. cbn in hrepr. + - rewrite /interp_rel interp_prems_union. cbn in hrepr. eapply clauses_sem_subset in hv; tea. - apply clauses_sem_clauses_of_le in hv. lia. + apply clauses_sem_clauses_of_le in hv. cbn in hv |- *. + unfold model_Z_val in *. lia. - cbn in hrepr. eapply clauses_sem_subset in hv; tea. rewrite /Clauses.clauses_of_eq in hv. eapply clauses_sem_union in hv. destruct hv as [hv hv']. apply clauses_sem_clauses_of_le in hv. - apply clauses_sem_clauses_of_le in hv'. lia. + apply clauses_sem_clauses_of_le in hv'. cbn in hv, hv' |- *. + unfold model_Z_val in *; lia. Qed. Lemma interp_univ_cstrs_of_m m : - interp_univ_cstrs (LoopCheck.valuation (model m)) (constraints m). + interp_univ_cstrs (model_Z_val m) (constraints m). Proof. intros uc hin. red. have h := repr_constraints m _ hin. - have hi := interp_cstrs_of_m m. + have hi := interp_rels_of_m m. red in hi. rewrite Forall_forall in hi. apply to_z_cstrs_spec_1 in hin as [cstrz [hin ->]]. destruct uc as [[l []] r]; cbn. cbn in h. - - move: (hi (to_atoms l ∨ to_atoms r, to_atoms r)) => /fwd. + - move: (hi ((to_atoms l ∨ to_atoms r)%nes, to_atoms r)) => /fwd. { apply relations_of_constraints_spec. exists (to_atoms l, ConstraintType.Le, to_atoms r). cbn. split => //. } - by rewrite interp_prems_union; lia. + by rewrite /interp_rel interp_prems_union; unfold model_Z_val in *; cbn; lia. - move: (hi (to_atoms l, to_atoms r)) => /fwd. { apply relations_of_constraints_spec. exists (to_atoms l, ConstraintType.Eq, to_atoms r). cbn. split => //. } by []. Qed. - Lemma interp_univ_cstrs_relations v cstrs : + Lemma interp_univ_cstrs_relations {S} {SL : Semilattice S Z} v cstrs : interp_univ_cstrs v cstrs <-> - interp_cstrs v (relations_of_constraints (to_z_cstrs cstrs)). + interp_rels v (relations_of_constraints (to_z_cstrs cstrs)). Proof. rewrite /interp_univ_cstrs. split. @@ -1986,16 +2049,16 @@ End ZUnivConstraint. cbn in heq; noconf heq. destruct d; noconf heq. * eapply to_z_cstrs_spec_2 in hin as [cstr [hin heq]]. destruct cstr as [[] ?]; noconf heq. specialize (hf _ hin). cbn in hf. - rewrite interp_prems_union. lia. + rewrite /interp_rel interp_prems_union; cbn in *. exact hf. * eapply to_z_cstrs_spec_2 in hin as [cstr [hin heq]]. destruct cstr as [[] ?]; noconf heq. specialize (hf _ hin). cbn in hf. - lia. + exact hf. - intros hi uc hin. red in hi. rewrite Forall_forall in hi. move: (hi (relation_of_constraint (to_constraint uc))) => /fwd. rewrite relations_of_constraints_spec; exists (to_constraint uc); split => //. now apply to_z_cstrs_spec_1 in hin as [cstrz [hin ->]]. destruct uc as [[l []] r] => //=. - rewrite interp_prems_union //=; cbn. lia. + rewrite interp_prems_union //=. Qed. Lemma prop_dec (b : bool) P : b <-> P -> (b = false <-> ~ P). @@ -2085,16 +2148,16 @@ Qed. *) Lemma subset_add {a l x} : ~ LevelExprSet.In l a -> a ⊂_leset NES.add l x -> a ⊂_leset x. Proof. - intros hnin; rewrite -univ_union_add_singleton. - move=> hsub lk /[dup]/hsub. rewrite univ_union_spec. + intros hnin; rewrite -union_add_singleton. + move=> hsub lk /[dup]/hsub. rewrite union_spec. intros [] => //. apply LevelExprSet.singleton_spec in H. subst. contradiction. Qed. (* Lemma subset_add_2 {a l x} : LevelExprSet.In l a -> a ⊂_leset NES.add l x -> a ⊂_leset x. Proof. - intros hnin; rewrite -univ_union_add_singleton. - move=> hsub lk /[dup]/hsub. rewrite univ_union_spec. + intros hnin; rewrite -union_add_singleton. + move=> hsub lk /[dup]/hsub. rewrite union_spec. intros [] => //. apply LevelExprSet.singleton_spec in H. subst. contradiction. Qed. *) @@ -2123,7 +2186,7 @@ Qed. *) Qed. Lemma premises_strict_subset_spec p p' : premises_strict_subset p p' <-> - p ⊂_leset p' /\ exists le, In le p' /\ ~ In le p. + (p ⊂_leset p') /\ exists le, In le p' /\ ~ In le p. Proof. split. - intros [hincl hneq]. split => //. @@ -2133,8 +2196,9 @@ Qed. *) Qed. Lemma premises_strict_subset_cardinal (p p' : premises) : - premises_strict_subset p p' -> cardinal p < cardinal p'. - Proof. rewrite premises_strict_subset_spec => -[incl [le [inp' ninp]]]. + premises_strict_subset p p' -> (cardinal p < cardinal p')%nat. + Proof. + rewrite premises_strict_subset_spec => -[incl [le [inp' ninp]]]. eapply subset_cardinal_lt; tea. Qed. @@ -2174,9 +2238,6 @@ Qed. *) Instance ord_wf : WellFounded ord. Proof. red. exact acc_ord. Qed. - Definition clauses_of_relations (p : list (premises × premises)) := - List.fold_right (fun '(l, r) => Clauses.union (clauses_of_eq l r)) Clauses.empty p. - Definition check_pres_clause p r := LoopCheck.Impl.check_clauses (clauses_of_relations p) (clauses_of_eq r.1 r.2). @@ -2187,8 +2248,8 @@ Qed. *) ~ LevelExprSet.In l u -> premises_strict_subset u (NES.add l u). Proof. intros hnin; rewrite premises_strict_subset_spec. - rewrite -univ_union_add_singleton. setoid_rewrite univ_union_spec. split. - - intros l'. rewrite univ_union_spec; lesets. + rewrite -union_add_singleton. setoid_rewrite union_spec. split. + - intros l'. rewrite union_spec; lesets. - exists l; split => //. right; now apply LevelExprSet.singleton_spec. Qed. @@ -2198,24 +2259,9 @@ Qed. *) Proof. cbn. reflexivity. Qed. - - Instance entails_all_proper : Proper (Clauses.Equal ==> Logic.eq ==> Logic.eq ==> iff) entails_all. - Proof. - intros cls cls' H ? ? <- ? ? <-. - split; intros ? ? hin. rewrite -H. now apply H0. - rewrite H; now apply H0. - Qed. - - Instance entails_equiv_proper : Proper (Clauses.Equal ==> Logic.eq ==> Logic.eq ==> iff) entails_equiv. - Proof. - intros cls cls' H ? ? <- ?? <-. - split. - - intros []; split; now rewrite -H. - - intros []; split; now rewrite H. - Qed. (* Lemma entails_deduction {cls prems prems' concl} : - entails cls (univ_union prems prems', concl) <-> + entails cls (union prems prems', concl) <-> entails (Clauses.add (prems, concl) cls) (prems', concl). Proof. split. @@ -2298,230 +2344,141 @@ Qed. *) eapply entails_clauses_cut; tea. Qed. - Parameter ϕ : nat -> rel. - Parameter ϕ_exists : forall r, exists n, ϕ n = r. - Parameter ϕ_inj : forall n n', ϕ n = ϕ n' -> n = n'. - - Definition neg_r p e := - p ⊢ℒ add_prems 1 e.1 ≤ e.2 \/ p ⊢ℒ add_prems 1 e.2 ≤ e.1. - - (* Definition consistent (r : rels) := - ~ (exists e, r ⊢ℒ e /\ neg_r r e). - - Definition satisfiable (r : rels) := - exists v, interp_cstrs v r. - - Definition satisfiable_consistent {p} : - satisfiable p -> consistent p. - Proof. - move=> [v it] [[l r] [hx [hnl|hnl]]]; - eapply presentation_entails_valid_eq in hx; - eapply presentation_entails_valid_le in hnl; - move: (hx _ it); move: (hnl _ it); cbn; - rewrite !interp_add_prems; lia. - Qed. *) - - (* Definition consistent' (Γ : rels) := - exists r, ~ (Γ ⊢ℒ r). *) - - Definition consistent Γ := - ~ exists e, Γ ⊢ℒ e ≡ add_prems 1 e. - - Inductive 𝒮 (r : rels) : rels -> nat -> Prop := - | S_0 Γ : List.incl Γ r -> 𝒮 r Γ 0 - | S_incl Γ n : 𝒮 r Γ n -> - (* ~ consistent (ϕ n :: Γ) -> *) - 𝒮 r Γ (S n) - | S_phi Γ n : 𝒮 r Γ n -> consistent (ϕ n :: Γ) -> 𝒮 r (ϕ n :: Γ) (S n). - - Definition 𝒮ω rs (Γ : rels) := exists (n: nat), 𝒮 rs Γ n. - - Definition in𝒮ω rs r := exists (n: nat) Γ, 𝒮 rs Γ n /\ Γ ⊢ℒ r. - (* /\ Γ ⊢ℒ r *) - - Definition maximally_consistent (Γ : rels) := - consistent Γ /\ forall r, (~ consistent (r :: Γ) \/ Γ ⊢ℒ r). - - Definition satisfiable (r : rels) := - exists v, interp_cstrs v r. - - Lemma consistent_satisfiable Γ : - satisfiable Γ -> consistent Γ. - Proof. - move=> [v sat] [e]. - move/presentation_entails_valid_rel/(_ v sat). cbn. - rewrite interp_add_prems. lia. - Qed. - - Section MaximallyConsistent. - - Lemma 𝒮ω_consistent_maximal Γ Γ' n : consistent Γ -> 𝒮 Γ Γ' n -> consistent Γ'. - (* /\ (consistent' (ϕ n :: Γ') \/ Γ' ⊢ℒ ϕ n). *) - Proof. - move=> con sprf. induction sprf. - - intros [e pe]. apply con. exists e. - eapply entails_L_rels_subset; tea. - - exact IHsprf. - - intros [e neq]. - destruct H. now exists e. - Qed. - - Definition 𝒮ω_exists rs (crs : consistent rs) n : exists Γ, 𝒮 rs Γ n. - Proof. - induction n. - - exists rs. by constructor. - - destruct IHn as [Γ' sn]. - destruct (check_pres_clause_spec Γ' (ϕ n)). - * exists (ϕ n :: Γ'). apply S_phi => //. - intros [e he]. apply 𝒮ω_consistent_maximal in sn => //. - eapply entails_L_cut in H; tea. - apply sn. now exists e. - * exists Γ'. apply S_incl => //. - Qed. - - Definition inSw rs r := exists n Γ, 𝒮 rs Γ n /\ Γ ⊢ℒ r. - - Import Semilattice. - Import SemilatticeInterp. - - Lemma axiom_inSw {rs r} : rs ⊢ℒ r -> inSw rs r. - Proof. - intros hs. exists 0, rs; split. constructor. red; auto. - exact: hs. - Qed. Section M0. Context (rs : rels). - Equations? M0 : semilattice := - M0 := - {| carrier := NES.t; - eq x y := inSw rs (x, y); + Equations? M0 : Semilattice NES.t Z := + M0 := {| + eq x y := rs ⊢ℒ x ≡ y; add := add_prems; - join := univ_union |}. + join := union |}. Proof. - all:intros. 1-4:apply axiom_inSw. - - eapply entails_assoc. - - eapply entails_comm. - - eapply entails_idem. - - eapply entails_sub. - - destruct H as [n [Γ [insw ent]]]. - exists n, Γ. split => //. - now eapply (@entails_succ_inj _ _ _ 1%Z). - - apply axiom_inSw. apply entails_succ_join. + all:intros. all:try solve [econstructor; eauto]. + - split; intros. + * intros x. eapply entails_refl. + * intros x y. eapply entails_sym. + * intros x y z. eapply entails_trans. + - rewrite add_prems_add_prems. eapply entails_refl. + - rewrite add_prems_0. apply entails_refl. Qed. - End M0. + Print semilattice. - Definition valid (s : semilattice) v r := - interp_rel s v r. + #[export] Existing Instance M0. + + Definition initial_semilattice : semilattice := + {| carrier := NES.t; sl := _ |}. Definition ids := (fun l : Level.t => singleton (l, 0%Z)). - Lemma interp_triv rs l : interp_prems_s (M0 rs) ids l = l. + Lemma interp_triv l : interp_prems ids l ≡ l. Proof. move: l; apply: elim. - intros [l k]. - * rewrite /interp_prems_s; cbn. - induction k; cbn; auto. - destruct p. - rewrite /add. - rewrite /interp_expr. - + rewrite interp_prems_singleton //= /ids //=. + rewrite add_prems_singleton //= Z.add_0_r. + apply entails_refl. + - move=> [] l k x ih hnin. + have ha := (interp_prems_add (SL := M0) ids (l, k)). + rewrite ha ih. rewrite /Model.interp_expr. rewrite -union_add_singleton /ids. + rewrite [add _ _]add_prems_singleton /add_expr Z.add_0_r. + apply (join_comm (Semilattice := M0)). Qed. + End M0. - Lemma syntax_model rs r : valid (M0 rs) ids r <-> inSw rs r. - Proof. - rewrite /valid. - destruct r as [l r]. cbn. + Lemma interp_rels_init rs : interp_rels (SL := M0 rs) ids rs. + Proof. + unfold interp_rels; unfold interp_rel. cbn. + have ir : incl rs rs. + { now intros l. } + move: ir. + generalize rs at 1 6. + induction rs0; cbn. + - constructor. + - destruct a. constructor. + * change (eq (Semilattice := M0 rs) (interp_prems (s := M0 rs) ids t0) (interp_prems (s := M0 rs) ids t1)). + rewrite !interp_triv. + constructor. apply ir. now constructor. + * apply IHrs0. intros r hin; apply ir. now right. + Qed. - Qed. - -(* - - - - Lemma 𝒮ω_maximal Γ (conΓ : consistent Γ) Γ' : 𝒮ω Γ Γ' -> maximally_consistent Γ'. - Proof. - intros [n sw]; red. - eapply 𝒮ω_consistent_maximal in sw. split => //. - move=> r. destruct (check_pres_clause_spec Γ' r). - now right. left. intros con. [e he]. - Qed. *) - -(* - Section S. - Context (p : rels). - - Fixpoint 𝖲 (n : nat) (a : rel) := - match n with - | 0 => List.In a p - | S n => 𝖲 n \/ ϕ n = a /\ (a :: 𝖲 n - - Equations? S (p : list (premises × premises)) (r : premises × premises) (e : enumeration r) : list (premises × premises) - by wf r ord := { - S p ?((singleton le, singleton le')) (enum_single le le') := - check_add p (NES.singleton le) (NES.singleton le') ; - S p _ (enum_add_left le u v nin e) := check_add (S p _ e) (NES.add le u) v; - S p _ (enum_add_right le u v nin e) := check_add (S p _ e) u (NES.add le v) }. - Proof. - - constructor; now apply premises_strict_subset_add. - - constructor; now apply premises_strict_subset_add. - Qed. - - Fixpoint S' (p : rels) n := - match n with - | 0 => p - | S n => S p rel (acc_enum rel) - end. + Definition valid {S} (SL : Semilattice S Z) v r := + interp_rel (SL := SL) v r. - Lemma extension p : consistent p -> exists p', maximally_consistent p'. - Proof. - intros con. - destruct p as [V C]. - exists {| V := V; C := (S' C) |}. - destruct C; cbn. - - red. split => //. - intros x y. left. intros hcon. red in hcon. admit. - - apply IHC. red in con. red. - intros [x hnc]. apply con. exists x. admit. - Admitted. -*) + Lemma syntax_model rs r : valid (M0 rs) ids r <-> rs ⊢ℒ r. + Proof. + rewrite /valid. + destruct r as [l r]. unfold interp_rel. + rewrite !interp_triv; split; apply. + Qed. Class Decidable (A : Prop) := dec : A \/ ~ A. + Arguments dec A {Decidable}. Instance dec_entails_L {p s t} : Decidable (p ⊢ℒ s ≡ t). Proof. red. eapply check_pres_clause_spec. Qed. - Lemma contra_prop A B (dec : Decidable B) : (~ B -> ~ A) -> (A -> B). + Lemma contra_prop A B (decB : Decidable B) : (~ B -> ~ A) -> (A -> B). Proof. intros he a. destruct (dec B). exact H. specialize (he H). contradiction. Qed. + Definition satisfiable (s : semilattice) (r : rels) := + exists v, interp_rels (SL := sl s) v r. + + Definition neg_r p e := + p ⊢ℒ add_prems 1 e.1 ≤ e.2 \/ p ⊢ℒ add_prems 1 e.2 ≤ e.1. - Lemma not_provable_neg p l r : ~ (p ⊢ℒ l ≡ r) -> neg_r p l r. + Definition consistent (r : rels) := + ~ (exists e, r ⊢ℒ e /\ neg_r r e). + + (* Lemma not_provable_neg p l r : ~ (p ⊢ℒ l ≡ r) -> neg_r p l r. Proof. intros np. red. - Admitted. + Admitted. *) Lemma entails_L_completeness {p l r} : - (forall v, interp_cstrs v p -> interp_prems v l = interp_prems v r) -> + (forall (s : semilattice) (v : Level.t -> s), interp_rels v p -> interp_prems v l ≡ interp_prems v r) -> p ⊢ℒ l ≡ r. Proof. - apply contra_prop. - apply dec_entails_L. - intros np hv. - apply not_provable_neg in np. destruct np. - have hp := @presentation_entails_satisfies p . - move/presentation_entails_valid_le: H. - rewrite /valid_constraint. cbn. - + intros hv. + specialize (hv (initial_semilattice p) ids). + forward hv. + { apply interp_rels_init. } + rewrite !interp_triv in hv. + exact hv. + Qed. + Lemma check_completeness {m c} : + LoopCheck.Impl.Abstract.check_clauses m c <-> (forall (s : semilattice) (v : Level.t -> s), clauses_sem v (LoopCheck.Impl.Abstract.clauses m) -> clauses_sem v c). + Proof. + rewrite LoopCheck.Impl.Abstract.check_clauses_spec. + split. + - move/entails_clauses_pres. + move=> ent s v hyps cl /ent. + admit. + - intros valid. + Search entails_clauses. + Set Printing All. + rewrite /entails_L_clause. Qed. + Lemma check_completeness {m c} : + check m c <-> (forall (s : semilattice) (v : Level.t -> s), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + Proof. + destruct check eqn:hc. + - split => // _ s v hu. + eapply check_valid_pres in hc. + destruct c as [[l []] r]; cbn in hc. + * red in hu. have := presentation_entails_satisfies hc. v => /fwd. + { admit. } + rewrite interp_prems_union. cbn. lia. + * have := presentation_entails_satisfies hc v => /fwd. +(* Lemma satisfies_entails_presentation {m c} : check m c = false <-> exists v, interp_univ_cstrs v (constraints m) -> invalid_cstr v c. Proof. @@ -2548,8 +2505,8 @@ Qed. *) apply interp_univ_cstrs_of_m. apply he. cbn. - apply interp_cstrs_of_m. - - move=> [v [ics ic]]. + apply interp_rels_of_m. + - move=> [v [ics ic]]. *) Lemma satisfies_entails_presentation {m c} : @@ -2569,7 +2526,7 @@ Qed. *) split. - intros hv. - have [v hc] : exists v, interp_cstrs v (C p). + have [v hc] : exists v, interp_rels v (C p). admit. specialize (hv _ hc). @@ -2585,3 +2542,107 @@ Qed. *) End UnivLoopChecking. + +(* Completeness try *) +(* + + + Parameter ϕ : nat -> rel. + Parameter ϕ_exists : forall r, exists n, ϕ n = r. + Parameter ϕ_inj : forall n n', ϕ n = ϕ n' -> n = n'. + + Definition neg_r p e := + p ⊢ℒ add_prems 1 e.1 ≤ e.2 \/ p ⊢ℒ add_prems 1 e.2 ≤ e.1. + + (* Definition consistent (r : rels) := + ~ (exists e, r ⊢ℒ e /\ neg_r r e). + + Definition satisfiable (r : rels) := + exists v, interp_rels v r. + + Definition satisfiable_consistent {p} : + satisfiable p -> consistent p. + Proof. + move=> [v it] [[l r] [hx [hnl|hnl]]]; + eapply presentation_entails_valid_eq in hx; + eapply presentation_entails_valid_le in hnl; + move: (hx _ it); move: (hnl _ it); cbn; + rewrite !interp_add_prems; lia. + Qed. *) + + (* Definition consistent' (Γ : rels) := + exists r, ~ (Γ ⊢ℒ r). *) + + Definition bottom (s : semilattice) := + exists x : s, add 1%Z x ≤ x. + + Notation "⟘" := (bottom _) : sl_scope. + + Definition consistent Γ := + ~ exists e, Γ ⊢ℒ e ≡ add_prems 1 e. + + Inductive 𝒮 (r : rels) : rels -> nat -> Prop := + | S_0 Γ : List.incl Γ r -> 𝒮 r Γ 0 + | S_incl Γ n : 𝒮 r Γ n -> + (* ~ consistent (ϕ n :: Γ) -> *) + 𝒮 r Γ (S n) + | S_phi Γ n : 𝒮 r Γ n -> consistent (ϕ n :: Γ) -> 𝒮 r (ϕ n :: Γ) (S n). + + Definition 𝒮ω rs (Γ : rels) := exists (n: nat), 𝒮 rs Γ n. + + Definition in𝒮ω rs r := exists (n: nat) Γ, 𝒮 rs Γ n /\ Γ ⊢ℒ r. + + (* /\ Γ ⊢ℒ r *) + + Definition maximally_consistent (Γ : rels) := + consistent Γ /\ forall r, (~ consistent (r :: Γ) \/ Γ ⊢ℒ r). + + Definition satisfiable (s : semilattice) (r : rels) := + exists v, interp_rels (SL := sl s) v r. + + Lemma consistent_satisfiable Γ : + satisfiable Z_semilattice Γ -> consistent Γ. + Proof. + move=> [v sat] [e]. + move/presentation_entails_valid_rel/(_ Z_semilattice v sat). cbn. + rewrite interp_add_prems. change (add 1%Z (interp_prems v e)) with (Z.add 1 (interp_prems v e)). + cbn -[Z.add]. lia. + Qed. + + Section MaximallyConsistent. + + Lemma 𝒮ω_consistent_maximal Γ Γ' n : consistent Γ -> 𝒮 Γ Γ' n -> consistent Γ'. + (* /\ (consistent' (ϕ n :: Γ') \/ Γ' ⊢ℒ ϕ n). *) + Proof. + move=> con sprf. induction sprf. + - intros [e pe]. apply con. exists e. + eapply entails_L_rels_subset; tea. + - exact IHsprf. + - intros [e neq]. + destruct H. now exists e. + Qed. + + Definition 𝒮ω_exists rs (crs : consistent rs) n : exists Γ, 𝒮 rs Γ n. + Proof. + induction n. + - exists rs. by constructor. + - destruct IHn as [Γ' sn]. + destruct (check_pres_clause_spec Γ' (ϕ n)). + * exists (ϕ n :: Γ'). apply S_phi => //. + intros [e he]. apply 𝒮ω_consistent_maximal in sn => //. + eapply entails_L_cut in H; tea. + apply sn. now exists e. + * exists Γ'. apply S_incl => //. + Qed. + + Definition inSw rs r := exists n Γ, 𝒮 rs Γ n /\ Γ ⊢ℒ r. + + Import Semilattice. + + Lemma axiom_inSw {rs r} : rs ⊢ℒ r -> inSw rs r. + Proof. + intros hs. exists 0, rs; split. constructor. red; auto. + exact: hs. + Qed. + +*) \ No newline at end of file diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v index a156a804f..ae4153b20 100644 --- a/utils/theories/NonEmptyLevelExprSet.v +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -75,7 +75,14 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) now move/InA_In_eq/LevelExprSetFact.elements_2. Qed. - Record t := { t_set :> LevelExprSet.t ; t_ne : is_empty t_set = false }. + Record t := + { t_set :> LevelExprSet.t ; + t_ne : is_empty t_set = false }. + + Declare Scope nes_scope. + Bind Scope nes_scope with t. + Delimit Scope nes_scope with nes. + Local Open Scope nes_scope. Existing Instance LevelExprSet.reflect_eq. Existing Instance Q.comm_monoid. @@ -340,7 +347,7 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) Qed. #[program] - Definition univ_union (prems prems' : t) : t := + Definition union (prems prems' : t) : t := {| t_set := LevelExprSet.union prems prems' |}. Next Obligation. destruct prems, prems'; cbn. @@ -350,35 +357,42 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) destruct t_ne0. lesets. Qed. - Lemma univ_union_spec u u' l : - LevelExprSet.In l (univ_union u u') <-> + Infix "∪" := union (at level 70): nes_scope. + + Lemma union_spec u u' l : + LevelExprSet.In l (u ∪ u') <-> LevelExprSet.In l u \/ LevelExprSet.In l u'. Proof. - destruct u, u'; unfold univ_union; cbn. + destruct u, u'; unfold union; cbn. apply LevelExprSet.union_spec. Qed. - Lemma univ_union_add_singleton u le : univ_union u (singleton le) = add le u. + Lemma union_add_singleton u le : union u (singleton le) = add le u. Proof. apply equal_exprsets. - intros x. rewrite univ_union_spec LevelExprSet.singleton_spec add_spec. + intros x. rewrite union_spec LevelExprSet.singleton_spec add_spec. intuition auto. Qed. - Lemma univ_union_comm {u u'} : univ_union u u' = univ_union u' u. + Lemma union_comm {u u'} : u ∪ u' = union u' u. Proof. apply equal_exprsets. - intros x. rewrite !univ_union_spec. + intros x. rewrite !union_spec. intuition auto. Qed. - Lemma univ_union_add_distr {le u u'} : univ_union (add le u) u' = add le (univ_union u u'). + Lemma union_add_distr {le u u'} : union (add le u) u' = add le (u ∪ u'). Proof. apply equal_exprsets. - intros x. rewrite !univ_union_spec !add_spec !univ_union_spec. + intros x. rewrite !union_spec !add_spec !union_spec. intuition auto. Qed. + Lemma union_idem u : union u u = u. + Proof. + apply equal_exprsets => l. + rewrite union_spec. firstorder. + Qed. Lemma levels_spec_aux l (e : LevelExprSet.t) acc : LevelSet.In l (LevelExprSet.fold (fun le : LevelExprSet.elt => LevelSet.add (level le)) e acc) <-> @@ -474,11 +488,11 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) cbn. firstorder. subst x'. now left. Qed. - Lemma univ_union_assoc {s t u} : univ_union (univ_union s t) u = - univ_union s (univ_union t u). + Lemma union_assoc {s t u} : union (s ∪ t) u = + union s (t ∪ u). Proof. apply equal_exprsets. - intros x. rewrite !univ_union_spec. + intros x. rewrite !union_spec. intuition auto. Qed. diff --git a/utils/theories/SemiLattice.v b/utils/theories/SemiLattice.v index 2c261282b..c8b109d74 100644 --- a/utils/theories/SemiLattice.v +++ b/utils/theories/SemiLattice.v @@ -170,3 +170,14 @@ Module Semilattice. End Derived. End Semilattice. + +Module InitialSemilattice + (Level : OrderedTypeWithLeibniz) (Q : Quantity) + (LevelSet : LevelSet_fun Level) + (LevelExpr : LevelExprT Level Q) + (LevelExprSet : LevelExprSet_fun Level Q LevelExpr). + + + + +End InitialSemilattice. From d0c9ad29c483f8a06339471ee7607a5c89cc5570 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 23 Sep 2025 13:40:16 +0200 Subject: [PATCH 061/164] Refactor proofs --- common/_RocqProject.in | 2 + common/theories/LoopChecking/Common.v | 102 +-- common/theories/LoopChecking/Deciders.v | 202 ++++- common/theories/LoopChecking/Expressions.v | 0 common/theories/LoopChecking/HornClauses.v | 223 +++-- .../LoopChecking/HornSemilatticeEquiv.v | 375 ++++++++ .../LoopChecking/InitialSemilattice.v | 743 ++++++++++++++++ common/theories/LoopChecking/Interfaces.v | 12 +- common/theories/LoopChecking/Model.v | 358 +------- common/theories/LoopChecking/ModelValuation.v | 161 ++++ common/theories/Universes.v | 29 +- .../theories/LoopChecking/UnivLoopChecking.v | 816 +----------------- utils/theories/MRClasses.v | 3 +- utils/theories/MRList.v | 7 + utils/theories/NonEmptyLevelExprSet.v | 113 ++- utils/theories/SemiLattice.v | 26 +- 16 files changed, 1774 insertions(+), 1398 deletions(-) create mode 100644 common/theories/LoopChecking/Expressions.v create mode 100644 common/theories/LoopChecking/HornSemilatticeEquiv.v create mode 100644 common/theories/LoopChecking/InitialSemilattice.v create mode 100644 common/theories/LoopChecking/ModelValuation.v diff --git a/common/_RocqProject.in b/common/_RocqProject.in index 4ff658e4c..c293edad6 100644 --- a/common/_RocqProject.in +++ b/common/_RocqProject.in @@ -18,7 +18,9 @@ theories/Transform.v theories/LoopChecking/Common.v theories/LoopChecking/Interfaces.v +theories/LoopChecking/InitialSemilattice.v theories/LoopChecking/HornClauses.v +theories/LoopChecking/HornSemilatticeEquiv.v theories/LoopChecking/Model.v theories/LoopChecking/Models.v theories/LoopChecking/PartialLoopChecking.v diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v index f36229c81..c2ae1c153 100644 --- a/common/theories/LoopChecking/Common.v +++ b/common/theories/LoopChecking/Common.v @@ -2,7 +2,7 @@ From Stdlib Require Import ssreflect ssrfun ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils SemiLattice. +From MetaRocq.Utils Require Import utils NonEmptyLevelExprSet SemiLattice. From MetaRocq.Common Require Universes. From Equations Require Import Equations. @@ -189,7 +189,11 @@ Qed. Notation min_opt := (option_map2 Z.min). -Infix "≤" := (opt_le Z.le) (at level 50). +Declare Scope opt_rel. +Delimit Scope opt_rel with opt. +Open Scope opt_rel. + +Infix "≤" := (opt_le Z.le) (at level 50) : opt_rel. Lemma opt_lt_le_trans x y z : opt_le Z.lt x y -> @@ -279,100 +283,6 @@ Proof. now rewrite (assoc (f := option_map2 Z.max)) (comm (f := option_map2 Z.max) x y) -assoc. Qed. -Section ForSemilattice. - Import Semilattice. - Import CommutativeMonoid. - Context {A : Type} {V : Type} {CM : IsCommMonoid V} {SL : Semilattice A V}. - Open Scope sl_scope. - - Lemma fold_right_max_in {a : A} {l : list A} n : In a l -> a ≤ (fold_right join n l). - Proof. - induction l. - - now cbn. - - intros [eq|inl]. subst a0. cbn. apply join_le_left. - cbn. specialize (IHl inl). etransitivity; tea. apply join_le_right. - Qed. - - Lemma fold_right_max_acc {n l} : n ≤ fold_right join n l. - Proof. - induction l. - - now cbn. - - cbn. etransitivity; tea. eapply join_le_right. - Qed. - - Lemma fold_right_impl n l l' : - (forall x, In x l -> In x l') -> fold_right join n l ≤ fold_right join n l'. - Proof. - induction l in l' |- *. - - cbn. destruct l'; cbn. reflexivity. - intros. have := @fold_right_max_acc n l'. - etransitivity; tea; eapply join_le_right. - - cbn; intros h. - have inal' := (h a (or_introl eq_refl)). - have := fold_right_max_in n inal'. - specialize (IHl l'). - forward IHl. - intros. apply h. now right. - intros hle; rewrite join_le_left_eq. now split. - Qed. - - Lemma fold_right_max_spec n l : - let fn := fold_right join in - (forall x, In x (n :: l) -> x ≤ fn n l). - Proof. - induction l; cbn. - - intros x [] => //. now subst. - (* exists n. firstorder. reflexivity. *) - - cbn in IHl. - intros x [|[]]; subst. - * specialize (IHl x). forward IHl by auto. - now apply join_le_right_trans. - * apply join_le_left. - * specialize (IHl x). forward IHl by auto. - now apply join_le_right_trans. - Qed. - - Lemma fold_right_equivlist_all_le n n' l l' : - equivlistA Logic.eq (n :: l) (n' :: l') -> fold_right join n l ≤ fold_right join n' l'. - Proof. - intros eq. - have hla := fold_right_max_spec n l. - have hra := fold_right_max_spec n' l'. - red in eq. - setoid_rewrite InA_In_eq in eq. - cbn in hra. setoid_rewrite <- eq in hra. clear -hra. - move: hra; generalize (fold_right join n' l'). - clear. - induction l. - - cbn. intros a heq. apply heq. now left. - - cbn. intros a' ih. - specialize (IHl a'). forward IHl. - { cbn; intros x []. subst. eapply ih. now left. - apply ih. auto. } - specialize (ih a). forward ih. { now right; left. } - eapply join_le_left_eq; now split. - Qed. - - Lemma fold_right_equivlist_all n n' l l' : - equivlistA Logic.eq (n :: l) (n' :: l') -> fold_right join n l ≡ fold_right join n' l'. - Proof. - intros eq. - apply eq_antisym; split; eapply fold_right_equivlist_all_le; auto. - now symmetry. - Qed. - - Lemma fold_right_comm acc l : l <> [] -> fold_right join acc l ≡ join acc (fold_right join (List.hd acc l) (List.tl l)). - Proof. - induction l in acc |- *. - - intros; congruence. - - intros _. cbn. destruct l; cbn. apply join_comm. - cbn in IHl. rewrite (IHl acc). congruence. - rewrite (IHl a). congruence. - now rewrite -!join_assoc (join_comm a). - Qed. - -End ForSemilattice. - Lemma fold_left_map {A B C} (f : B -> A -> A) (g : C -> B) l acc : fold_left (fun acc l => f (g l) acc) l acc = fold_left (fun acc l => f l acc) (List.map g l) acc. diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 444d5f2a1..73a5d4185 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -7,7 +7,7 @@ From MetaRocq.Utils Require Import utils MRClasses SemiLattice. From MetaRocq.Common Require UnivConstraintType Universes. From Equations Require Import Equations. -From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model Models PartialLoopChecking. +From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model Models PartialLoopChecking InitialSemilattice HornSemilatticeEquiv. Set Equations Transparent. @@ -53,6 +53,10 @@ Module Import I := LoopCheckingImpl LS. Import LS. Local Open Scope Z_scope. +Module Import Equiv := HornSemilattice LS. +Import Equiv.SL. +Import Equiv. + Definition init_model cls := max_clause_premises cls. Lemma init_model_levels cls k : @@ -117,10 +121,10 @@ Definition print_clauses (cls : clauses) := Definition valuation := LevelMap.t nat. -Equations? infer_model (cls : clauses) : option model := +Equations? infer_model (cls : clauses) : model + premises := infer_model cls with loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (init_model cls) _ := - | Loop _ _ => None - | Model w vm heq => Some vm.(model_model). + | Loop v _ => inr v + | Model w vm heq => inl vm.(model_model). Proof. split. - reflexivity. @@ -128,12 +132,116 @@ Proof. - apply is_update_of_empty. Qed. +Definition correct_model (cls : clauses) (m : model) := + enabled_clauses m cls /\ is_model cls m. + +Lemma enabled_clauses_le {m v u} : enabled_clauses m (v ⋞ u)%cls <-> + defined_model_of (levels u) m. +Proof. + split. +Admitted. + Definition infer_correctness cls := match infer_model cls with - | Some m => correct_model cls m - | None => ~ exists v, clauses_sem v cls + | inl m => correct_model cls m + | inr u => ~ exists m, defined_model_of (levels u) m /\ is_model cls m end. +Definition valid_clauses m cls := Clauses.For_all (valid_clause m) cls. +Infix "⊨" := valid_clauses (at level 90). + +Lemma is_model_valid {cls m} : is_model cls m <-> m ⊨ cls. +Proof. + rewrite /is_model. + rewrite [is_true _]Clauses.for_all_spec. reflexivity. +Qed. + +Lemma entails_all_model_valid {cls cls' : clauses} {m : model} : + m ⊨ cls -> cls ⊢ℋ cls' -> m ⊨ cls'. +Proof. + intros ism ent cl incl. + move/ent: incl => entcl. + eapply entails_model_valid; tea. + apply Clauses.for_all_spec. tc. apply ism. +Qed. + +Print valid_clause. + +Lemma valid_enabled_clause_spec model cl : + enabled_clause model cl -> + valid_clause model cl -> + exists hmin, min_premise model (premise cl) = Some hmin /\ (Some (hmin + (concl cl).2) ≤ level_value model (concl cl).1)%opt. +Proof. + intros [hmin eq]. + destruct cl as [prems [concl k]]. move/valid_clause_elim/(_ hmin eq) => hle. + exists hmin. split => //. +Qed. + +Lemma valid_enabled_clauses_spec {model cls} : + enabled_clauses model cls -> + valid_clauses model cls -> + forall cl, Clauses.In cl cls -> + exists hmin, min_premise model (premise cl) = Some hmin /\ (Some (hmin + (concl cl).2) ≤ level_value model (concl cl).1)%opt. +Proof. + intros en valid cl hin. + specialize (en cl hin). + specialize (valid cl hin). + now apply valid_enabled_clause_spec. +Qed. + + +Lemma min_opt_None_right x z : min_opt x None = Some z -> False. +Proof. + destruct x => //=. +Qed. + +Lemma min_opt_None_left x z : min_opt None x = Some z -> False. +Proof. + destruct x => //=. +Qed. + +Lemma loop_invalid {m u} : enabled_clauses m (succ u ⋞ u)%cls -> m ⊨ succ u ⋞ u -> False. +Proof. + intros en valid. + have vm := valid_enabled_clauses_spec en valid. + setoid_rewrite clauses_of_le_spec in vm. + clear en valid. + move: u vm. apply: NES.elim. + - intros le hcl. + move: (hcl (singleton le, succ_expr le)) => /fwd. + { exists (succ_expr le). split => //. + apply In_add_prems. exists le; split => //. now apply LevelExprSet.singleton_spec. } + move=> [z [hmin hleq]]. cbn in hleq. + depelim hleq. cbn in H0. + rewrite min_premise_singleton /min_atom_value in hmin. + destruct le as [l k]. cbn -[Z.add] in *. rewrite H0 in hmin. noconf hmin. lia. + - intros le x en hnin h. + apply en. intros cl [lk [hin eq]]. subst cl. + eapply In_add_prems in hin as [? []]. subst lk. cbn. + move: (h (add le x, succ_expr x0)) => /fwd. + { exists (succ_expr x0). split => //. + apply In_add_prems. exists x0. split => //. + apply LevelExprSet.add_spec. now right. } + intros [hmin [eqmin lv]]. + cbn in lv. cbn in eqmin. + rewrite min_premise_add in eqmin. + move: (h (add le x, succ_expr le)) => /fwd. + { exists (succ_expr le). split => //. + apply In_add_prems. exists le. split => //. + apply LevelExprSet.add_spec; now left. } + intros [hmin' [eqmin' lv']]. cbn in eqmin', lv'. + rewrite min_premise_add in eqmin'. + destruct (min_premise m x) eqn:mx. + * exists z. split => //. + destruct (min_atom_value m le) eqn:mina; cbn in * => //. + noconf eqmin; noconf eqmin'. + destruct le as [le lek]. destruct x0 as [x0 x0k]; cbn -[Z.add] in *. + destruct (level_value m le) => //. + Opaque Z.add. depelim lv'. depelim lv. rewrite H1. constructor. + noconf mina. lia. + * now apply min_opt_None_right in eqmin'. +Qed. + Import Semilattice. Lemma infer_correct cls : infer_correctness cls. Proof. @@ -152,20 +260,15 @@ Proof. { eapply enabled_clauses_ext. apply is_update_of_ext in isupd. exact isupd. apply init_model_enabled. } split => //. - unfold clauses_sem. - intros cl hin. - eapply valid_clause_model. now eapply encl in hin. - eapply Clauses.for_all_spec in ism; tc. now specialize (ism _ hin). - - intros [v clssem]. + - intros [v [en clssem]]. move: hi. - funelim (infer_model cls) => //. intros _. - red in islooping. - have sem := clauses_sem_entails_all islooping v0. - specialize (sem clssem). red in sem. - rewrite interp_add_prems in sem. - cbn [add Zsemilattice] in sem. - cbn [join Zadd_is_comm_monoid Zsemilattice] in sem. - Opaque Z.add. cbn in sem. lia. Transparent Z.add. + funelim (infer_model cls) => //. intros [=]. subst t0. + red in islooping. clear Heq Heqcall. + apply to_entails_all in islooping. + apply is_model_valid in clssem. + have hv := entails_all_model_valid clssem islooping. + eapply loop_invalid in hv; tea. + now apply enabled_clauses_le. Qed. Program Definition loop_check cls (cl : clause) : result (premises_model (clauses_levels cls) cl).1 LevelSet.empty cls (premises_model (clauses_levels cls) cl).2 := @@ -212,7 +315,7 @@ Equations check (cls : clauses) (cl : clause) : check_result cls := Definition check_clauses (cls : clauses) (cls' : clauses) : bool := let check_one cl := match check cls cl with - | IsLooping v isl => false + | IsLooping _ _ => false | Valid => true | Invalid => false end @@ -225,9 +328,8 @@ Theorem check_entails {cls cl} : Proof. destruct cl as [prems [concl k]]. funelim (check cls _) => // _. - set (V := clause_levels _ ∪ clauses_levels cls) in *. + set (V := (clause_levels _ ∪ clauses_levels cls)%levels) in *. clear Heqcall H. cbn [concl fst snd] in *. clear Heq0. - unfold valid_entailment, valid_clause, level_value_above. move/check_atom_value_spec: Heq; intros h; depelim h. rename H into hgt. have vmupd := model_updates v. have vmok := model_ok v. @@ -254,26 +356,40 @@ Proof. Qed. Lemma check_looping {cls cl v isl} : - check cls cl = IsLooping v isl -> ~ (exists V, clauses_sem V cls). + check cls cl = IsLooping v isl -> + ~ (exists m, defined_model_of (levels v) m /\ is_model cls m). Proof. - move/check_entails_looping/clauses_sem_entails_all => h [] V /h. - rewrite interp_add_prems. cbn -[Z.add]. lia. + move/check_entails_looping. + intros loop [m' [en clssem]]. + apply to_entails_all in loop. + apply is_model_valid in clssem. + have hv := entails_all_model_valid clssem loop. + eapply loop_invalid in hv; tea. + now apply enabled_clauses_le. Qed. -Lemma check_valid_looping {cls cl v isl m} : +(* Lemma check_valid_looping {cls cl m v isl} : enabled_clauses m cls -> is_model cls m -> check cls cl = IsLooping v isl -> False. Proof. - move=> en /(valid_clauses_model _ _ en) csem /check_looping; apply. - now eexists. -Qed. + move=> en ism. + rewrite /check /loop_check. + destruct loop. + + /check_looping; apply. + destruct def as [def isupd]. + exists m'. split => //. + move: isupd; move/is_update_of_case => []. + * move=> [] empw eq. rewrite -eq. + exists m. +Qed. *) Theorem check_invalid {cls cl} : check cls cl = Invalid -> ~ entails cls cl. Proof. funelim (check cls cl) => //. - set (V := clause_levels cl ∪ clauses_levels cls) in *. + set (V := (clause_levels cl ∪ clauses_levels cls)%levels) in *. destruct cl as [prems [concl k]]. rename val into conclval_v => _. clear H Heq0 Heqcall prf. cbn in he. move: (check_atom_value_spec (Some k) conclval_v). rewrite Heq. @@ -680,17 +796,23 @@ Module Abstract. intros [= <-]. now cbn. Qed. + Definition clause_sem {S} {SL : Semilattice S Q.t} V (cl : clause) : Prop := + let '(prems, concl) := cl in + le (interp_expr V concl) (interp_prems V prems). + + Definition clauses_sem {S} {SL : Semilattice S Q.t} V (cls : Clauses.t) : Prop := + Clauses.For_all (clause_sem V) cls. + Lemma enforce_clauses_inconsistent m cls u : enforce_clauses m cls = Some (inr u) -> - ~ exists V, clauses_sem V (Clauses.union (clauses m) cls). + entails_L (relations_of_clauses (Clauses.union (clauses m) cls)) (loop_univ u, succ_prems (loop_univ u)). + (* ~ exists V, clauses_sem (SL := Zsemilattice) V (Clauses.union (clauses m) cls). *) Proof. funelim (enforce_clauses m cls) => //=. - intros [= <-]. clear -u. intros [V cs]. - destruct u as [u loop]. - eapply clauses_sem_entails_all in loop; tea. - rewrite interp_add_prems in loop. - cbn -[Z.add] in loop. lia. - Qed. + intros [= <-]. clear -u. + destruct u as [u loop]. cbn [loop_univ]. + eapply Theory.to_entails_all in loop. + Admitted. Definition check_clauses m cls := check_clauses (clauses m) cls. @@ -707,7 +829,11 @@ Module Abstract. rewrite /check_clauses /Deciders.check_clauses. eapply Clauses.for_all_spec; tc => cl hin. destruct check eqn:hc => //. - * exfalso; eapply check_valid_looping; tea. + * exfalso; eapply check_entails_looping in hc; tea. + eapply Theory.to_entails_all in hc. + Search entails_L. + + 2:eapply m.(model).(model_valid).(model_ok). eapply enabled_clauses_ext, m.(model).(enabled_model). eapply (is_update_of_ext m.(model).(model_valid).(I.model_updates)). diff --git a/common/theories/LoopChecking/Expressions.v b/common/theories/LoopChecking/Expressions.v new file mode 100644 index 000000000..e69de29bb diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 9b5c775d9..2b6dd7941 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -167,7 +167,7 @@ Module Clauses (LS : LevelSets). Infix "⊂_clset" := Clauses.Subset (at level 70). Infix "=_clset" := Clauses.Equal (at level 70). - Definition clauses := Clauses.t. + Notation clauses := Clauses.t. Lemma filter_add {p x s} : Clauses.filter p (Clauses.add x s) =_clset if p x then Clauses.add x (Clauses.filter p s) else Clauses.filter p s. Proof. @@ -377,13 +377,14 @@ Module Clauses (LS : LevelSets). Definition max_clause_premise (cls : clauses) := Clauses.fold (fun cl acc => Z.max (premise_max (premise cl)) acc) cls 0%Z. + Local Open Scope Z_scope. + Definition gain (cl : clause) : Z := (concl cl).2 - (premise_min (premise cl)). Definition max_gain (cls : clauses) := Clauses.fold (fun cl acc => Nat.max (Z.to_nat (gain cl)) acc) cls 0%nat. - Lemma clauses_conclusions_diff cls s : clauses_conclusions (Clauses.diff cls (clauses_with_concl cls s)) ⊂_lset LevelSet.diff (clauses_conclusions cls) s. @@ -885,7 +886,7 @@ Module Clauses (LS : LevelSets). apply clause_levels_spec. left. apply NES.levels_spec. exists (k + n). destruct cl; cbn. apply In_add_prems. exists (l, k). - split => //. rewrite /add_expr. lia_f_equal. + split => //. rewrite /add_expr //=. lia_f_equal. * intros ->. exists (add_clause n cl); split => //. now apply add_clauses_spec. apply clause_levels_spec. right. destruct cl; cbn. destruct t0 => //. @@ -906,18 +907,6 @@ Module Clauses (LS : LevelSets). f_equal. lia. Qed. - Lemma add_prems_singleton n cl : add_prems n (singleton cl) = singleton (add_expr n cl). - Proof. - apply NES.equal_exprsets => [] [l k]. - rewrite In_add_prems LevelExprSet.singleton_spec. - firstorder. - - destruct x; noconf H0. - eapply LevelExprSet.singleton_spec in H. - now red in H; noconf H. - - destruct cl. exists (t, z). split => //. - red in H; noconf H. now apply LevelExprSet.singleton_spec. - Qed. - Lemma max_premise_of_spec_aux s l k : max_premise_of l s = k -> (forall k', LevelExprSet.In (l, k') s -> (Some k' ≤ k)) /\ @@ -1009,13 +998,22 @@ Module Clauses (LS : LevelSets). Definition entails_all cls (prems concls : premises) := LevelExprSet.For_all (fun le => entails cls (prems, le)) concls. - Definition entails_clauses cls cls' := + Definition entails_clauses (cls cls' : Clauses.t) := Clauses.For_all (entails cls) cls'. - Notation " cls ⊢ prems → concl " := (entails cls (prems, concl)) (at level 70). - Notation " cls ⊢a prems → concl " := (entails_all cls prems concl) (at level 70). + Declare Scope clause_scope. + Delimit Scope clause_scope with clause. + Bind Scope clause_scope with clause. + + Declare Scope clauses_scope. + Delimit Scope clauses_scope with cls. + Bind Scope clauses_scope with Clauses.t. + + Notation " cls ⊢ prems → concl " := (entails cls (prems%nes, concl)) (at level 70). + Notation " cls ⊢a prems → concl " := (entails_all cls prems%nes concl%nes) (at level 70). + Notation " cls '⊢ℋ' cls' " := (entails_clauses cls cls') (at level 72). (* \mscrH *) - Definition entails_equiv cls u u' := + Definition entails_equiv cls (u u' : NES.t) := cls ⊢a u → u' /\ cls ⊢a u' → u. Notation "cls '⊢a' u ↔ u'" := (entails_equiv cls u u') (at level 70). @@ -1036,6 +1034,47 @@ Module Clauses (LS : LevelSets). now apply NES.equal_exprsets. Qed. + (* Proper instances *) + + Instance in_pred_closure_proper : Proper (Clauses.Equal ==> Logic.eq ==> impl) in_pred_closure. + Proof. + intros cls cls' eq ? cl -> h. + induction h. + - constructor. now rewrite -eq. + - constructor. + Qed. + + Instance proper_entails : Proper (Clauses.Equal ==> Logic.eq ==> impl) entails. + Proof. + intros cls cls' eq ? cl -> h. + induction h. + - constructor; auto. + - econstructor 2; eauto. + now rewrite -eq. + Qed. + + Instance entails_all_proper : Proper (Clauses.Equal ==> Logic.eq ==> Logic.eq ==> iff) entails_all. + Proof. + intros cls cls' H ? ? <- ? ? <-. + split; intros ? ? hin. rewrite -H. now apply H0. + rewrite H; now apply H0. + Qed. + + Instance entails_clauses_proper : Proper (Clauses.Equal ==> Clauses.Equal ==> iff) entails_clauses. + Proof. + intros cls cls' H ? ? H'. + split; intros ? ? hin. rewrite -H. apply H0. now rewrite H'. + rewrite H; apply H0. now rewrite -H'. + Qed. + + Instance entails_equiv_proper : Proper (Clauses.Equal ==> Logic.eq ==> Logic.eq ==> iff) entails_equiv. + Proof. + intros cls cls' H ? ? <- ?? <-. + split. + - intros []; split; now rewrite -H. + - intros []; split; now rewrite H. + Qed. + Lemma entails_plus cls c : entails cls c -> entails (succ_clauses cls) (succ_clause c). Proof. induction 1. @@ -1045,6 +1084,7 @@ Module Clauses (LS : LevelSets). * have -> : (succ_prems prems', succ_expr concl') = add_clause n (succ_clause cl). { destruct cl as [prems'' concl'']. cbn in H0. noconf H0. rewrite add_prems_add_prems add_expr_add_expr add_clause_add_clause. + rewrite /add; cbn -[Z.add]. now rewrite Z.add_1_r Z.add_1_l. } constructor. now rewrite -add_clauses_spec. * have eq : (succ_prems (singleton (x, (k + 1)))) = (singleton (x, k + 1 + 1)). @@ -1053,11 +1093,12 @@ Module Clauses (LS : LevelSets). split. { intros [? [hin ->]]. rewrite LevelExprSet.singleton_spec in hin. red in hin; subst x0. - red. rewrite /succ_expr. lia_f_equal. } + red. rewrite /succ_expr. cbn -[Z.add]; lia_f_equal. } { unfold LevelExprSet.E.eq. intros ->. exists (x, k + 1). split. - now rewrite LevelExprSet.singleton_spec. rewrite /succ_expr. lia_f_equal. } } - rewrite eq /succ_expr. rewrite Z.add_comm !(Z.add_comm 1 k) (Z.add_comm 1). constructor. + now rewrite LevelExprSet.singleton_spec. rewrite /succ_expr. + cbn -[Z.add]; lia_f_equal. } } + rewrite eq /succ_expr. cbn -[Z.add]; rewrite Z.add_comm !(Z.add_comm 1 k) (Z.add_comm 1). constructor. + unfold succ_clause in IHentails. eapply entails_equal; tea. intros x. rewrite /succ_prems. rewrite NES.map_spec NES.add_spec. @@ -1091,7 +1132,8 @@ Module Clauses (LS : LevelSets). - rewrite Z.add_0_r. tauto. - intros hen. rewrite Nat2Z.inj_succ in hen. rewrite Z.add_succ_r in hen. eapply IHn. move: hen. - have -> : Z.succ (k + Z.of_nat n) = 1 + (k + Z.of_nat n) by lia. + cbn -[Z.add]. + have -> : Z.succ (k + Z.of_nat n)%Z = 1 + (k + Z.of_nat n) by lia. eapply entails_pred_closure. Qed. @@ -1223,14 +1265,6 @@ Module Clauses (LS : LevelSets). now eapply entails_weak. Qed. - Lemma add_prems_union {n u u'} : add_prems n (u ∪ u') = union (add_prems n u) (add_prems n u'). - Proof. - apply equal_exprsets => l. - rewrite In_add_prems. - rw union_spec. - rewrite !In_add_prems. firstorder. - Qed. - Lemma entails_all_weak {cls prem concl concl'} : entails_all cls prem concl -> entails_all cls (add concl' prem) concl. @@ -1424,8 +1458,8 @@ Module Clauses (LS : LevelSets). move: (cla (add_expr n cl)) => /fwd. rewrite In_add_prems. exists cl; split => //. move/(entails_shift (- n)) => //=. - rewrite !add_prems_add_prems add_expr_add_expr. - have -> : (- n + n = 0) by lia. + rewrite !add_prems_add_prems add_expr_add_expr; cbn -[Z.add]. + have -> : (- n + n = 0)%Z by lia. now rewrite add_prems_0 //= add_expr_0. Qed. @@ -1461,6 +1495,15 @@ Module Clauses (LS : LevelSets). now move/d/entails_clauses_subset. Qed. + Lemma entails_ℋ_clauses_subset cls cls' cls'' : + cls ⊢ℋ cls' -> + cls ⊂_clset cls'' -> + cls'' ⊢ℋ cls'. + Proof. + move=> ha hsub [prems concl] /ha ent. + eapply entails_clauses_subset; tea. + Qed. + Lemma entails_succ cls (u v : premises) : (forall l k, LevelExprSet.In (l, k) v -> exists k', LevelExprSet.In (l, k') u /\ k <= k') -> cls ⊢a u → v. @@ -1490,6 +1533,7 @@ Module Clauses (LS : LevelSets). eapply entails_all_trans. tea. rewrite add_prems_add_prems in IHn. have eq : 1 + Z.of_nat (S n) = Z.of_nat (S (S n)) by lia. + cbn -[Z.add] in *. now rewrite eq in IHn. Qed. @@ -1514,6 +1558,7 @@ Module Clauses (LS : LevelSets). apply loop_any_successor. - intros _ [l k]. rewrite In_add_prems. intros [[] [hin heq]]. rewrite /add_expr in heq. noconf heq. + cbn -[Z.add]. rewrite Z.add_comm. apply entails_pred_closure_neg. now constructor. @@ -1533,13 +1578,16 @@ Module Clauses (LS : LevelSets). eapply in_add_clauses in H as [[prems' concl'] [hin heq]]. noconf heq. eapply (clause_cut _ (add_prems n prems') (add_expr n concl')). 2:eapply IHha. - 2:{ f_equal. rewrite !add_expr_add_expr. now rewrite add_prems_add add_expr_add_expr Z.add_comm. } + 2:{ f_equal. rewrite !add_expr_add_expr. cbn -[Z.add]; now rewrite add_prems_add add_expr_add_expr Z.add_comm. } exact: (incls cls (prems', concl') n hin). - rewrite add_prems_add_prems in H1. rewrite Z.add_comm in H1. + rewrite add_prems_add_prems in H1. + cbn -[Z.add] in H1. + rewrite Z.add_comm in H1. rewrite -(add_prems_add_prems 1 n prems') in H1. now move/inj_add_prems_sub: H1. + specialize (H0 (x, k + 1)). forward H0. now apply LevelExprSet.singleton_spec. eapply In_add_prems in H0 as [[l' k'] [hin heq]]. noconf heq. + cbn -[Z.add] in *. have eq: k' = k by lia. subst k'. clear H. eapply clause_cut. 2:eapply IHha. eapply (predcl _ x (k - 1)). 2:{ intros x'. move/LevelExprSet.singleton_spec => ->. now have -> : k - 1 + 1 = k by lia. } @@ -1595,9 +1643,79 @@ Module Clauses (LS : LevelSets). apply entails_all_succ. Qed. + Lemma entails_cut {cls cl cl'} : + entails cls cl -> + entails (Clauses.add cl cls) cl' -> + entails cls cl'. + Proof. + intros ent ent'. + induction ent'. + - now constructor. + - depelim H. + * eapply Clauses.add_spec in H as [->|hin]. + destruct cl as [prems2 concl2]. noconf H0. + + apply: (@entails_add cls prems (add_expr n concl2) _ _ IHent'). + eapply entails_subset; tea. + now eapply (@entails_shift _ (_, _) n). + + destruct cl0 as [prems'' concl'']; noconf H0. + have h := (@entails_add cls prems (add_expr n concl'') _ _ IHent'). + apply h. + eapply entails_subset; tea. + eapply (@entails_shift _ (_, _) n). + now eapply entails_in. + * apply: (@entails_add cls prems (x, k)). + eapply clause_cut; tea. + { constructor 2; tea. } + { constructor. now rewrite LevelExprSet.add_spec; left. } + assumption. + Qed. + + Lemma entails_clauses_cut_one {cls cls0 cl} : + cls ⊢ℋ cls0 -> + entails (Clauses.union cls0 cls) cl -> + entails cls cl. + Proof. + move: cls0 cls cl. apply: ClausesProp.set_induction. + - intros s he cls0 cl ent. + have -> : Clauses.union s cls0 =_clset cls0. + { clsets. } + by []. + - move=> s0 s1 ih x hin hadd s2 cl ent. + have s0ent : s2 ⊢ℋ s0. + { move=> cl' hin'. apply ent, hadd. now right. } + specialize (ih s2 cl s0ent). + rewrite ClausesProp.Add_Equal in hadd. + rewrite hadd in ent. do 2 red in ent. + rewrite hadd ClausesProp.add_union_singleton ClausesProp.union_assoc -ClausesProp.add_union_singleton. + move: (ent x) => /fwd. now apply Clauses.add_spec. + move=> entx. destruct x as [prems concl]. + eapply (entails_clauses_subset _ (Clauses.union s0 s2)) in entx. + 2:{ clsets. } + move=> ent'. apply ih. + eapply entails_cut; tea. + Qed. + + Lemma entails_clauses_cut {cls cls0 cls1} : + cls ⊢ℋ cls0 -> + Clauses.union cls0 cls ⊢ℋ cls1 -> + cls ⊢ℋ cls1. + Proof. + move=> ent ent' cl /ent' hin. + eapply entails_clauses_cut_one; tea. + Qed. + + Infix "∨" := union (at level 30). + Notation succ x := (add_prems 1%Z x). + Definition clauses_of_le l r := LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) (NES.t_set l) Clauses.empty. + Definition clauses_of_eq (u v : NES.t) := + Clauses.union (clauses_of_le u v) (clauses_of_le v u). + + Notation " s ⋞ t " := (clauses_of_le s t) (at level 70) : clauses_scope. (* \curlyeqprec *) + Notation " s ≡ t " := (clauses_of_eq s t) (at level 70) : clauses_scope. (* \allequal *) + Lemma clauses_of_le_spec l r : forall cl, Clauses.In cl (clauses_of_le l r) <-> LevelExprSet.Exists (fun lk => cl = (r, lk)) l. @@ -1614,19 +1732,15 @@ Module Clauses (LS : LevelSets). rewrite ih. right; firstorder. Qed. - Infix "∨" := union (at level 30). - Notation succ x := (add_prems 1%Z x). - - Definition clauses_of_eq (u v : NES.t) := - Clauses.union (clauses_of_le u v) (clauses_of_le v u). - - Declare Scope clauses_scope. - Delimit Scope clauses_scope with cls. - Bind Scope clauses_scope with Clauses.t. - - Notation " s ⋞ t " := (clauses_of_le s t) (at level 70) : clauses_scope. (* \curlyeqprec *) - Notation " s ≡ t " := (clauses_of_eq s t) (at level 70) : clauses_scope. (* \allequal *) - Notation " cls '⊢ℋ' cls' " := (entails_clauses cls cls') (at level 72). (* \mscrH *) + Lemma to_entails_all {cls s t} : + cls ⊢ℋ s ⋞ t <-> cls ⊢a t → s. + Proof. + split. + - intros hs l hin. apply (hs (t, l)). + apply clauses_of_le_spec. now exists l. + - intros ha l. rewrite clauses_of_le_spec. + intros [lk [hin ->]]. now apply ha. + Qed. Definition le (t u : NES.t) : Clauses.t := t ∨ u ≡ u. @@ -1643,16 +1757,6 @@ Module Clauses (LS : LevelSets). now rewrite Clauses.union_spec. Qed. - Lemma to_entails_all {cls s t} : - cls ⊢ℋ s ⋞ t <-> cls ⊢a t → s. - Proof. - split. - - intros hs l hin. apply (hs (t, l)). - apply clauses_of_le_spec. now exists l. - - intros ha l. rewrite clauses_of_le_spec. - intros [lk [hin ->]]. now apply ha. - Qed. - Lemma to_entails_equiv {cls s t} : cls ⊢ℋ s ≡ t <-> cls ⊢a t ↔ s. Proof. @@ -1803,7 +1907,7 @@ Module Clauses (LS : LevelSets). Lemma succ_join {cls n s t} : cls ⊢ℋ add_prems n (s ∨ t) ≡ add_prems n s ∨ add_prems n t. Proof. - rewrite add_prems_union; auto with entails. + rewrite NES.add_prems_union; auto with entails. Qed. Lemma join_congr_left {cls r s t} : @@ -1831,7 +1935,6 @@ Module Clauses (LS : LevelSets). Section prems_semi. Obligation Tactic := idtac. - Import CommutativeMonoid. Import Semilattice (Semilattice, eq, add, join). Context (cls : Clauses.t). diff --git a/common/theories/LoopChecking/HornSemilatticeEquiv.v b/common/theories/LoopChecking/HornSemilatticeEquiv.v new file mode 100644 index 000000000..f524eefbe --- /dev/null +++ b/common/theories/LoopChecking/HornSemilatticeEquiv.v @@ -0,0 +1,375 @@ +(* Distributed under the terms of the MIT license. *) +From Stdlib Require Import ssreflect ssrbool ssrfun ZArith. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils NonEmptyLevelExprSet SemiLattice. + +From MetaRocq.Common Require Universes. +From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses InitialSemilattice. +From Equations Require Import Equations. +Set Equations Transparent. + +Module HornSemilattice (LS : LevelSets). + Module Export Clauses := Clauses LS. + Module Export SL := InitialSemilattice LS. + Import NES. + + Local Open Scope sl_scope. + + Definition relations_of_clauses c := + Clauses.fold (fun '(prems, concl) acc => (NES.union (singleton concl) prems, prems) :: acc) c []. + + Definition clauses_of_relations r := + List.fold_right (fun '(l, r) acc => Clauses.union (clauses_of_eq l r) acc) Clauses.empty r. + + Lemma clauses_of_relations_spec {rels} : + forall cl, Clauses.In cl (clauses_of_relations rels) -> + exists r, In r rels /\ Clauses.In cl (clauses_of_eq r.1 r.2). + Proof. + rewrite /clauses_of_relations. + induction rels; cbn. + - clsets. + - move=> cl. destruct a as [l r]; cbn in *. + rewrite Clauses.union_spec => -[]. + * rewrite /clauses_of_eq Clauses.union_spec => -[inl|inr]; cbn; + rw Clauses.union_spec; cbn. + exists (l, r). split => //. now left. cbn. now left. + exists (l, r). split => //. now left. cbn. now right. + * move/IHrels => [[l' r'] [hin]]; cbn in *. + rewrite /clauses_of_eq Clauses.union_spec => -[inl|inr]; cbn; + rw Clauses.union_spec; now exists (l', r'); split => //. + Qed. + + Lemma clauses_of_relations_spec_inv {rels} : + forall r, In r rels -> + Clauses.Subset (clauses_of_eq r.1 r.2) (clauses_of_relations rels). + Proof. + rewrite /clauses_of_relations. + induction rels; cbn. + - clsets. + - move=> [l r] //= []. + * move=> -> ?. rewrite Clauses.union_spec; now left. + * move/IHrels => //= hin ?. destruct a as [l' r']. + rewrite Clauses.union_spec; now right. + Qed. + + Lemma relations_of_clauses_spec {cls} : + forall eq, In eq (relations_of_clauses cls) -> + exists prems concl, Clauses.In (prems, concl) cls /\ + eq = (singleton concl ∨ prems, prems). + Proof. + rewrite /relations_of_clauses. + eapply ClausesProp.fold_rec. + - move=> s'he eq => //=. + - move=> x a s' s'' hin hnin hadd ih eq. + destruct x as [prems concl]. cbn. + intros [<-|ina]. + * do 2 eexists. split => //. apply hadd. now left. + * move: (ih _ ina) => [? [? []]]. do 2 eexists; split => //. + apply hadd. now right. assumption. + Qed. + + Lemma relations_of_clauses_spec_inv {cls} : + forall cl, Clauses.In cl cls -> + In (singleton (concl cl) ∨ premise cl, premise cl) (relations_of_clauses cls). + Proof. + rewrite /relations_of_clauses. + eapply ClausesProp.fold_rec. + - move=> s'he eq => //=. + - move=> x a s' s'' hin hnin hadd ih eq. + destruct x as [prems concl]. cbn. + rewrite hadd. + intros [<-|ina]. + * cbn. now left. + * move: (ih _ ina) => insing. now right. + Qed. + + Definition entails_L_clause p cl := + p ⊢ℒ singleton (concl cl) ≤ premise cl. + + Definition entails_L_clauses cls cls' := + Clauses.For_all (entails_L_clause (relations_of_clauses cls)) cls'. + + Lemma entails_L_idem_gen {le} {prems : premises} {p} : + LevelExprSet.In le prems -> + p ⊢ℒ (singleton le) ∨ prems ≡ prems. + Proof. + move: prems; apply: NES.elim. + - move=> le' /LevelExprSet.singleton_spec <-. + apply entails_idem. + - move=> le' x hin hnin /LevelExprSet.add_spec []. + * unfold LevelExprSet.E.eq in *; intros eq; subst le'. + rewrite union_comm union_add_singleton. + rewrite add_idem. apply entails_refl. + * move/hin => heq. + rewrite -!union_add_singleton -union_assoc. + now apply entails_join_congr. + Qed. + + Lemma in_pred_closure_entails_L {cls} cl : + in_pred_closure cls cl -> + entails_L_clause (relations_of_clauses cls) cl. + Proof. + induction 1. + - rewrite /entails_L_clause /rel_le. + destruct cl as [prems concl]; cbn. + rewrite -add_prems_singleton -add_prems_union. + apply entails_add_congr. + apply entails_c. now eapply (relations_of_clauses_spec_inv (prems, concl)). + - replace (x, (k + 1)%Z) with (add_expr 1%Z (x, k)). + rewrite -add_prems_singleton. red; cbn. + eapply entails_sub. + now rewrite /succ_expr Z.add_comm. + Qed. + + Lemma entails_entails_L {cls} cl : + entails cls cl -> + entails_L_clause (relations_of_clauses cls) cl. + Proof. + intros h; induction h. + - red. + now apply entails_L_idem_gen. + - move: IHh; rewrite -!union_add_singleton. + eapply in_pred_closure_entails_L in H. + rewrite /entails_L_clause in H |- *; cbn in *. + have hsub:= entails_L_subset H H0. + move=> h'. + eapply entails_L_le_trans. tea. + move/entails_L_eq_le_1: hsub. now rewrite union_comm. + Qed. + + Theorem entails_ℋ_entails_L {cls} cls' : + cls ⊢ℋ cls' -> + entails_L_clauses cls cls'. + Proof. + move=> h cl /h. apply entails_entails_L. + Qed. + + Lemma in_pred_closure_entails_clause {cls cl} : + in_pred_closure cls cl -> + entails cls cl. + Proof. + destruct cl as [prems concl]; intros inp. + eapply clause_cut; trea. + constructor. now apply NES.add_spec. + Qed. + + Lemma in_clause_of_le {le} {l r : premises} : + LevelExprSet.In le l <-> + Clauses.Clauses.In (r, le) (l ⋞ r). + Proof. + rewrite clauses_of_le_spec. + split. + - exists le. split => //. + - intros [lk [hin [=]]]. now subst le. + Qed. + + Lemma entails_ℋ_entails_L_eq_left {p l r} : + In (l, r) p -> + clauses_of_relations p ⊢a r → l. + Proof. + intros hin l' cl. + eapply in_pred_closure_entails_clause, incls0. + eapply clauses_of_relations_spec_inv. tea. cbn. + rewrite /clauses_of_eq Clauses.union_spec. left. + apply clauses_of_le_spec. now exists l'. + Qed. + + Lemma entails_ℋ_entails_L_eq_right {p l r} : + In (l, r) p -> + clauses_of_relations p ⊢a l → r. + Proof. + intros hin l' cl. + eapply in_pred_closure_entails_clause, incls0. + eapply clauses_of_relations_spec_inv. tea. cbn. + rewrite /clauses_of_eq Clauses.union_spec. right. + apply clauses_of_le_spec. now exists l'. + Qed. + + Lemma entails_clauses_eq_pres {p l r} : + In (l, r) p -> + clauses_of_relations p ⊢ℋ l ≡ r. + Proof. + intros hin. + apply Theory.eq_antisym. + split. + - rewrite to_entails_all. now apply entails_ℋ_entails_L_eq_left. + - rewrite to_entails_all. now apply entails_ℋ_entails_L_eq_right. + Qed. + + Theorem entails_L_entails {p r} : + p ⊢ℒ r -> + clauses_of_relations p ⊢ℋ clauses_of_eq r.1 r.2. + Proof. + intros h; depind h; cbn. + * now eapply entails_clauses_eq_pres. + * eapply Theory.eq_refl. + * now eapply Theory.eq_sym. + * now eapply Theory.eq_trans. + * now eapply Theory.succ_congr. + * now eapply Theory.succ_inj in IHh. + * now eapply Theory.join_congr_left. + * eapply Theory.join_assoc. + * eapply Theory.join_idem. + * eapply Theory.join_comm. + * eapply Theory.join_succ. + * eapply Theory.succ_join. + Qed. + + Lemma entails_L_split p (s t : premises) : + (forall le, LevelExprSet.In le s -> p ⊢ℒ singleton le ≤ t) -> + p ⊢ℒ s ≤ t. + Proof. + move: s; apply: NES.elim. + - intros [l k] ih. eapply ih. + now apply LevelExprSet.singleton_spec. + - move=> le x h hnin ih. + forward h. + { move=> le' hin. move: (ih le') => /fwd //. + eapply LevelExprSet.add_spec. now right. } + specialize (ih le); forward ih. + eapply LevelExprSet.add_spec; now left. + rewrite -union_add_singleton. + now eapply entails_L_le_join. + Qed. + + Lemma entails_L_clauses_pres_all {p s t} : + (relations_of_clauses (clauses_of_relations p)) ⊢ℒ s ≡ t -> + p ⊢ℒ s ≡ t. + Proof. + induction 1; try solve [econstructor; eauto]. cbn in H. + move/relations_of_clauses_spec: H => [prems [concl [hin heq]]]. + noconf heq. + move/clauses_of_relations_spec: hin => [[l r]] [] hin //=. + rewrite /clauses_of_eq Clauses.union_spec => -[] hin'; + eapply entails_L_le_eq; + rewrite clauses_of_le_spec in hin'. + - destruct hin' as [? [hin' heq]]. noconf heq. + eapply entails_L_le_trans with l. + * now eapply entails_L_in. + * eapply entails_L_eq_le_1. now constructor. + - destruct hin' as [? [hin' heq]]; noconf heq. + eapply entails_L_le_trans with r. + + now eapply entails_L_in. + + eapply entails_L_eq_le_1. eapply entails_sym. now constructor. + Qed. + + Lemma entails_L_clauses_pres_le {p s t} : + entails_L_clauses (clauses_of_relations p) (s ⋞ t) -> + p ⊢ℒ s ≤ t. + Proof. + intros hf. do 2 red in hf. + rw_in clauses_of_le_spec hf. + eapply entails_L_split. + move=> le hin. + move: (hf (t, le)) => /fwd. + { exists le; split => //. } + move=> h; red in h. cbn in h. + now eapply entails_L_clauses_pres_all in h. + Qed. + + Lemma entails_L_clauses_of_relations_eq {p s t} : + entails_L_clauses (clauses_of_relations p) (s ≡ t) -> + p ⊢ℒ s ≡ t. + Proof. + intros hf. do 2 red in hf. + eapply entails_L_eq_antisym. + all: apply entails_L_clauses_pres_le. + - intros cl hin; red. eapply hf. + rewrite /clauses_of_eq. clsets. + - intros cl hin; red. eapply hf. + rewrite /clauses_of_eq. clsets. + Qed. + + Lemma completeness_eq p s t : + p ⊢ℒ s ≡ t <-> + clauses_of_relations p ⊢ℋ clauses_of_eq s t. + Proof. + split. + - move/entails_L_entails => //=. + - move/entails_ℋ_entails_L. + by apply entails_L_clauses_of_relations_eq. + Qed. +(* + Lemma entails_L_clause_entails {cls cl} : + entails_L_clause (relations_of_clauses cls) cl -> + entails cls cl. + Proof. *) + + Lemma clauses_of_relations_relations_of_clauses {cls} : cls ⊂_clset (clauses_of_relations (relations_of_clauses cls)). + Proof. + intros cl. + move/relations_of_clauses_spec_inv/clauses_of_relations_spec_inv => //=; apply. + rewrite /clauses_of_eq Clauses.union_spec. left. + eapply clauses_of_le_spec. exists (concl cl). split => //. rewrite LevelExprSet.union_spec. left; now apply LevelExprSet.singleton_spec. + now destruct cl. + Qed. + + Lemma entails_all_singleton cls prems concl : + cls ⊢a prems → singleton concl <-> cls ⊢ prems → concl. + Proof. + split. + - move/(_ concl) => /fwd //. now apply LevelExprSet.singleton_spec. + - move=> cl cl' /LevelExprSet.singleton_spec. intros e; red in e; now subst cl'. + Qed. + + Lemma entails_ℋ_singleton cls prems concl : + cls ⊢ℋ singleton concl ⋞ prems <-> cls ⊢ prems → concl. + Proof. + rewrite to_entails_all. apply entails_all_singleton. + Qed. + + Lemma entails_ℋ_clauses_of_relations {cls cls'} : + clauses_of_relations (relations_of_clauses cls) ⊢ℋ cls' -> + cls ⊢ℋ cls'. + Proof. + move=> ha. eapply (entails_clauses_cut (cls0 := clauses_of_relations (relations_of_clauses cls))); revgoals. + eapply entails_ℋ_clauses_subset; tea. + { intros ?; rewrite Clauses.union_spec; now left. } + intros cl. + move/clauses_of_relations_spec => [] [l r] [] //= /relations_of_clauses_spec [] prems [] concl [] hin [=] -> ->. + have eq : cls ⊢ℋ (singleton concl ∪ prems) ≡ prems. + apply Theory.le_spec, to_entails_all, entails_all_singleton. + now eapply entails_in. + now move/eq. + Qed. + + (* - move/clauses_of_relations_spec => [] [l r] [] /relations_of_clauses_spec [] prems [] [concl k] [] incls [=] -> -> //=. + rewrite /clauses_of_eq Clauses.union_spec. !clauses_of_le_spec => -[[lk [hin heq]]|[lk [hin heq]]]. + * subst cl. + exists (concl cl). split => //. rewrite LevelExprSet.union_spec. left; now apply LevelExprSet.singleton_spec. + *) + + Lemma entails_L_entails_ℋ {cls} cls' : + entails_L_clauses cls cls' -> + cls ⊢ℋ cls'. + Proof. + move=> hcl cl /hcl. + move/entails_L_entails => //=. + move/entails_ℋ_clauses_of_relations/Theory.eq_antisym => -[] + _. + move/Theory.join_le_left => -[] + _. + move/entails_ℋ_singleton. + now destruct cl. + Qed. + + Lemma entails_L_clauses_eq {p s t} : + entails_L_clauses p (s ≡ t) <-> + entails_L_clauses p (s ⋞ t) /\ entails_L_clauses p (t ⋞ s). + Proof. + rewrite /entails_L_clauses /clauses_of_eq. + split. + - intros ha; split => l; move:(ha l); rewrite Clauses.union_spec; + intros he hle; apply he; now constructor. + - intros [le le'] l. + rewrite Clauses.union_spec; intros []; [apply le|apply le']; assumption. + Qed. + + Theorem entails_L_entails_ℋ_equiv {cls cls'} : + entails_L_clauses cls cls' <-> cls ⊢ℋ cls'. + Proof. + split. + - apply entails_L_entails_ℋ. + - apply entails_ℋ_entails_L. + Qed. + +End HornSemilattice. diff --git a/common/theories/LoopChecking/InitialSemilattice.v b/common/theories/LoopChecking/InitialSemilattice.v new file mode 100644 index 000000000..27973349c --- /dev/null +++ b/common/theories/LoopChecking/InitialSemilattice.v @@ -0,0 +1,743 @@ +(* Distributed under the terms of the MIT license. *) +From Stdlib Require Import ssreflect ssrbool ssrfun ZArith. +From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. +From MetaRocq.Utils Require Import utils NonEmptyLevelExprSet SemiLattice. + +From MetaRocq.Common Require Universes. +From MetaRocq.Common.LoopChecking Require Import Common Interfaces. +From Equations Require Import Equations. +Set Equations Transparent. + +Module InitialSemilattice (LS : LevelSets). + Import Q. + Existing Instance comm_monoid. + Existing Instance add_inj_eq. + Export LS. + Import NES.OfQ. + Local Open Scope quantity. + Import NES. + Open Scope nes_scope. + + Import Semilattice. + Import CommutativeMonoid. + Existing Instance OfQ.add_inj_le. + + Definition rel := t × t. + + Declare Scope rel_scope. + Delimit Scope rel_scope with rel. + Bind Scope rel_scope with rel. + Open Scope rel_scope. + + Definition rels := list rel. + + Record presentation := + { V : LevelSet.t; + C : list (NES.t × NES.t); }. + + Infix "∨" := NES.union (at level 30) : nes_scope. + Open Scope nes_scope. + + Definition rel_eq (x y : t) : rel := (x, y). + Definition rel_le (x y : t) : rel := ((x ∨ y)%nes, y). + + Infix "≡" := rel_eq (at level 70, no associativity) : rel_scope. + Infix "≤" := rel_le (at level 50, no associativity) : rel_scope. + + Reserved Notation " p ⊢ℒ r " (at level 72, no associativity). + + Inductive entails_L (p : rels) : NES.t × NES.t -> Prop := + | entails_c {l r} : List.In (l, r) p -> p ⊢ℒ l ≡ r + | entails_refl {x} : p ⊢ℒ x ≡ x + | entails_sym {x y} : p ⊢ℒ x ≡ y -> p ⊢ℒ y ≡ x + | entails_trans {x y z} : p ⊢ℒ x ≡ y -> p ⊢ℒ y ≡ z -> p ⊢ℒ x ≡ z + | entails_add_congr {x y n} : p ⊢ℒ x ≡ y -> p ⊢ℒ add_prems n x ≡ add_prems n y + | entails_add_inj {n x y} : p ⊢ℒ (add_prems n x) ≡ (add_prems n y) -> p ⊢ℒ x ≡ y + | entails_join_congr {x y r} : p ⊢ℒ x ≡ y -> p ⊢ℒ (x ∨ r) ≡ (y ∨ r) + | entails_assoc {x y z} : p ⊢ℒ ((x ∨ y) ∨ z) ≡ (x ∨ (y ∨ z)) + | entails_idem {x} : p ⊢ℒ (x ∨ x) ≡ x + | entails_comm {x y} : p ⊢ℒ (x ∨ y) ≡ (y ∨ x) + | entails_sub {x} : p ⊢ℒ (x ∨ add_prems one x) ≡ (add_prems one x) + | entails_add_join {n x y} : p ⊢ℒ (add_prems n (x ∨ y)) ≡ (add_prems n x ∨ add_prems n y) + where " p ⊢ℒ r " := (entails_L p r%_rel). + Derive Signature for entails_L. + + Lemma entails_join_congr_all {p} {x x' y y'} : + p ⊢ℒ x ≡ x' -> p ⊢ℒ y ≡ y' -> p ⊢ℒ (x ∨ y) ≡ (x' ∨ y'). + Proof. + intros he he'. + eapply entails_trans with (x' ∨ y). + now apply entails_join_congr. + rewrite (@union_comm x' y) (@union_comm x' y'). + now apply entails_join_congr. + Qed. + + Lemma entails_join_congr_all_inv {p} {x x' y z} : p ⊢ℒ (x ∨ y) ≡ z -> p ⊢ℒ x ≡ x' -> p ⊢ℒ (x' ∨ y) ≡ z. + Proof. + intros he he'. + eapply entails_trans with (x ∨ y) => //. + apply entails_join_congr => //. now eapply entails_sym. + Qed. + + Lemma entails_join_congr_all_inv_r {p} {x y y' z} : p ⊢ℒ (x ∨ y) ≡ z -> p ⊢ℒ y ≡ y' -> p ⊢ℒ (x ∨ y') ≡ z. + Proof. + intros he he'. + eapply entails_trans with (x ∨ y) => //. + rewrite !(@union_comm x). + apply entails_join_congr => //. now eapply entails_sym. + Qed. + + Section pres_Semilattice. + Import Semilattice. + Context (p : presentation). + + Definition relations (c : list (NES.t × NES.t)) : Prop := + List.Forall (fun '(l, r) => l = r) c. + + + Definition univ_le (u u' : t) := + forall l k, LevelExprSet.In (l, k) u -> exists k', LevelExprSet.In (l, k') u /\ (OfQ.le k k'). + + Definition univ_eq u u' := + univ_le u u' /\ univ_le u' u. + + Infix "≌" := univ_eq (at level 70, no associativity). + + Lemma univ_le_refl u u' : u = u' -> univ_le u u'. + Proof. + intros <- l k hin; exists k; split => //. reflexivity. + Qed. + + Lemma univ_eq_refl u u' : u = u' -> univ_eq u u'. + Proof. + split; apply univ_le_refl; tea. now symmetry. + Qed. + + Lemma univ_eq_sym u u' : univ_eq u u' -> univ_eq u' u. + Proof. + move=> [] le le'. split; auto. + Qed. + + Lemma univ_eq_trans u u' u'' : univ_eq u u' -> univ_eq u' u'' -> univ_eq u u''. + Proof. + move=> [] le le' [] le0 le0'. split; auto. + Qed. + + Lemma univ_add_le_inj {n u v} : univ_le (add_prems n u) (add_prems n v) -> univ_le u v. + Proof. + intros hle l k hin. + red in hle. + specialize (hle l). + specialize (hle (CommutativeMonoid.add n k)). + move: hle => /fwd. + { apply In_add_prems. exists (l, k); split => //. } + move=> [] k' [] /In_add_prems [] [] l' k2 [] inu [=] -> -> hle'. + exists k2. split => //. + now apply (inj k k2). + Qed. + + Lemma univ_add_inj {n u v} : univ_eq (add_prems n u) (add_prems n v) -> univ_eq u v. + Proof. + move=> [] le le'. split; eauto using univ_add_le_inj. + Qed. + + (* To model subsumption correctly, we need a larger relation than Leibniz equality. + In other words, (x ∨ add 1 x) <> add 1 x. *) + Equations? pres_semilattice : Semilattice NES.t Q.t := + pres_semilattice := + {| eq x y := relations p.(C) -> univ_eq x y; + add := add_prems; + join x y := x ∪ y |}. + Proof. + all:intros. + - split; red; intros. + * now apply univ_eq_refl. + * now apply univ_eq_sym, H. + * now eapply univ_eq_trans; eauto. + - rewrite add_prems_add_prems. now apply univ_eq_refl. + - specialize (H H0). destruct H as [le le']. + split; move=> l k /In_add_prems => -[[l' k'] [hin [=]]] -> ->. + * exists (CommutativeMonoid.add n k'). split => //. apply In_add_prems. + exists (l', k'). split => //. reflexivity. + * exists (CommutativeMonoid.add n k')%Q; split => //. apply In_add_prems. + exists (l', k'); split => //. reflexivity. + - rewrite add_prems_0. now apply univ_eq_refl. + - apply univ_eq_refl. now rewrite union_assoc. + - apply univ_eq_refl. now rewrite union_comm. + - split. intros l k; rewrite !LevelExprSet.union_spec. + intros []; exists k; split => //; try lia. + now rewrite union_spec. reflexivity. + now rewrite union_spec. reflexivity. + intros l k hin. exists k. split => //. reflexivity. + - split. intros l k; rewrite !LevelExprSet.union_spec. + intros []; exists k; split => //; try lia; + now rewrite ?union_spec. + intros l k hin. exists k. split => //. reflexivity. + - split. intros l k hin. exists k. split => //. reflexivity. + intros l k hin. exists k. split => //; reflexivity. + - specialize (H H0). now eapply univ_add_inj. + - apply univ_eq_refl. now rewrite add_prems_union. + Qed. + End pres_Semilattice. + + Hint Constructors entails_L : entails_L. + + Lemma entails_L_le_refl p x : + p ⊢ℒ x ≤ x. + Proof. + eapply entails_idem. + Qed. + + Lemma entails_L_le_trans p x y z : + p ⊢ℒ x ≤ y -> p ⊢ℒ y ≤ z -> p ⊢ℒ x ≤ z. + Proof. + intros le le'. + eapply entails_trans. 2:exact le'. + eapply entails_trans with (x ∨ y ∨ z). + rewrite union_assoc. eapply entails_sym. + eapply entails_join_congr_all => //. apply entails_refl. + rewrite union_assoc. + eapply entails_trans with (x ∨ ((y ∨ y) ∨ z)). + eapply entails_join_congr_all; auto with entails_L. + rewrite union_assoc -union_assoc. + now eapply entails_join_congr_all. + Qed. + + Lemma subset_union {u u' : t} : + u ⊂_leset u' -> u ∨ u' = u'. + Proof. + intros hincl; apply equal_exprsets => l. + rewrite union_spec. firstorder. + Qed. + + Lemma incl_entails_L {cls} {u u' : t} : + u ⊂_leset u' -> cls ⊢ℒ u ≤ u'. + Proof. + move=> hincl. unfold rel_le. + rewrite subset_union //; auto with entails_L. + Qed. + + Lemma entails_L_subset {cls} {prems prems' prems'' : t} : + cls ⊢ℒ prems ≤ prems' -> + prems' ⊂_leset prems'' -> + cls ⊢ℒ prems ≤ prems''. + Proof. + move=> heq /(@incl_entails_L cls). + now eapply entails_L_le_trans. + Qed. + + Lemma entails_L_rels_subset {rels rels' r} : + rels ⊢ℒ r -> + incl rels rels' -> + rels' ⊢ℒ r. + Proof. + induction 1; try solve [econstructor; eauto]. + Qed. + + + Lemma entails_L_le_eq {cls l r} : cls ⊢ℒ l ≤ r -> cls ⊢ℒ l ∨ r ≡ r. + Proof. trivial. Qed. + + Lemma entails_L_eq_le_1 {cls} {l r} : cls ⊢ℒ l ≡ r -> cls ⊢ℒ l ≤ r. + Proof. + intros eq; unfold rel_le. + eapply (entails_join_congr_all_inv (x := r)). + eapply entails_idem. now eapply entails_sym. + Qed. + + Lemma entails_L_eq_le_2 {cls} {l r} : cls ⊢ℒ l ≡ r -> cls ⊢ℒ r ≤ l. + Proof. + intros eq; unfold rel_le. + eapply entails_sym in eq. now eapply entails_L_eq_le_1 in eq. + Qed. + + Lemma entails_L_eq_antisym {cls} {l r} : cls ⊢ℒ r ≤ l -> cls ⊢ℒ l ≤ r -> cls ⊢ℒ l ≡ r. + Proof. + unfold rel_le. intros le le'. + eapply entails_trans with (l ∨ r) => //. + apply entails_sym. now rewrite union_comm. + Qed. + + Lemma entails_L_le_join_l {p x x' r} : + p ⊢ℒ x ≤ x' -> + p ⊢ℒ (x ∨ r) ≤ (x' ∨ r). + Proof. + intros le. + unfold rel_le in le |- *. + rewrite union_assoc (@union_comm r) union_assoc -union_assoc. + eapply entails_join_congr_all => //. + apply entails_idem. + Qed. + + Lemma entails_L_le_congr {p x y x' y'} : + p ⊢ℒ x ≤ x' -> + p ⊢ℒ y ≤ y' -> + p ⊢ℒ x ∨ y ≤ x' ∨ y'. + Proof. + move/(entails_L_le_join_l (r:=y)) => le le'. + eapply entails_L_le_trans; tea. + rewrite !(@union_comm x'). + now eapply entails_L_le_join_l. + Qed. + + Lemma entails_L_le_idem {p x} : + p ⊢ℒ x ∨ x ≤ x. + Proof. + eapply entails_L_eq_le_1, entails_idem. + Qed. + + Lemma entails_L_le_join {p x y z} : + p ⊢ℒ x ≤ z -> + p ⊢ℒ y ≤ z -> + p ⊢ℒ x ∨ y ≤ z. + Proof. + move=> le le'. + have := entails_L_le_congr le le' => comb. + eapply entails_L_le_trans; tea. + eapply entails_L_le_idem. + Qed. + + Lemma entails_L_le_left {p x y} : + p ⊢ℒ x ≤ x ∨ y. + Proof. + rewrite /rel_le. rewrite -union_assoc. + eapply entails_join_congr_all. apply entails_idem. apply entails_refl. + Qed. + + Lemma entails_L_le_right {p x y} : + p ⊢ℒ y ≤ x ∨ y. + Proof. + rewrite union_comm; apply entails_L_le_left. + Qed. + + Lemma entails_L_in p l (t : t) : + LevelExprSet.In l t -> + p ⊢ℒ NES.singleton l ≤ t. + Proof. + move: t; apply: NES.elim. + - move=>[l' k] /LevelExprSet.singleton_spec => ->. + apply entails_L_le_refl. + - move=> le x h hnin /NES.add_spec []. + * intros ->. rewrite -union_add_singleton. + apply entails_L_le_right. + * move/h => hle. + rewrite -union_add_singleton. + eapply entails_L_le_trans with x => //. + apply entails_L_le_left. + Qed. + + Import Semilattice. + + Section interp. + Context {S : Type} {SL : Semilattice S Q.t}. + Context (v : Level.t -> S). + + Definition interp_expr '(l, k) := (add k (v l))%Z. + + Definition interp_prems prems := + let '(hd, tl) := to_nonempty_list prems in + fold_right (fun lk acc => join (interp_expr lk) acc) (interp_expr hd) tl. + + Definition interp_rel r := + let '(l, r) := r in + interp_prems l ≡ interp_prems r. + + Definition interp_rels c := + List.Forall interp_rel c. + + Declare Scope sl_scope. + Infix "≤" := le : sl_scope. + Infix "≡" := eq : sl_scope. + Local Open Scope sl_scope. + + End interp. + +Section ForSemilattice. + Import Semilattice. + Import CommutativeMonoid. + Context {A : Type} {V : Type} {CM : IsCommMonoid V} {SL : Semilattice A V}. + Open Scope sl_scope. + + Lemma fold_right_max_in {a : A} {l : list A} n : In a l -> a ≤ (fold_right join n l). + Proof. + induction l. + - now cbn. + - intros [eq|inl]. subst a0. cbn. apply join_le_left. + cbn. specialize (IHl inl). etransitivity; tea. apply join_le_right. + Qed. + + Lemma fold_right_max_acc {n l} : n ≤ fold_right join n l. + Proof. + induction l. + - now cbn. + - cbn. etransitivity; tea. eapply join_le_right. + Qed. + + Lemma fold_right_impl n l l' : + (forall x, In x l -> In x l') -> fold_right join n l ≤ fold_right join n l'. + Proof. + induction l in l' |- *. + - cbn. destruct l'; cbn. reflexivity. + intros. have := @fold_right_max_acc n l'. + etransitivity; tea; eapply join_le_right. + - cbn; intros h. + have inal' := (h a (or_introl Logic.eq_refl)). + have := fold_right_max_in n inal'. + specialize (IHl l'). + forward IHl. + intros. apply h. now right. + intros hle; rewrite join_le_left_eq. now split. + Qed. + + Lemma fold_right_max_spec n l : + let fn := fold_right join in + (forall x, In x (n :: l) -> x ≤ fn n l). + Proof. + induction l; cbn. + - intros x [] => //. now subst. + (* exists n. firstorder. reflexivity. *) + - cbn in IHl. + intros x [|[]]; subst. + * specialize (IHl x). forward IHl by auto. + now apply join_le_right_trans. + * apply join_le_left. + * specialize (IHl x). forward IHl by auto. + now apply join_le_right_trans. + Qed. + + Lemma fold_right_equivlist_all_le n n' l l' : + equivlistA Logic.eq (n :: l) (n' :: l') -> fold_right join n l ≤ fold_right join n' l'. + Proof. + intros eq. + have hla := fold_right_max_spec n l. + have hra := fold_right_max_spec n' l'. + red in eq. + setoid_rewrite InA_In_eq in eq. + cbn in hra. setoid_rewrite <- eq in hra. clear -hra. + move: hra; generalize (fold_right join n' l'). + clear. + induction l. + - cbn. intros a heq. apply heq. now left. + - cbn. intros a' ih. + specialize (IHl a'). forward IHl. + { cbn; intros x []. subst. eapply ih. now left. + apply ih. auto. } + specialize (ih a). forward ih. { now right; left. } + eapply join_le_left_eq; now split. + Qed. + + Lemma fold_right_equivlist_all n n' l l' : + equivlistA Logic.eq (n :: l) (n' :: l') -> fold_right join n l ≡ fold_right join n' l'. + Proof. + intros eq. + apply eq_antisym; split; eapply fold_right_equivlist_all_le; auto. + now symmetry. + Qed. + + Lemma fold_right_comm acc l : l <> [] -> fold_right join acc l ≡ join acc (fold_right join (List.hd acc l) (List.tl l)). + Proof. + induction l in acc |- *. + - intros; congruence. + - intros _. cbn. destruct l; cbn. apply join_comm. + cbn in IHl. rewrite (IHl acc). congruence. + rewrite (IHl a). congruence. + now rewrite -!join_assoc (join_comm a). + Qed. + +End ForSemilattice. + + Section OnInterp. + Context {S : Type} {SL : Semilattice S Q.t}. + + (* There exists a valuation making all clauses true in the natural numbers *) + Definition satisfiable (cls : rels) := + exists V, interp_rels V cls. + + (* Any valuation making all clauses valid in the given semilattice also satisfies the clause cl *) + Definition entails_sem (cls : rels) (r : rel) := + forall V, interp_rels V cls -> interp_rel V r. + + Lemma interp_add_expr V n e : + interp_expr V (add_expr n e) ≡ add n (interp_expr V e). + Proof. + destruct e as [l k]; cbn. now rewrite add_distr. + Qed. + + Lemma interp_prems_singleton V e : + interp_prems V (NES.singleton e) = interp_expr V e. + Proof. + rewrite /interp_prems. + now rewrite singleton_to_nonempty_list /=. + Qed. + + Lemma interp_prems_ge v (prems : t) : + forall prem, LevelExprSet.In prem prems -> + interp_expr v prem ≤ interp_prems v prems. + Proof. + intros. + unfold interp_prems. + have he := to_nonempty_list_spec prems. + destruct to_nonempty_list. + pose proof to_nonempty_list_spec'. + rewrite In_elements in H. rewrite -he in H. clear H0 he. clear -H. + destruct H. subst p. + - induction l. cbn. auto. + cbn. red. eapply join_idem. cbn. + etransitivity; tea. + apply join_le_right. + - induction l in H |- *. + now cbn in H. + cbn in H. destruct H; subst; cbn. + * cbn. apply join_le_left. + * specialize (IHl H). etransitivity; tea. apply join_le_right. + Qed. + + Lemma interp_prems_elements V u : + interp_prems V u = fold_right join (interp_expr V (to_nonempty_list u).1) (List.map (interp_expr V) (to_nonempty_list u).2). + Proof. + rewrite /interp_prems. + have he := to_nonempty_list_spec u. + destruct to_nonempty_list. + now rewrite fold_right_map. + Qed. + + Lemma fold_right_interp {V : Level.t -> S} {x l x' l'} : + equivlistA Logic.eq (x :: l) (x' :: l') -> + fold_right join (interp_expr V x) (List.map (interp_expr V) l) ≡ fold_right join (interp_expr V x') (List.map (interp_expr V) l'). + Proof. + intros eq. apply fold_right_equivlist_all. + intros a. rewrite !InA_In_eq. + rewrite !(in_map_iff (interp_expr V) (_ :: _)). + setoid_rewrite <-InA_In_eq. + split. + - move=> [b [<- ]]. + eexists; split; trea. now apply eq in b0. + - move=> [b [<- ]]. + eexists; split; trea. now apply eq in b0. + Qed. + + Lemma equivlistA_add le u : let l := to_nonempty_list (NES.add le u) in + equivlistA Logic.eq (l.1 :: l.2) (le :: LevelExprSet.elements u). + Proof. + have he := to_nonempty_list_spec (NES.add le u). + destruct to_nonempty_list. cbn. + intros x. rewrite he. + rewrite !LevelExprSet.elements_spec1. + split. + - move/LevelExprSet.add_spec => [->|hin]. + now constructor. constructor 2. now apply LevelExprSet.elements_spec1. + - intros h; depelim h; subst. now apply LevelExprSet.add_spec; left. + apply LevelExprSet.add_spec. now apply LevelExprSet.elements_spec1 in h. + Qed. + + Lemma interp_prems_add V le (u : t) : + interp_prems V (NES.add le u) ≡ join (interp_expr V le) (interp_prems V u). + Proof. + rewrite 2!interp_prems_elements. + erewrite fold_right_interp. 2:apply equivlistA_add. + rewrite fold_right_comm. + { apply map_nil, elements_not_empty. } + apply join_congr_r. eapply fold_right_equivlist_all. + have he := to_nonempty_list_spec u. + destruct to_nonempty_list. rewrite -he //=. + Qed. + + Lemma interp_prems_elim (P : t -> S -> Prop) V : + Proper (Logic.eq ==> eq ==> iff) P -> + (forall le, P (singleton le) (interp_expr V le)) -> + (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (NES.add le u) (join (interp_expr V le) k)) -> + forall u, P u (interp_prems V u). + Proof. + intros prop hs hadd. + eapply elim. + - intros le. rewrite interp_prems_singleton. apply hs. + - intros le prems ih hnin. + rewrite interp_prems_add. now apply hadd. + Qed. + + Lemma interp_add_prems V n e : interp_prems V (add_prems n e) ≡ add n (interp_prems V e). + Proof. + revert e. + refine (interp_prems_elim (fun u z => interp_prems V (add_prems n u) ≡ add n z) _ _ _ _). + - intros p p' eq a a' eq'. + subst p'. now rewrite eq'. + - intros le. + rewrite add_prems_singleton interp_prems_singleton //=. + destruct le; cbn. now rewrite add_distr. + - intros le u k heq hnin. + rewrite add_prems_add. + rewrite interp_prems_add heq interp_add_expr. + now rewrite add_join. + Qed. + + Lemma interp_prems_in {V le} {u : t} : + LevelExprSet.In le u -> interp_expr V le ≤ interp_prems V u. + Proof. + revert u. + refine (interp_prems_elim (fun u z => LevelExprSet.In le u -> interp_expr V le ≤ z) V _ _ _). + - intros ? ? <- x y eq. now rewrite eq. + - intros le' u'. + apply LevelExprSet.singleton_spec in u'. red in u'; subst. + reflexivity. + - move=> le' u z hz hnin /LevelExprSet.add_spec [->|hin]. + * apply join_le_left. + * specialize (hz hin). + now apply join_le_right_trans. + Qed. + + Lemma interp_prems_union {v : Level.t -> S} {x y : t} : + interp_prems v (x ∪ y) ≡ + join (interp_prems v x) (interp_prems v y). + Proof. + move: x; apply NES.elim. + - intros []. rewrite union_comm union_add_singleton. + now rewrite interp_prems_add interp_prems_singleton. + - intros le' x ih hnin. + rewrite union_add_distr !interp_prems_add ih. cbn. + now rewrite join_assoc. + Qed. + + Lemma clauses_sem_subset {u u' : t} : u ⊂_leset u' -> + forall V, interp_prems V u ≤ interp_prems V u'. + Proof. + intros hsub V. + revert u u' hsub. + refine (interp_prems_elim (fun u z => forall u' : t, u ⊂_leset u' -> + z ≤ interp_prems V u') V _ _ _). + - intros ?? <- ?? eq. + now setoid_rewrite eq. + - intros le u' hsing. + specialize (hsing le). forward hsing by now apply LevelExprSet.singleton_spec. + now apply interp_prems_in. + - intros le u k ih hin u' sub. + have hle := sub le. + specialize (ih u'). + forward ih. intros x hin'. apply sub. now apply LevelExprSet.add_spec; right. + forward hle by now apply LevelExprSet.add_spec; left. + have hi := interp_prems_in (V := V) hle. + apply join_le_left_eq. split => //. + Qed. + + End OnInterp. + + Structure semilattice := + { carrier :> Type; + sl : Semilattice carrier Q.t }. + + (* Definition incr_semilattice : semilattice_on comm_monoid := {| carrier := Q.t; sl := _ |}. *) + + Instance semlattice_Semilattice (s : semilattice) : Semilattice (carrier s) Q.t := sl s. + + Definition valid_relation rels c := + (forall (s : semilattice) (v : Level.t -> s), interp_rels v rels -> interp_rel v c). + + Lemma entails_L_valid {p r} : + p ⊢ℒ r -> valid_relation p r. + Proof. + rewrite /valid_relation //=. + destruct r as [l r] => //=. + intros h; depind h; cbn; move=> s v hv. + 1:{ red in hv. rewrite Forall_forall in hv; eapply hv in H. exact H. } + all:try specialize (IHh _ _ Logic.eq_refl s _ hv). + all:try specialize (IHh1 _ _ Logic.eq_refl s _ hv). + all:try specialize (IHh2 _ _ Logic.eq_refl s _ hv). + all:try lia; eauto. + all:rewrite ?interp_add_prems ?interp_prems_union ?interp_add_prems; try lia. + - eapply reflexivity. + - now eapply symmetry, IHh. + - eapply transitivity; [eapply IHh1|eapply IHh2] => //. + - now apply add_congr. + - rewrite ?interp_add_prems in IHh. + now apply add_inj in IHh. + - now apply join_congr. + - apply join_assoc. + - apply join_idem. + - apply join_comm. + - apply (join_sub (Semilattice := sl s)). + - now apply add_join. + Qed. + + Equations? init_model (rs : rels) : Semilattice t Q.t := + init_model rs := {| + eq x y := rs ⊢ℒ x ≡ y; + add := add_prems; + join := union |}. + Proof. + all:intros. all:try solve [econstructor; eauto]. + - split; intros. + * intros x. eapply entails_refl. + * intros x y. eapply entails_sym. + * intros x y z. eapply entails_trans. + - rewrite add_prems_add_prems. eapply entails_refl. + - rewrite add_prems_0. apply entails_refl. + Defined. + + #[export] Existing Instance init_model. + + Definition initial_semilattice rs : semilattice := + {| carrier := NES.t; sl := init_model rs |}. + + Definition ids (rs : rels) : Level.t -> t := (fun l : Level.t => singleton (l, zero)). + + Lemma interp_triv rs l : eq (Semilattice := init_model rs) (interp_prems (SL := init_model rs) (ids rs) l) l. + Proof. + move: l; apply: elim. + - intros [l k]. + rewrite interp_prems_singleton //= /ids //=. + rewrite add_prems_singleton //=. rewrite comm neutral. + apply entails_refl. + - move=> [] l k x ih hnin. + have ha := (interp_prems_add (SL := init_model rs) (ids rs) (l, k)). + rewrite ha ih. rewrite /interp_expr. rewrite -union_add_singleton /ids. + rewrite [add _ _]add_prems_singleton /add_expr comm neutral. + apply (join_comm (Semilattice := init_model rs)). + Qed. + + Lemma interp_rels_init rs : interp_rels (SL := init_model rs) (ids rs) rs. + Proof. + unfold interp_rels; unfold interp_rel. cbn. + have ir : incl rs rs. + { now intros l. } + move: ir. + generalize rs at 1 8. + induction rs0; cbn. + - constructor. + - destruct a. constructor. + * change (eq (Semilattice := init_model rs) (interp_prems (SL := init_model rs) (ids rs) t0) (interp_prems (SL := init_model rs) (ids rs) t1)). + rewrite !interp_triv. + constructor. apply ir. now constructor. + * apply IHrs0. intros r hin; apply ir. now right. + Qed. + + Definition valid {S} (SL : Semilattice S Q.t) v r := + interp_rel (SL := SL) v r. + + Lemma syntax_model rs r : valid (init_model rs) (ids rs) r <-> rs ⊢ℒ r. + Proof. + rewrite /valid. + destruct r as [l r]. unfold interp_rel. + rewrite !interp_triv; split; apply. + Qed. + + Lemma valid_entails_L {p r} : + valid_relation p r -> p ⊢ℒ r. + Proof. + rewrite /valid_relation. + intros ha. apply syntax_model. + destruct r as [l r]. cbn. + change (eq (Semilattice := init_model p) (interp_prems (SL := init_model p) (ids p) l) (interp_prems (SL := init_model p) (ids p) r)). + specialize (ha (initial_semilattice p) (ids p) (interp_rels_init p)). + now cbn in ha. + Qed. + + (* Entailment is complete, i.e. it does represent the free semilattice with an action from Q.t *) + Lemma completeness {p r} : + valid_relation p r <-> p ⊢ℒ r. + Proof. + split. + - apply valid_entails_L. + - apply entails_L_valid. + Qed. + +End InitialSemilattice. diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 2e5352d6d..9322784a9 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -46,10 +46,15 @@ End FMapOTInterface. Module Q <: Quantity. Include OrdersEx.Z_as_OT. + Import CommutativeMonoid. - Instance comm_monoid : CommutativeMonoid Z.zero Z.add := _. + Instance comm_monoid : IsCommMonoid Z := + { zero := Z.zero ; one := 1%Z; add := Z.add }. - Program Instance add_inj z : Injective (Z.add z). + Program Instance add_inj_eq z : Injective (Z.add z) eq eq. + Next Obligation. unfold eq in *. lia. Qed. + + Program Instance add_inj_lt z : Injective (Z.add z) lt lt. Next Obligation. lia. Qed. Definition reflect_eq : ReflectEq t := _. @@ -63,12 +68,13 @@ Module Type LevelSets. Declare Module LevelExpr : LevelExprT Level Q. Declare Module LevelExprSet : LevelExprSet_fun Level Q LevelExpr. Declare Module LevelMap : FMapOTInterface Level. + Module NES := NonEmptyLevelExprSet Level Q LevelSet LevelExpr LevelExprSet. End LevelSets. Module FromLevelSets (LS : LevelSets). Export LS. -Module NES := NonEmptyLevelExprSet Level Q LevelSet LevelExpr LevelExprSet. +Import NES.OfQ. Import NES. #[export] Existing Instance Level.reflect_eq. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 8e30799ce..019ce69c6 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -69,16 +69,17 @@ From Stdlib Require Import ssreflect ssrbool ssrfun ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils SemiLattice. +From MetaRocq.Utils Require Import utils. From MetaRocq.Common Require Universes. -From MetaRocq.Common Require Import Common Interfaces HornClauses. +From MetaRocq.Common Require Import Common Interfaces HornClauses HornSemilatticeEquiv. From Equations Require Import Equations. Set Equations Transparent. Module Model (LS : LevelSets). - Module Export Clauses := Clauses(LS). - Export NES. + Module Export Clauses := HornSemilattice (LS). + Import LS. + Export LS.NES. Import Init.Logic (eq). Definition model := LevelMap.t (option Z). @@ -113,7 +114,7 @@ Module Model (LS : LevelSets). | Some z, Some v => z <=? v | None, _ => true. - Lemma check_atom_value_spec z l : reflectProp (z ≤ l) (check_atom_value z l). + Lemma check_atom_value_spec z l : reflectProp (z ≤ l)%opt (check_atom_value z l). Proof. funelim (check_atom_value z l). - destruct (Z.leb_spec z v); constructor. @@ -341,7 +342,7 @@ Module Model (LS : LevelSets). strictly_updates cls ls m m' -> P ls m m' -> strictly_updates cls ls' m' m'' -> - P ls' m' m'' -> P (ls ∪ ls') m m'') -> + P ls' m' m'' -> P (ls ∪ ls')%levels m m'') -> forall (s : LevelSet.t) (m m0 : model), strictly_updates cls s m m0 -> P s m m0. Proof. @@ -490,6 +491,8 @@ Module Model (LS : LevelSets). destruct Z.leb => //. Qed. + Open Scope opt_rel. + Lemma valid_clause_elim {m prems concl k} : valid_clause m (prems, (concl, k)) -> forall z, min_premise m prems = Some z -> Some (z + k) ≤ level_value m concl. @@ -920,7 +923,7 @@ Module Model (LS : LevelSets). split. left. split; reflexivity. move/negbTE: hlt'. destruct k' => //. - elim: Z.leb_spec => //. intros; constructor; lia. constructor. + elim: Z.leb_spec => //. cbn -[Z.add]. intros; constructor; lia. constructor. exists k'. split => //. right; eauto. reflexivity. Qed. @@ -1237,8 +1240,9 @@ Module Model (LS : LevelSets). Proof. intros l k; rewrite /to_positive. rewrite In_add_prems. split. - - move=> hin; exists (l, k). split => //. rewrite /add_expr; lia_f_equal. + - move=> hin; exists (l, k). split => //. rewrite /add_expr; cbn -[Z.add]; lia_f_equal. - move=> [] [l' k'] [] hin heq. noconf heq. + cbn -[Z.add] in *. now have -> : k = k' by lia. Qed. @@ -1967,7 +1971,7 @@ Module Model (LS : LevelSets). eapply level_value_MapsTo in hm. now rewrite hm. Qed. -Lemma is_update_of_empty cls m : + Lemma is_update_of_empty cls m : is_update_of cls LevelSet.empty m m. Proof. unfold is_update_of. @@ -2581,7 +2585,8 @@ Lemma is_update_of_empty cls m : intros hle eq. setoid_rewrite eq. eexists. setoid_rewrite LevelMapFact.F.add_mapsto_iff. split; [left;split;eauto|] => //. destruct level_value eqn:hl => //. - * rewrite (level_value_MapsTo hm) in hl. noconf hl. constructor. lia. + * rewrite (level_value_MapsTo hm) in hl. noconf hl. constructor. + cbn -[Z.add] in *; lia. * rewrite (level_value_MapsTo hm) in hl. noconf hl. constructor. - move=> ls ls' m m' m'' su ihsu su' ihsu' l k; rewrite LevelSet.union_spec; move=> [] hin hm. apply ihsu in hm as [k' [hle hm']]; tea. @@ -2906,7 +2911,8 @@ Lemma is_update_of_empty cls m : Proof. intros tot cla mp [l k]. rewrite In_add_prems => [] [[l' k']] [] /of_level_map_spec hm. - rewrite /succ_expr => he. noconf he. rewrite Z.add_comm. + rewrite /succ_expr => he. noconf he. cbn -[Z.add] in *. + rewrite Z.add_comm. eapply entails_any_one; tea. exact tot. apply tot. now exists (Some k'). Qed. @@ -2943,212 +2949,12 @@ Lemma is_update_of_empty cls m : now eapply strictly_updates_defined_map in su. Qed. - Section Semantics. - Import Semilattice. - Section Interpretation. - Context {A : Type} {s : Semilattice A Z}. - Context (V : Level.t -> A). - - Definition interp_expr '(l, k) := add k (V l). - Definition interp_prems prems := - let '(hd, tl) := to_nonempty_list prems in - fold_right (fun lk acc => join (interp_expr lk) acc) (interp_expr hd) tl. - - Definition clause_sem (cl : clause) : Prop := - let '(prems, concl) := cl in - le (interp_expr concl) (interp_prems prems). - - Definition clauses_sem (cls : clauses) : Prop := - Clauses.For_all clause_sem cls. - End Interpretation. - - Section OfSL. - Context {A} {SL : Semilattice A Z}. - Declare Scope sl_scope. - Infix "≤" := le : sl_scope. - Infix "≡" := eq : sl_scope. - Local Open Scope sl_scope. - - (* There exists a valuation making all clauses true in the natural numbers *) - Definition satisfiable (cls : clauses) := - exists V, clauses_sem V cls. - - (* Any valuation making all clauses valid in the given semilattice also satisfies the clause cl *) - Definition entails_sem (cls : clauses) (cl : clause) := - forall V, clauses_sem V cls -> clause_sem V cl. - - Lemma interp_add_expr V n e : - interp_expr V (add_expr n e) ≡ add n (interp_expr V e). - Proof. - destruct e as [l k]; cbn. now rewrite add_distr. - Qed. - - Lemma interp_prems_singleton V e : - interp_prems V (NES.singleton e) = interp_expr V e. - Proof. - rewrite /interp_prems. - now rewrite singleton_to_nonempty_list /=. - Qed. - - Lemma interp_prems_ge v (prems : premises) : - forall prem, LevelExprSet.In prem prems -> - interp_expr v prem ≤ interp_prems v prems. - Proof. - intros. - unfold interp_prems. - have he := to_nonempty_list_spec prems. - destruct to_nonempty_list. - pose proof to_nonempty_list_spec'. - rewrite In_elements in H. rewrite -he in H. clear H0 he. clear -H. - destruct H. subst p. - - induction l. cbn. auto. - cbn. red. eapply join_idem. cbn. - etransitivity; tea. - apply join_le_right. - - induction l in H |- *. - now cbn in H. - cbn in H. destruct H; subst; cbn. - * cbn. apply join_le_left. - * specialize (IHl H). etransitivity; tea. apply join_le_right. - Qed. - - Lemma interp_prems_elements V u : - interp_prems V u = fold_right join (interp_expr V (to_nonempty_list u).1) (List.map (interp_expr V) (to_nonempty_list u).2). - Proof. - rewrite /interp_prems. - have he := to_nonempty_list_spec u. - destruct to_nonempty_list. - now rewrite Universes.fold_right_map. - Qed. - - Lemma fold_right_interp {V : Level.t -> A} {x l x' l'} : - equivlistA Logic.eq (x :: l) (x' :: l') -> - fold_right join (interp_expr V x) (List.map (interp_expr V) l) ≡ fold_right join (interp_expr V x') (List.map (interp_expr V) l'). - Proof. - intros eq. apply fold_right_equivlist_all. - intros a. rewrite !InA_In_eq. - rewrite !(in_map_iff (interp_expr V) (_ :: _)). - setoid_rewrite <-InA_In_eq. - split. - - move=> [b [<- ]]. - eexists; split; trea. now apply eq in b0. - - move=> [b [<- ]]. - eexists; split; trea. now apply eq in b0. - Qed. - - Lemma equivlistA_add le u : let l := to_nonempty_list (NES.add le u) in - equivlistA Logic.eq (l.1 :: l.2) (le :: LevelExprSet.elements u). - Proof. - have he := to_nonempty_list_spec (NES.add le u). - destruct to_nonempty_list. cbn. - intros x. rewrite he. - rewrite !LevelExprSet.elements_spec1. - split. - - move/LevelExprSet.add_spec => [->|hin]. - now constructor. constructor 2. now apply LevelExprSet.elements_spec1. - - intros h; depelim h; subst. now apply LevelExprSet.add_spec; left. - apply LevelExprSet.add_spec. now apply LevelExprSet.elements_spec1 in h. - Qed. - - Lemma interp_prems_add V le (u : premises) : - interp_prems V (NES.add le u) ≡ join (interp_expr V le) (interp_prems V u). - Proof. - rewrite 2!interp_prems_elements. - erewrite fold_right_interp. 2:apply equivlistA_add. - rewrite fold_right_comm. - { apply map_nil, elements_not_empty. } - apply join_congr_r. eapply fold_right_equivlist_all. - have he := to_nonempty_list_spec u. - destruct to_nonempty_list. rewrite -he //=. - Qed. - - Lemma interp_prems_elim (P : premises -> A -> Prop) V : - Proper (Logic.eq ==> eq ==> iff) P -> - (forall le, P (NES.singleton le) (interp_expr V le)) -> - (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (NES.add le u) (join (interp_expr V le) k)) -> - forall u, P u (interp_prems V u). - Proof. - intros prop hs hadd. - eapply elim. - - intros le. rewrite interp_prems_singleton. apply hs. - - intros le prems ih hnin. - rewrite interp_prems_add. now apply hadd. - Qed. - - Lemma interp_add_prems V n e : interp_prems V (add_prems n e) ≡ add n (interp_prems V e). - Proof. - revert e. - refine (interp_prems_elim (fun u z => interp_prems V (add_prems n u) ≡ add n z) _ _ _ _). - - intros p p' eq a a' eq'. - subst p'. now rewrite eq'. - - intros le. - rewrite add_prems_singleton interp_prems_singleton //=. - destruct le; cbn. now rewrite add_distr. - - intros le u k heq hnin. - rewrite add_prems_add. - rewrite interp_prems_add heq interp_add_expr. - now rewrite add_join. - Qed. - - Lemma interp_prems_in {V le} {u : premises} : - LevelExprSet.In le u -> interp_expr V le ≤ interp_prems V u. - Proof. - revert u. - refine (interp_prems_elim (fun u z => LevelExprSet.In le u -> interp_expr V le ≤ z) V _ _ _). - - intros ? ? <- x y eq. now rewrite eq. - - intros le' u'. - apply LevelExprSet.singleton_spec in u'. red in u'; subst. - reflexivity. - - move=> le' u z hz hnin /LevelExprSet.add_spec [->|hin]. - * apply join_le_left. - * specialize (hz hin). - now apply join_le_right_trans. - Qed. - - Lemma clauses_sem_subset {u u' : premises} : u ⊂_leset u' -> - forall V, interp_prems V u ≤ interp_prems V u'. - Proof. - intros hsub V. - revert u u' hsub. - refine (interp_prems_elim (fun u z => forall u' : premises, u ⊂_leset u' -> - z ≤ interp_prems V u') V _ _ _). - - intros ?? <- ? ? eq. - now setoid_rewrite eq. - - intros le u' hsing. - specialize (hsing le). forward hsing by now apply LevelExprSet.singleton_spec. - now apply interp_prems_in. - - intros le u k ih hin u' sub. - have hle := sub le. - specialize (ih u'). - forward ih. intros x hin'. apply sub. now apply LevelExprSet.add_spec; right. - forward hle by now apply LevelExprSet.add_spec; left. - have hi := interp_prems_in (V := V) hle. - apply join_le_left_eq. split => //. - Qed. - - End OfSL. - End Semantics. - Definition enabled_clause (m : model) (cl : clause) := exists z, min_premise m (premise cl) = Some z. Definition enabled_clauses (m : model) (cls : clauses) := Clauses.For_all (enabled_clause m) cls. - Import Semilattice. - - Definition to_val (v : LevelMap.t nat) l := - match LevelMap.find l v with - | Some n => n - | None => 0%nat - end. - - Definition to_Z_val (v : Level.t -> nat) := fun l => Z.of_nat (v l). - - (* Interprest in a nat semilattice only *) - Definition correct_model {SL : Semilattice Z Z} (cls : clauses) (m : model) := - enabled_clauses m cls /\ clauses_sem (to_Z_val (to_val (valuation_of_model m))) cls. - Lemma enabled_clause_ext {m m' cl} : m ⩽ m' -> enabled_clause m cl -> enabled_clause m' cl. Proof. @@ -3158,7 +2964,6 @@ Lemma is_update_of_empty cls m : rewrite hm in pr. depelim pr. now exists y. Qed. - Lemma enabled_clauses_ext m m' cls : m ⩽ m' -> enabled_clauses m cls -> enabled_clauses m' cls. Proof. intros hext. @@ -3167,84 +2972,6 @@ Lemma is_update_of_empty cls m : now apply enabled_clause_ext. Qed. - Lemma in_pred_closure_entails {A} {SL : Semilattice A Z} cls cl : - in_pred_closure cls cl -> - (forall V, clauses_sem V cls -> clause_sem V cl). - Proof. - induction 1. - - intros V. rewrite /clauses_sem. intros ha. - apply ha in H. - move: H; rewrite /clause_sem. - destruct cl as [prems concl]. - cbn. rewrite interp_add_prems. - destruct concl as [concl conclk]. - rewrite /add_expr; cbn. - rewrite -add_distr => le. now apply (le_add (n:=n)) in le. - - intros V clsm. cbn. - rewrite interp_prems_singleton. - cbn. red. rewrite -!add_distr. rewrite -add_join. - now rewrite join_sub. - Qed. - - (** Enabled and valid clauses are satisfied by valuation *) - Lemma valid_clause_model model cl : - enabled_clause model cl -> - valid_clause model cl -> - clause_sem (to_Z_val (to_val (valuation_of_model model))) cl. - Proof. - unfold enabled_clause, valid_clause. - destruct min_premise eqn:hmin => //= => //. - 2:{ intros [k' eq]. congruence. } - intros [k' eq]. noconf eq. - destruct cl as [prems [concl k]]. cbn -[le]. - unfold level_value_above. - destruct level_value eqn:hl => //. - unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. - move/Z.leb_le => hrel. - eapply LevelMap.find_2 in hfind. - have conclm := valuation_of_model_spec _ _ _ hfind. - set (v := (model_max _ - _)) in *. - cbn in conclm. - eapply LevelMap.find_1 in conclm. - subst v. - pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. - rewrite hmin in premeq. - eapply transitivity. 2:{ eapply interp_prems_ge; tea. } - unfold interp_expr. destruct prem as [prem k']. - symmetry in premeq. - move: premeq. unfold min_atom_value. - unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. - destruct o => //. - intros [= <-]. - eapply LevelMap.find_2 in findp. - have premm := valuation_of_model_spec _ _ _ findp. - eapply LevelMap.find_1 in premm. - assert (z1 - k' <= z0 - k). lia. - have hm : z0 <= model_max model. - { eapply model_max_spec in hfind; tea. now depelim hfind. } - have hm' : z1 <= model_max model. - { eapply model_max_spec in findp; tea. now depelim findp. } - have hmi : model_min model <= z0. - { eapply model_min_spec; tea. } - have hmi' : model_min model <= z1. - { eapply model_min_spec; tea. } - assert (0 <= model_max model)%Z by apply model_max_spec2. - assert (model_min model <= 0)%Z by apply model_min_spec2. - rewrite /to_Z_val /to_val premm conclm. - cbn. lia. - Qed. - - Lemma valid_clauses_model model cls : - enabled_clauses model cls -> - is_model cls model -> - clauses_sem (to_Z_val (to_val (valuation_of_model model))) cls. - Proof. - move=> en ism cl hin. - apply valid_clause_model. - now apply en. - now move/Clauses.for_all_spec: ism; apply. - Qed. - Lemma init_model_enabled cls : enabled_clauses (max_clause_premises cls) cls. Proof. unfold enabled_clauses. @@ -3263,53 +2990,6 @@ Lemma is_update_of_empty cls m : eexists => //. Qed. - Definition valid_entailment cls cl := forall V, clauses_sem V cls -> clause_sem V cl. - Definition invalid_entailment cls cl := - forall V, clauses_sem V cls -> clause_sem V cl -> False. - - Lemma clauses_sem_entails {cls cl} : - entails cls cl -> - valid_entailment cls cl. - Proof. - induction 1. - - intros v clls. red. - destruct concl0 as [concl k]. - have hge := interp_prems_ge (SL := Zsemilattice) v prems _ H. - cbn in *. by lia. - - move=> V Hcls. - move: {IHentails} (IHentails _ Hcls). - unfold clause_sem. unfold ge => hyp. - etransitivity; tea. rewrite interp_prems_add. - rewrite interp_prems_add in hyp. - eapply in_pred_closure_entails in H; tea. - move: H; rewrite /clause_sem. unfold ge. - have ssub := clauses_sem_subset (SL := Zsemilattice) H1 V. - cbn in *. lia. - Qed. - - Lemma clauses_sem_entails_all {cls prems concl} : - cls ⊢a prems → concl -> - (forall V, clauses_sem V cls -> interp_prems V concl ≤ interp_prems V prems). - Proof. - intros ha V hcls. - red in ha. - move: ha. - revert concl. - refine (@interp_prems_elim _ _ (fun concl z => _ -> z ≤ interp_prems V prems) V _ _ _). - - move=> le //=. move/(_ le). - intros h; forward h by now apply LevelExprSet.singleton_spec. - now have ent := (clauses_sem_entails h _ hcls). - - intros le u k ih hnin. - intros hf. - forward ih. intros x hin; apply (hf x). - rewrite LevelExprSet.add_spec; now right. - specialize (hf le). - forward hf by now apply LevelExprSet.add_spec; left. - cbn in hf. - have ent := (clauses_sem_entails hf _ hcls). cbn in ent. - cbn in *. lia. - Qed. - Lemma valid_clause_shift m n cl : valid_clause m cl -> valid_clause m (add_clause n cl). Proof. @@ -3318,7 +2998,7 @@ Lemma is_update_of_empty cls m : apply valid_clause_intro => z eqmin. eapply min_premise_add_prems_inv in eqmin. specialize (hv _ eqmin). - etransitivity; tea. constructor; lia. + etransitivity; tea. constructor. cbn -[Z.add]. lia. Qed. Lemma entails_model_valid cls cl : entails cls cl -> @@ -3364,4 +3044,4 @@ Lemma is_update_of_empty cls m : exact: valid_clause_elim IHentails _ hadd. Qed. -End Model. \ No newline at end of file +End Model. diff --git a/common/theories/LoopChecking/ModelValuation.v b/common/theories/LoopChecking/ModelValuation.v new file mode 100644 index 000000000..50fda1ab6 --- /dev/null +++ b/common/theories/LoopChecking/ModelValuation.v @@ -0,0 +1,161 @@ + + Section Semantics. + Import Semilattice. + Section Interpretation. + Context {A : Type} {s : Semilattice A Z}. + Context (V : Level.t -> A). + + (* Definition interp_expr '(l, k) := add k (V l). *) + + Definition clause_sem (cl : clause) : Prop := + let '(prems, concl) := cl in + le (interp_expr concl) (interp_prems prems). + + Definition clauses_sem (cls : clauses) : Prop := + Clauses.For_all clause_sem cls. + End Interpretation. + + + End Semantics. + + + + + Definition to_val (v : LevelMap.t nat) l := + match LevelMap.find l v with + | Some n => n + | None => 0%nat + end. + + Definition to_Z_val (v : Level.t -> nat) := fun l => Z.of_nat (v l). + + (* Interprest in a nat semilattice only *) + Definition correct_model {SL : Semilattice Z Z} (cls : clauses) (m : model) := + enabled_clauses m cls /\ clauses_sem (to_Z_val (to_val (valuation_of_model m))) cls. + + + Lemma in_pred_closure_entails {A} {SL : Semilattice A Z} cls cl : + in_pred_closure cls cl -> + (forall V, clauses_sem V cls -> clause_sem V cl). + Proof. + induction 1. + - intros V. rewrite /clauses_sem. intros ha. + apply ha in H. + move: H; rewrite /clause_sem. + destruct cl as [prems concl]. + cbn. rewrite interp_add_prems. + destruct concl as [concl conclk]. + rewrite /add_expr; cbn. + rewrite -add_distr => le. now apply (le_add (n:=n)) in le. + - intros V clsm. cbn. + rewrite interp_prems_singleton. + cbn. red. rewrite -!add_distr. rewrite -add_join. + now rewrite join_sub. + Qed. + + (** Enabled and valid clauses are satisfied by valuation *) + Lemma valid_clause_model model cl : + enabled_clause model cl -> + valid_clause model cl -> + clause_sem (to_Z_val (to_val (valuation_of_model model))) cl. + Proof. + unfold enabled_clause, valid_clause. + destruct min_premise eqn:hmin => //= => //. + 2:{ intros [k' eq]. congruence. } + intros [k' eq]. noconf eq. + destruct cl as [prems [concl k]]. cbn -[le]. + unfold level_value_above. + destruct level_value eqn:hl => //. + unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. + move/Z.leb_le => hrel. + eapply LevelMap.find_2 in hfind. + have conclm := valuation_of_model_spec _ _ _ hfind. + set (v := (model_max _ - _)) in *. + cbn in conclm. + eapply LevelMap.find_1 in conclm. + subst v. + pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. + rewrite hmin in premeq. + eapply transitivity. 2:{ eapply interp_prems_ge; tea. } + unfold interp_expr. destruct prem as [prem k']. + symmetry in premeq. + move: premeq. unfold min_atom_value. + unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. + destruct o => //. + intros [= <-]. + eapply LevelMap.find_2 in findp. + have premm := valuation_of_model_spec _ _ _ findp. + eapply LevelMap.find_1 in premm. + assert (z1 - k' <= z0 - k). lia. + have hm : z0 <= model_max model. + { eapply model_max_spec in hfind; tea. now depelim hfind. } + have hm' : z1 <= model_max model. + { eapply model_max_spec in findp; tea. now depelim findp. } + have hmi : model_min model <= z0. + { eapply model_min_spec; tea. } + have hmi' : model_min model <= z1. + { eapply model_min_spec; tea. } + assert (0 <= model_max model)%Z by apply model_max_spec2. + assert (model_min model <= 0)%Z by apply model_min_spec2. + rewrite /to_Z_val /to_val premm conclm. + cbn. lia. + Qed. + + Lemma valid_clauses_model model cls : + enabled_clauses model cls -> + is_model cls model -> + clauses_sem (to_Z_val (to_val (valuation_of_model model))) cls. + Proof. + move=> en ism cl hin. + apply valid_clause_model. + now apply en. + now move/Clauses.for_all_spec: ism; apply. + Qed. + + Definition valid_entailment cls cl := forall V, clauses_sem V cls -> clause_sem V cl. + Definition invalid_entailment cls cl := + forall V, clauses_sem V cls -> clause_sem V cl -> False. + + Lemma clauses_sem_entails {cls cl} : + entails cls cl -> + valid_entailment cls cl. + Proof. + induction 1. + - intros v clls. red. + destruct concl0 as [concl k]. + have hge := interp_prems_ge (SL := Zsemilattice) v prems _ H. + cbn in *. by lia. + - move=> V Hcls. + move: {IHentails} (IHentails _ Hcls). + unfold clause_sem. unfold ge => hyp. + etransitivity; tea. rewrite interp_prems_add. + rewrite interp_prems_add in hyp. + eapply in_pred_closure_entails in H; tea. + move: H; rewrite /clause_sem. unfold ge. + have ssub := clauses_sem_subset (SL := Zsemilattice) H1 V. + cbn in *. lia. + Qed. + + Lemma clauses_sem_entails_all {cls prems concl} : + cls ⊢a prems → concl -> + (forall V, clauses_sem V cls -> interp_prems V concl ≤ interp_prems V prems). + Proof. + intros ha V hcls. + red in ha. + move: ha. + revert concl. + refine (@interp_prems_elim _ _ (fun concl z => _ -> z ≤ interp_prems V prems) V _ _ _). + - move=> le //=. move/(_ le). + intros h; forward h by now apply LevelExprSet.singleton_spec. + now have ent := (clauses_sem_entails h _ hcls). + - intros le u k ih hnin. + intros hf. + forward ih. intros x hin; apply (hf x). + rewrite LevelExprSet.add_spec; now right. + specialize (hf le). + forward hf by now apply LevelExprSet.add_spec; left. + cbn in hf. + have ent := (clauses_sem_entails hf _ hcls). cbn in ent. + cbn in *. lia. + Qed. + diff --git a/common/theories/Universes.v b/common/theories/Universes.v index d424b8ef3..948989fd8 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -383,18 +383,28 @@ Module Universe. - non empty *) Module Q <: Quantity. Include OrdersEx.Nat_as_OT. + Import CommutativeMonoid. #[program] - Instance comm_monoid : CommutativeMonoid 0%nat add. + Instance comm_monoid : IsCommMonoid nat := + {| zero := 0%nat; + one := 1%nat; + add := Nat.add |}. Next Obligation. - apply add_assoc. + split; tc. + - red. apply add_assoc. + - red. apply add_comm. + - red. apply Nat.add_0_l. Qed. - Next Obligation. - apply add_comm. + + Instance add_inj_eq n : Injective (add n) eq eq. + Proof. + red. intros x y; rewrite /eq /add //=. lia. Qed. - Instance add_inj n : Injective (add n). + + Instance add_inj_lt n : Injective (add n) lt lt. Proof. - red. intros x y; lia. + red. intros x y; rewrite /eq /add //=. lia. Qed. Definition reflect_eq : ReflectEq t := _. @@ -1004,13 +1014,6 @@ Section Univ. intros hfg -> ->; induction l'; cbn; auto; congruence. Qed. - Lemma fold_right_map {A B C} (f : B -> A -> A) (g : C -> B) acc l : - fold_right (fun x acc => f (g x) acc) acc l = - fold_right (fun x acc => f x acc) acc (List.map g l). - Proof. - induction l; cbn; auto. congruence. - Qed. - Lemma subset_levels_exprs {le levels} : LevelSet.Subset (Universe.levels le) levels -> forall e, LevelExprSet.In e le -> LevelSet.In e.1 levels. diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v index 1a00bb593..56804d449 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -380,16 +380,6 @@ End ZUnivConstraint. rewrite Nat2Z.id //. Qed. - Definition choose_prems (u : premises) : LevelExpr.t := (to_nonempty_list u).1. - Lemma choose_prems_spec u : LevelExprSet.In (choose_prems u) u. - Proof. - rewrite /choose_prems. - have hs := to_nonempty_list_spec u. - destruct to_nonempty_list. cbn. - rewrite -LevelExprSet.elements_spec1 InA_In_eq -hs. - now constructor. - Qed. - Lemma clauses_of_le_nempty l r : ~ Clauses.Empty (clauses_of_le l r). Proof. intros he. red in he. eapply he. @@ -875,24 +865,6 @@ End ZUnivConstraint. rewrite !to_of_valuation_univ. lsets. lsets. cbn; lia. Qed. - Instance in_pred_closure_proper : Proper (Clauses.Equal ==> Logic.eq ==> impl) in_pred_closure. - Proof. - intros cls cls' eq ? cl -> h. - induction h. - - constructor. now rewrite -eq. - - constructor. - Qed. - - - Instance proper_entails : Proper (Clauses.Equal ==> Logic.eq ==> impl) entails. - Proof. - intros cls cls' eq ? cl -> h. - induction h. - - constructor; auto. - - econstructor 2; eauto. - now rewrite -eq. - Qed. - Definition entails_cstr cstrs c := entails_clauses (to_clauses cstrs) (LoopCheck.to_clauses (to_constraint c)). @@ -962,18 +934,6 @@ End ZUnivConstraint. eapply (repr_constraints m); tea. Qed. - Lemma interp_prems_union {S} {SL : Semilattice S Z} {v : Level.t -> S} {x y : premises} : - interp_prems v (x ∪ y) ≡ - join (interp_prems v x) (interp_prems v y). - Proof. - move: x; apply NES.elim. - - intros []. rewrite union_comm union_add_singleton. - now rewrite interp_prems_add interp_prems_singleton. - - intros le' x ih hnin. - rewrite union_add_distr !interp_prems_add ih. cbn. - now rewrite join_assoc. - Qed. - Lemma val_respects cls v : @respects _ _ Z _ (horn_semi cls) _ Zsemilattice (fun u => interp_prems v u). Proof. split; cbn. @@ -995,214 +955,6 @@ End ZUnivConstraint. now eapply clauses_sem_entails in he. Qed. - Import Semilattice. - - Definition rel := premises × premises. - - Declare Scope rel_scope. - Delimit Scope rel_scope with rel. - Bind Scope rel_scope with rel. - Open Scope rel_scope. - - Definition rels := list rel. - - Record presentation := - { V : LevelSet.t; - C : list (NES.t × NES.t); }. - - Infix "∨" := NES.union (at level 30) : nes_scope. - Open Scope nes_scope. - - Definition rel_eq (x y : premises) : rel := (x, y). - Definition rel_le (x y : premises) : rel := ((x ∨ y)%nes, y). - - Infix "≡" := rel_eq (at level 70, no associativity) : rel_scope. - Infix "≤" := rel_le (at level 50, no associativity) : rel_scope. - - Reserved Notation " p ⊢ℒ r " (at level 72, no associativity). - - Inductive entails_L (p : rels) : NES.t × NES.t -> Prop := - | entails_c {l r} : List.In (l, r) p -> p ⊢ℒ l ≡ r - | entails_refl {x} : p ⊢ℒ x ≡ x - | entails_sym {x y} : p ⊢ℒ x ≡ y -> p ⊢ℒ y ≡ x - | entails_trans {x y z} : p ⊢ℒ x ≡ y -> p ⊢ℒ y ≡ z -> p ⊢ℒ x ≡ z - | entails_add_congr {x y n} : p ⊢ℒ x ≡ y -> p ⊢ℒ add_prems n x ≡ add_prems n y - | entails_add_inj {n x y} : p ⊢ℒ (add_prems n x) ≡ (add_prems n y) -> p ⊢ℒ x ≡ y - | entails_join_congr {x y r} : p ⊢ℒ x ≡ y -> p ⊢ℒ (x ∨ r) ≡ (y ∨ r) - | entails_assoc {x y z} : p ⊢ℒ ((x ∨ y) ∨ z) ≡ (x ∨ (y ∨ z)) - | entails_idem {x} : p ⊢ℒ (x ∨ x) ≡ x - | entails_comm {x y} : p ⊢ℒ (x ∨ y) ≡ (y ∨ x) - | entails_sub {x} : p ⊢ℒ (x ∨ succ_prems x) ≡ (succ_prems x) - | entails_add_join {n x y} : p ⊢ℒ (add_prems n (x ∨ y)) ≡ (add_prems n x ∨ add_prems n y) - where " p ⊢ℒ r " := (entails_L p r%_rel). - Derive Signature for entails_L. - - Lemma entails_join_congr_all {p} {x x' y y'} : - p ⊢ℒ x ≡ x' -> p ⊢ℒ y ≡ y' -> p ⊢ℒ (x ∨ y) ≡ (x' ∨ y'). - Proof. - intros he he'. - eapply entails_trans with (x' ∨ y). - now apply entails_join_congr. - rewrite (@union_comm x' y) (@union_comm x' y'). - now apply entails_join_congr. - Qed. - - Lemma entails_join_congr_all_inv {p} {x x' y z} : p ⊢ℒ (x ∨ y) ≡ z -> p ⊢ℒ x ≡ x' -> p ⊢ℒ (x' ∨ y) ≡ z. - Proof. - intros he he'. - eapply entails_trans with (x ∨ y) => //. - apply entails_join_congr => //. now eapply entails_sym. - Qed. - - Lemma entails_join_congr_all_inv_r {p} {x y y' z} : p ⊢ℒ (x ∨ y) ≡ z -> p ⊢ℒ y ≡ y' -> p ⊢ℒ (x ∨ y') ≡ z. - Proof. - intros he he'. - eapply entails_trans with (x ∨ y) => //. - rewrite !(@union_comm x). - apply entails_join_congr => //. now eapply entails_sym. - Qed. - - Section pres_Semilattice. - Import Semilattice. - Context (p : presentation). - - Definition relations (c : list (NES.t × NES.t)) : Prop := - List.Forall (fun '(l, r) => l = r) c. - - Definition univ_le (u u' : premises) := - forall l k, LevelExprSet.In (l, k) u -> exists k', LevelExprSet.In (l, k') u /\ (k <= k')%Z. - - Definition univ_eq u u' := - univ_le u u' /\ univ_le u' u. - - Infix "≌" := univ_eq (at level 70, no associativity). - - Lemma univ_le_refl u u' : u = u' -> univ_le u u'. - Proof. - intros <- l k hin; exists k; split => //; lia. - Qed. - - Lemma univ_eq_refl u u' : u = u' -> univ_eq u u'. - Proof. - split; apply univ_le_refl; tea. now symmetry. - Qed. - - Lemma univ_eq_sym u u' : univ_eq u u' -> univ_eq u' u. - Proof. - move=> [] le le'. split; auto. - Qed. - - Lemma univ_eq_trans u u' u'' : univ_eq u u' -> univ_eq u' u'' -> univ_eq u u''. - Proof. - move=> [] le le' [] le0 le0'. split; auto. - Qed. - - Lemma univ_add_le_inj {n u v} : univ_le (add_prems n u) (add_prems n v) -> univ_le u v. - Proof. - intros hle l k hin. - move: (hle l (n + k)%Z) => /fwd. - { apply In_add_prems. exists (l, k); split => //. } - move=> [] k' [] /In_add_prems [] [] l' k2 [] inu [=] -> -> hle'. - exists k2. split => //. lia. - Qed. - - Lemma univ_add_inj {n u v} : univ_eq (add_prems n u) (add_prems n v) -> univ_eq u v. - Proof. - move=> [] le le'. split; eauto using univ_add_le_inj. - Qed. - - (* To model subsumption correctly, we need a larger relation than Leibniz equality. - In other words, (x ∨ add 1 x) <> add 1 x. *) - Equations? pres_semilattice : Semilattice NES.t Z := - pres_semilattice := - {| eq x y := relations p.(C) -> univ_eq x y; - add := add_prems; - join x y := x ∪ y |}. - Proof. - all:intros. - - split; red; intros. - * now apply univ_eq_refl. - * now apply univ_eq_sym, H. - * now eapply univ_eq_trans; eauto. - - rewrite add_prems_add_prems. now apply univ_eq_refl. - - specialize (H H0). destruct H as [le le']. - split; move=> l k /In_add_prems => -[[l' k'] [hin [=]]] -> ->. - * exists (n + k')%Z. split => //. apply In_add_prems. - exists (l', k'). split => //. reflexivity. - * exists (n + k')%Z; split => //. apply In_add_prems. - exists (l', k'); split => //. reflexivity. - - rewrite add_prems_0. now apply univ_eq_refl. - - apply univ_eq_refl. now rewrite union_assoc. - - apply univ_eq_refl. now rewrite union_comm. - - split. intros l k; rewrite !LevelExprSet.union_spec. - intros []; exists k; split => //; try lia; - now rewrite union_spec. - intros l k hin. exists k. split => //. lia. - - split. intros l k; rewrite !LevelExprSet.union_spec. - intros []; exists k; split => //; try lia; - now rewrite union_spec. - intros l k hin. exists k. split => //. lia. - - split. intros l k hin. exists k. split => //. reflexivity. - intros l k hin. exists k. split => //; reflexivity. - - specialize (H H0). now eapply univ_add_inj. - - apply univ_eq_refl. now rewrite add_prems_union. - Qed. - End pres_Semilattice. - - Hint Constructors entails_L : entails_L. - - Lemma entails_L_le_refl p x : - p ⊢ℒ x ≤ x. - Proof. - eapply entails_idem. - Qed. - - Lemma entails_L_le_trans p x y z : - p ⊢ℒ x ≤ y -> p ⊢ℒ y ≤ z -> p ⊢ℒ x ≤ z. - Proof. - intros le le'. - eapply entails_trans. 2:exact le'. - eapply entails_trans with (x ∨ y ∨ z). - rewrite union_assoc. eapply entails_sym. - eapply entails_join_congr_all => //. apply entails_refl. - rewrite union_assoc. - eapply entails_trans with (x ∨ ((y ∨ y) ∨ z)). - eapply entails_join_congr_all; auto with entails_L. - rewrite union_assoc -union_assoc. - now eapply entails_join_congr_all. - Qed. - - Lemma subset_union {u u' : premises} : - u ⊂_leset u' -> u ∨ u' = u'. - Proof. - intros hincl; apply equal_exprsets => l. - rewrite union_spec. firstorder. - Qed. - - Lemma incl_entails_L {cls} {u u' : premises} : - u ⊂_leset u' -> cls ⊢ℒ u ≤ u'. - Proof. - move=> hincl. unfold rel_le. - rewrite subset_union //; auto with entails_L. - Qed. - - Lemma entails_L_subset {cls} {prems prems' prems'' : premises} : - cls ⊢ℒ prems ≤ prems' -> - prems' ⊂_leset prems'' -> - cls ⊢ℒ prems ≤ prems''. - Proof. - move=> heq /(@incl_entails_L cls). - now eapply entails_L_le_trans. - Qed. - - Lemma entails_L_rels_subset {rels rels' r} : - rels ⊢ℒ r -> - incl rels rels' -> - rels' ⊢ℒ r. - Proof. - induction 1; try solve [econstructor; eauto]. - Qed. - Definition relation_of_constraint c := let '(l, d, r) := c in match d with @@ -1241,100 +993,11 @@ End ZUnivConstraint. {| V := levels_of_z_constraints cstrs; C := relations_of_constraints cstrs |}. - Definition entails_L_clause p cl := - p ⊢ℒ singleton (concl cl) ≤ premise cl. - - Definition relations_of_clauses c := - Clauses.fold (fun '(prems, concl) acc => (singleton concl ∨ prems, prems) :: acc) c []. - - Definition clauses_of_relations r := - List.fold_right (fun '(l, r) acc => Clauses.union (clauses_of_eq l r) acc) Clauses.empty r. - - Lemma clauses_of_relations_spec {rels} : - forall cl, Clauses.In cl (clauses_of_relations rels) -> - exists r, In r rels /\ Clauses.In cl (clauses_of_eq r.1 r.2). - Proof. - rewrite /clauses_of_relations. - induction rels; cbn. - - clsets. - - move=> cl. destruct a as [l r]; cbn in *. - rewrite Clauses.union_spec => -[]. - * rewrite /clauses_of_eq Clauses.union_spec => -[inl|inr]; cbn; - rw Clauses.union_spec; cbn. - exists (l, r). split => //. now left. cbn. now left. - exists (l, r). split => //. now left. cbn. now right. - * move/IHrels => [[l' r'] [hin]]; cbn in *. - rewrite /clauses_of_eq Clauses.union_spec => -[inl|inr]; cbn; - rw Clauses.union_spec; now exists (l', r'); split => //. - Qed. - - - Lemma clauses_of_relations_spec_inv {rels} : - forall r, In r rels -> - Clauses.Subset (clauses_of_eq r.1 r.2) (clauses_of_relations rels). - Proof. - rewrite /clauses_of_relations. - induction rels; cbn. - - clsets. - - move=> [l r] //= []. - * move=> -> ?. rewrite Clauses.union_spec; now left. - * move/IHrels => //= hin ?. destruct a as [l' r']. - rewrite Clauses.union_spec; now right. - Qed. - - Lemma relations_of_clauses_spec {cls} : - forall eq, In eq (relations_of_clauses cls) -> - exists prems concl, Clauses.In (prems, concl) cls /\ - eq = (NES.singleton concl ∨ prems, prems). - Proof. - rewrite /relations_of_clauses. - eapply ClausesProp.fold_rec. - - move=> s'he eq => //=. - - move=> x a s' s'' hin hnin hadd ih eq. - destruct x as [prems concl]. cbn. - intros [<-|ina]. - * do 2 eexists. split => //. apply hadd. now left. - * move: (ih _ ina) => [? [? []]]. do 2 eexists; split => //. - apply hadd. now right. assumption. - Qed. - - Lemma relations_of_clauses_spec_inv {cls} : - forall cl, Clauses.In cl cls -> - In (NES.singleton (concl cl) ∨ premise cl, premise cl) (relations_of_clauses cls). - Proof. - rewrite /relations_of_clauses. - eapply ClausesProp.fold_rec. - - move=> s'he eq => //=. - - move=> x a s' s'' hin hnin hadd ih eq. - destruct x as [prems concl]. cbn. - rewrite hadd. - intros [<-|ina]. - * cbn. now left. - * move: (ih _ ina) => insing. now right. - Qed. Definition presentation_of_clauses cls := {| V := Clauses.clauses_levels cls; C := relations_of_clauses cls |}. - Lemma in_pred_closure_entails_clause {cls cl} : - in_pred_closure cls cl -> - entails cls cl. - Proof. - destruct cl as [prems concl]; intros inp. - eapply clause_cut; trea. - constructor. now apply NES.add_spec. - Qed. - - Lemma in_clause_of_le {le} {l r : premises} : - LevelExprSet.In le l <-> - Clauses.Clauses.In (r, le) (l ⋞ r). - Proof. - rewrite clauses_of_le_spec. - split. - - exists le. split => //. - - intros [lk [hin [=]]]. now subst le. - Qed. Lemma entails_clauses_le {cstrs l r} : ZUnivConstraintSet.In (l, ConstraintType.Le, r) cstrs -> @@ -1385,32 +1048,9 @@ End ZUnivConstraint. rewrite Theory.to_entails_all. now apply entails_clauses_le. Qed. - - Lemma add_idem {l x} : NES.add l (NES.add l x) = NES.add l x. - Proof. - apply equal_exprsets => l'. - rewrite !NES.add_spec. firstorder. - Qed. - - Lemma entails_L_idem_gen {le} {prems : premises} {p} : - LevelExprSet.In le prems -> - p ⊢ℒ (singleton le) ∨ prems ≡ prems. - Proof. - move: prems; apply: NES.elim. - - move=> le' /LevelExprSet.singleton_spec <-. - apply entails_idem. - - move=> le' x hin hnin /LevelExprSet.add_spec []. - * intros eq; subst le'. - rewrite union_comm union_add_singleton. - rewrite add_idem. apply entails_refl. - * move/hin => heq. - rewrite -!union_add_singleton -union_assoc. - now apply entails_join_congr. - Qed. - Lemma presentation_of_clauses_spec cls prems concl : - Clauses.In (prems, concl) cls -> - In (NES.singleton concl ∨ prems, prems) (C (presentation_of_clauses cls)). + Clauses.In (prems, concl) cls -> + In (NES.singleton concl ∨ prems, prems) (C (presentation_of_clauses cls)). Proof. rewrite /presentation_of_clauses //=. move/relations_of_clauses_spec_inv => //=. @@ -1420,168 +1060,6 @@ End ZUnivConstraint. noconf heq. *) - Lemma in_pred_closure_entails_L {cls} cl : - in_pred_closure cls cl -> - entails_L_clause (relations_of_clauses cls) cl. - Proof. - induction 1. - - rewrite /entails_L_clause /rel_le. - destruct cl as [prems concl]; cbn. - rewrite -add_prems_singleton -add_prems_union. - apply entails_add_congr. - apply entails_c. now eapply presentation_of_clauses_spec. - - replace (x, (k + 1)%Z) with (add_expr 1 (x, k)). - rewrite -add_prems_singleton. red; cbn. - eapply entails_sub. - now rewrite /succ_expr Z.add_comm. - Qed. - - Lemma entails_L_le_eq {cls l r} : cls ⊢ℒ l ≤ r -> cls ⊢ℒ l ∨ r ≡ r. - Proof. trivial. Qed. - - Lemma entails_L_eq_le_1 {cls} {l r} : cls ⊢ℒ l ≡ r -> cls ⊢ℒ l ≤ r. - Proof. - intros eq; unfold rel_le. - eapply (entails_join_congr_all_inv (x := r)). - eapply entails_idem. now eapply entails_sym. - Qed. - - Lemma entails_L_eq_le_2 {cls} {l r} : cls ⊢ℒ l ≡ r -> cls ⊢ℒ r ≤ l. - Proof. - intros eq; unfold rel_le. - eapply entails_sym in eq. now eapply entails_L_eq_le_1 in eq. - Qed. - - Lemma entails_L_eq_antisym {cls} {l r} : cls ⊢ℒ r ≤ l -> cls ⊢ℒ l ≤ r -> cls ⊢ℒ l ≡ r. - Proof. - unfold rel_le. intros le le'. - eapply entails_trans with (l ∨ r) => //. - apply entails_sym. now rewrite union_comm. - Qed. - - Lemma entails_L_le_join_l {p x x' r} : - p ⊢ℒ x ≤ x' -> - p ⊢ℒ (x ∨ r) ≤ (x' ∨ r). - Proof. - intros le. - unfold rel_le in le |- *. - rewrite union_assoc (@union_comm r) union_assoc -union_assoc. - eapply entails_join_congr_all => //. - apply entails_idem. - Qed. - - Lemma entails_L_le_congr {p x y x' y'} : - p ⊢ℒ x ≤ x' -> - p ⊢ℒ y ≤ y' -> - p ⊢ℒ x ∨ y ≤ x' ∨ y'. - Proof. - move/(entails_L_le_join_l (r:=y)) => le le'. - eapply entails_L_le_trans; tea. - rewrite !(@union_comm x'). - now eapply entails_L_le_join_l. - Qed. - - Lemma entails_L_le_idem {p x} : - p ⊢ℒ x ∨ x ≤ x. - Proof. - eapply entails_L_eq_le_1, entails_idem. - Qed. - - Lemma entails_L_le_join {p x y z} : - p ⊢ℒ x ≤ z -> - p ⊢ℒ y ≤ z -> - p ⊢ℒ x ∨ y ≤ z. - Proof. - move=> le le'. - have := entails_L_le_congr le le' => comb. - eapply entails_L_le_trans; tea. - eapply entails_L_le_idem. - Qed. - - Lemma entails_clause_pres {cls} cl : - entails cls cl -> - entails_L_clause (relations_of_clauses cls) cl. - Proof. - intros h; induction h. - - red. - now apply entails_L_idem_gen. - - move: IHh; rewrite -!union_add_singleton. - eapply in_pred_closure_entails_L in H. - rewrite /entails_L_clause in H |- *; cbn in *. - have hsub:= entails_L_subset H H0. - move=> h'. - eapply entails_L_le_trans. tea. - move/entails_L_eq_le_1: hsub. now rewrite union_comm. - Qed. - - Definition entails_L_clauses p cls := - Clauses.For_all (entails_L_clause p) cls. - - Lemma entails_clauses_pres {cls} cls' : - cls ⊢ℋ cls' -> - entails_L_clauses (relations_of_clauses cls) cls'. - Proof. - move=> h cl /h. apply entails_clause_pres. - Qed. - - Lemma entails_L_clauses_eq {p s t} : - entails_L_clauses p (s ≡ t) <-> - entails_L_clauses p (s ⋞ t) /\ entails_L_clauses p (t ⋞ s). - Proof. - rewrite /entails_L_clauses /clauses_of_eq. - split. - - intros ha; split => l; move:(ha l); rewrite Clauses.union_spec; - intros he hle; apply he; now constructor. - - intros [le le'] l. - rewrite Clauses.union_spec; intros []; [apply le|apply le']; assumption. - Qed. - - Lemma entails_L_split p (s t : premises) : - (forall le, LevelExprSet.In le s -> p ⊢ℒ singleton le ≤ t) -> - p ⊢ℒ s ≤ t. - Proof. - move: s; apply: NES.elim. - - intros [l k] ih. eapply ih. - now apply LevelExprSet.singleton_spec. - - move=> le x h hnin ih. - forward h. - { move=> le' hin. move: (ih le') => /fwd //. - eapply LevelExprSet.add_spec. now right. } - specialize (ih le); forward ih. - eapply LevelExprSet.add_spec; now left. - rewrite -union_add_singleton. - now eapply entails_L_le_join. - Qed. - - Lemma entails_L_le_left {p x y} : - p ⊢ℒ x ≤ x ∨ y. - Proof. - rewrite /rel_le. rewrite -union_assoc. - eapply entails_join_congr_all. apply entails_idem. apply entails_refl. - Qed. - - Lemma entails_L_le_right {p x y} : - p ⊢ℒ y ≤ x ∨ y. - Proof. - rewrite union_comm; apply entails_L_le_left. - Qed. - - Lemma entails_L_in p l (t : premises) : - LevelExprSet.In l t -> - p ⊢ℒ NES.singleton l ≤ t. - Proof. - move: t; apply: NES.elim. - - move=>[l' k] /LevelExprSet.singleton_spec => ->. - apply entails_L_le_refl. - - move=> le x h hnin /NES.add_spec []. - * intros ->. rewrite -union_add_singleton. - apply entails_L_le_right. - * move/h => hle. - rewrite -union_add_singleton. - eapply entails_L_le_trans with x => //. - apply entails_L_le_left. - Qed. - Lemma entails_L_clauses_all {cstrs s t} : (relations_of_clauses (of_z_constraints cstrs)) ⊢ℒ s ≡ t -> (relations_of_constraints cstrs) ⊢ℒ s ≡ t. @@ -1612,27 +1090,6 @@ End ZUnivConstraint. eexists; split; tea. cbn. now cbn. Qed. - Lemma entails_L_clauses_pres_all {p s t} : - (relations_of_clauses (clauses_of_relations p)) ⊢ℒ s ≡ t -> - p ⊢ℒ s ≡ t. - Proof. - induction 1; try solve [econstructor; eauto]. cbn in H. - move/relations_of_clauses_spec: H => [prems [concl [hin heq]]]. - noconf heq. - move/clauses_of_relations_spec: hin => [[l r]] [] hin //=. - rewrite /clauses_of_eq Clauses.union_spec => -[] hin'; - eapply entails_L_le_eq; - rewrite clauses_of_le_spec in hin'. - - destruct hin' as [? [hin' heq]]. noconf heq. - eapply entails_L_le_trans with l. - * now eapply entails_L_in. - * eapply entails_L_eq_le_1. now constructor. - - destruct hin' as [? [hin' heq]]; noconf heq. - eapply entails_L_le_trans with r. - + now eapply entails_L_in. - + eapply entails_L_eq_le_1. eapply entails_sym. now constructor. - Qed. - Lemma entails_L_clauses_le {cstrs s t} : entails_L_clauses (relations_of_clauses (of_z_constraints cstrs)) (s ⋞ t) -> relations_of_constraints cstrs ⊢ℒ s ≤ t. @@ -1695,14 +1152,6 @@ End ZUnivConstraint. Definition interp_univ_cstrs c := UnivConstraintSet.For_all interp_univ_cstr c. - Definition interp_expr '(l, k) := (add k (v l))%Z. - - Definition interp_rel r := - let '(l, r) := r in - interp_prems v l ≡ interp_prems v r. - - Definition interp_rels c := - List.Forall interp_rel c. End interp. Structure semilattice := @@ -1722,108 +1171,6 @@ End ZUnivConstraint. Definition valid_cstrs p cstrs := ZUnivConstraintSet.For_all (valid_constraint p) cstrs. - Lemma entails_clauses_pres_eq_left {p l r} : - In (l, r) p -> - clauses_of_relations p ⊢a r → l. - Proof. - intros hin l' cl. - eapply in_pred_closure_entails_clause, incls0. - eapply clauses_of_relations_spec_inv. tea. cbn. - rewrite /clauses_of_eq Clauses.union_spec. left. - apply clauses_of_le_spec. now exists l'. - Qed. - - Lemma entails_clauses_pres_eq_right {p l r} : - In (l, r) p -> - clauses_of_relations p ⊢a l → r. - Proof. - intros hin l' cl. - eapply in_pred_closure_entails_clause, incls0. - eapply clauses_of_relations_spec_inv. tea. cbn. - rewrite /clauses_of_eq Clauses.union_spec. right. - apply clauses_of_le_spec. now exists l'. - Qed. - - Lemma entails_clauses_eq_pres {p l r} : - In (l, r) p -> - clauses_of_relations p ⊢ℋ l ≡ r. - Proof. - intros hin. - apply Theory.eq_antisym. - split. - - rewrite Theory.to_entails_all. now apply entails_clauses_pres_eq_left. - - rewrite Theory.to_entails_all. now apply entails_clauses_pres_eq_right. - Qed. - - Lemma entails_L_clauses_pres_le {p s t} : - entails_L_clauses (relations_of_clauses (clauses_of_relations p)) (s ⋞ t) -> - p ⊢ℒ s ≤ t. - Proof. - intros hf. do 2 red in hf. - rw_in clauses_of_le_spec hf. - eapply entails_L_split. - move=> le hin. - move: (hf (t, le)) => /fwd. - { exists le; split => //. } - move=> h; red in h. cbn in h. - now eapply entails_L_clauses_pres_all in h. - Qed. - - Lemma entails_L_clauses_of_relations_eq {p s t} : - entails_L_clauses (relations_of_clauses (clauses_of_relations p)) (s ≡ t) -> - p ⊢ℒ s ≡ t. - Proof. - intros hf. do 2 red in hf. - eapply entails_L_eq_antisym. - all: apply entails_L_clauses_pres_le. - - intros cl hin; red. eapply hf. - rewrite /clauses_of_eq. clsets. - - intros cl hin; red. eapply hf. - rewrite /clauses_of_eq. clsets. - Qed. - - Lemma completeness_eq p s t : - p ⊢ℒ s ≡ t <-> - clauses_of_relations p ⊢ℋ clauses_of_eq s t. - Proof. - split. - - intros h; depind h; cbn. - * now eapply entails_clauses_eq_pres. - * eapply Theory.eq_refl. - * now eapply Theory.eq_sym. - * now eapply Theory.eq_trans. - * now eapply Theory.succ_congr. - * now eapply Theory.succ_inj. - * now eapply Theory.join_congr_left. - * eapply Theory.join_assoc. - * eapply Theory.join_idem. - * eapply Theory.join_comm. - * eapply Theory.join_succ. - * eapply Theory.succ_join. - - move/entails_clauses_pres. apply entails_L_clauses_of_relations_eq. - Qed. - - Instance entails_all_proper : Proper (Clauses.Equal ==> Logic.eq ==> Logic.eq ==> iff) entails_all. - Proof. - intros cls cls' H ? ? <- ? ? <-. - split; intros ? ? hin. rewrite -H. now apply H0. - rewrite H; now apply H0. - Qed. - - Instance entails_clauses_proper : Proper (Clauses.Equal ==> Clauses.Equal ==> iff) entails_clauses. - Proof. - intros cls cls' H ? ? H'. - split; intros ? ? hin. rewrite -H. apply H0. now rewrite H'. - rewrite H; apply H0. now rewrite -H'. - Qed. - - Instance entails_equiv_proper : Proper (Clauses.Equal ==> Logic.eq ==> Logic.eq ==> iff) entails_equiv. - Proof. - intros cls cls' H ? ? <- ?? <-. - split. - - intros []; split; now rewrite -H. - - intros []; split; now rewrite H. - Qed. Lemma to_clauses_of_z_constraints {cstrs} : to_clauses cstrs =_clset of_z_constraints (to_z_cstrs cstrs). @@ -1875,7 +1222,7 @@ End ZUnivConstraint. * eapply Theory.join_comm. * eapply Theory.join_succ. * eapply Theory.succ_join. - - move/entails_clauses_pres; apply entails_L_clauses_of_eq. + - move/entails_ℋ_entails_L; apply entails_L_clauses_of_eq. Qed. Lemma completeness_le cstrs s t : @@ -1887,7 +1234,7 @@ End ZUnivConstraint. - move/completeness_eq_cstrs. cbn. intros h; red in h. cbn in h. eapply Theory.le_spec. now rewrite /C.le. - - move/entails_clauses_pres. apply entails_L_clauses_le. + - move/entails_ℋ_entails_L. apply entails_L_clauses_le. Qed. Import LoopCheck.Impl.I.Model.Model.Clauses.FLS. @@ -1914,31 +1261,7 @@ End ZUnivConstraint. Section SemiLatticeInterp. Import Semilattice. - Lemma presentation_entails_valid_rel {p r} : - p ⊢ℒ r -> valid_relation p r. - Proof. - rewrite /valid_relation //=. - destruct r as [l r] => //=. - intros h; depind h; cbn; move=> s v hv. - 1:{ red in hv. rewrite Forall_forall in hv; eapply hv in H. exact H. } - all:try specialize (IHh _ _ eq_refl s _ hv). - all:try specialize (IHh1 _ _ eq_refl s _ hv). - all:try specialize (IHh2 _ _ eq_refl s _ hv). - all:try lia; eauto. - all:rewrite ?interp_add_prems ?interp_prems_union ?interp_add_prems; try lia. - - eapply reflexivity. - - now eapply symmetry, IHh. - - eapply transitivity; [eapply IHh1|eapply IHh2] => //. - - now apply add_congr. - - rewrite ?interp_add_prems in IHh. - now apply add_inj in IHh. - - now apply join_congr. - - apply join_assoc. - - apply join_idem. - - apply join_comm. - - apply (join_sub (Semilattice := sl s)). - - now apply add_join. - Qed. + Lemma presentation_entails_valid_eq {p l r} : p ⊢ℒ l ≡ r -> valid_constraint p (l, ConstraintType.Eq, r). @@ -2270,66 +1593,6 @@ Qed. *) * *) - Lemma entails_cut {cls cl cl'} : - entails cls cl -> - entails (Clauses.add cl cls) cl' -> - entails cls cl'. - Proof. - intros ent ent'. - induction ent'. - - now constructor. - - depelim H. - * eapply Clauses.add_spec in H as [->|hin]. - destruct cl as [prems2 concl2]. noconf H0. - + apply: (@entails_add cls prems (add_expr n concl2) _ _ IHent'). - eapply entails_subset; tea. - now eapply (@entails_shift _ (_, _) n). - + destruct cl0 as [prems'' concl'']; noconf H0. - have h := (@entails_add cls prems (add_expr n concl'') _ _ IHent'). - apply h. - eapply entails_subset; tea. - eapply (@entails_shift _ (_, _) n). - now eapply entails_in. - * apply: (@entails_add cls prems (x, k)). - eapply clause_cut; tea. - { constructor 2; tea. } - { constructor. now rewrite LevelExprSet.add_spec. } - assumption. - Qed. - - Lemma entails_clauses_cut_one {cls cls0 cl} : - cls ⊢ℋ cls0 -> - entails (Clauses.union cls0 cls) cl -> - entails cls cl. - Proof. - move: cls0 cls cl. apply: ClausesProp.set_induction. - - intros s he cls0 cl ent. - have -> : Clauses.union s cls0 =_clset cls0. - { clsets. } - by []. - - move=> s0 s1 ih x hin hadd s2 cl ent. - have s0ent : s2 ⊢ℋ s0. - { move=> cl' hin'. apply ent, hadd. now right. } - specialize (ih s2 cl s0ent). - rewrite ClausesProp.Add_Equal in hadd. - rewrite hadd in ent. do 2 red in ent. - rewrite hadd ClausesProp.add_union_singleton ClausesProp.union_assoc -ClausesProp.add_union_singleton. - move: (ent x) => /fwd. now apply Clauses.add_spec. - move=> entx. destruct x as [prems concl]. - eapply (entails_clauses_subset _ (Clauses.union s0 s2)) in entx. - 2:{ clsets. } - move=> ent'. apply ih. - eapply entails_cut; tea. - Qed. - - Lemma entails_clauses_cut {cls cls0 cls1} : - cls ⊢ℋ cls0 -> - Clauses.union cls0 cls ⊢ℋ cls1 -> - cls ⊢ℋ cls1. - Proof. - move=> ent ent' cl /ent' hin. - eapply entails_clauses_cut_one; tea. - Qed. Lemma entails_L_cut {Γ r r'} : Γ ⊢ℒ r -> @@ -2346,73 +1609,6 @@ Qed. *) - Section M0. - Context (rs : rels). - - Equations? M0 : Semilattice NES.t Z := - M0 := {| - eq x y := rs ⊢ℒ x ≡ y; - add := add_prems; - join := union |}. - Proof. - all:intros. all:try solve [econstructor; eauto]. - - split; intros. - * intros x. eapply entails_refl. - * intros x y. eapply entails_sym. - * intros x y z. eapply entails_trans. - - rewrite add_prems_add_prems. eapply entails_refl. - - rewrite add_prems_0. apply entails_refl. - Qed. - Print semilattice. - - #[export] Existing Instance M0. - - Definition initial_semilattice : semilattice := - {| carrier := NES.t; sl := _ |}. - - Definition ids := (fun l : Level.t => singleton (l, 0%Z)). - - Lemma interp_triv l : interp_prems ids l ≡ l. - Proof. - move: l; apply: elim. - - intros [l k]. - rewrite interp_prems_singleton //= /ids //=. - rewrite add_prems_singleton //= Z.add_0_r. - apply entails_refl. - - move=> [] l k x ih hnin. - have ha := (interp_prems_add (SL := M0) ids (l, k)). - rewrite ha ih. rewrite /Model.interp_expr. rewrite -union_add_singleton /ids. - rewrite [add _ _]add_prems_singleton /add_expr Z.add_0_r. - apply (join_comm (Semilattice := M0)). - Qed. - End M0. - - - Lemma interp_rels_init rs : interp_rels (SL := M0 rs) ids rs. - Proof. - unfold interp_rels; unfold interp_rel. cbn. - have ir : incl rs rs. - { now intros l. } - move: ir. - generalize rs at 1 6. - induction rs0; cbn. - - constructor. - - destruct a. constructor. - * change (eq (Semilattice := M0 rs) (interp_prems (s := M0 rs) ids t0) (interp_prems (s := M0 rs) ids t1)). - rewrite !interp_triv. - constructor. apply ir. now constructor. - * apply IHrs0. intros r hin; apply ir. now right. - Qed. - - Definition valid {S} (SL : Semilattice S Z) v r := - interp_rel (SL := SL) v r. - - Lemma syntax_model rs r : valid (M0 rs) ids r <-> rs ⊢ℒ r. - Proof. - rewrite /valid. - destruct r as [l r]. unfold interp_rel. - rewrite !interp_triv; split; apply. - Qed. Class Decidable (A : Prop) := dec : A \/ ~ A. Arguments dec A {Decidable}. @@ -2457,7 +1653,7 @@ Qed. *) Proof. rewrite LoopCheck.Impl.Abstract.check_clauses_spec. split. - - move/entails_clauses_pres. + - move/entails_ℋ_entails_L. move=> ent s v hyps cl /ent. admit. - intros valid. diff --git a/utils/theories/MRClasses.v b/utils/theories/MRClasses.v index 43032d84c..570a403f2 100644 --- a/utils/theories/MRClasses.v +++ b/utils/theories/MRClasses.v @@ -1,3 +1,4 @@ +From Corelib Require Import Relation_Definitions. Class Neutral {A} (f : A -> A -> A) (z : A) := neutral x : f z x = x. @@ -10,4 +11,4 @@ Class CommutativeMonoid {A} (zero : A) (add : A -> A -> A) := add_comm :: Commutative add; add_neutral :: Neutral add zero }. -Class Injective {A B} (f : A -> B) := inj : forall x y, f x = f y -> x = y. +Class Injective {A B} (f : A -> B) (R : relation A) (R' : relation B) := inj : forall x y, R' (f x) (f y) -> R x y. diff --git a/utils/theories/MRList.v b/utils/theories/MRList.v index 580b8b0be..bd28b3cc6 100644 --- a/utils/theories/MRList.v +++ b/utils/theories/MRList.v @@ -27,6 +27,13 @@ Qed. Lemma app_tip_assoc {A} (l : list A) x l' : (l ++ [x]) ++ l' = l ++ (x :: l'). Proof. now rewrite <- app_assoc. Qed. +Lemma fold_right_map {A B C} (f : B -> A -> A) (g : C -> B) acc l : + fold_right (fun x acc => f (g x) acc) acc l = + fold_right (fun x acc => f x acc) acc (List.map g l). +Proof. + induction l; cbn; auto. congruence. +Qed. + Fixpoint fold_left_i_aux {A B} (f : A -> nat -> B -> A) (n0 : nat) (l : list B) (a0 : A) {struct l} : A := match l with diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v index ae4153b20..7593614fe 100644 --- a/utils/theories/NonEmptyLevelExprSet.v +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -17,14 +17,58 @@ Module Type OrderedTypeWithLeibnizWithReflect. Parameter to_string : t -> string. End OrderedTypeWithLeibnizWithReflect. +Module CommutativeMonoid. +Class IsCommMonoid (A : Type) := + { zero : A; + one : A; + add : A -> A -> A; + comm_mon :: CommutativeMonoid zero add }. + +Declare Scope comm_monoid. +Notation "0" := zero : comm_monoid. +Notation "1" := one : comm_monoid. +Notation "+" := add : comm_monoid. +End CommutativeMonoid. + Module Type Quantity. Include OrderedTypeWithLeibniz. - Parameter zero : t. - Parameter add : t -> t -> t. - Declare Instance comm_monoid : CommutativeMonoid zero add. - Declare Instance add_inj n : Injective (add n). + Import CommutativeMonoid. + + Declare Instance comm_monoid : IsCommMonoid t. + Declare Instance add_inj_eq n : Injective (add n) Logic.eq Logic.eq. + Declare Instance add_inj_lt n : Injective (add n) lt lt. End Quantity. +Module OfQuantity (Q : Quantity). + Import CommutativeMonoid. + Import Q. + + Declare Scope quantity. + Bind Scope quantity with t. + Delimit Scope quantity with Q. + Infix "+" := add : quantity. + + Definition le (x y : t) := lt x y \/ eq x y. + + Instance le_refl : Reflexive le. + Proof. red. now right. Qed. + + Instance le_trans : Transitive le. + Proof. red. intros x y z [] []. + - left. now transitivity y. + - rewrite -H0. now left. + - rewrite H. now left. + - rewrite H H0. now right. + Qed. + + Lemma add_inj_le {n} : Injective (add n) le le. + Proof. + intros x y []. left. now apply inj in H. + apply inj in H. now right. + Qed. + +End OfQuantity. + Module Type LevelExprT (Level : OrderedTypeWithLeibniz) (Q : Quantity). Include UsualOrderedType with Definition t := (Level.t * Q.t)%type. Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. @@ -64,6 +108,9 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) Infix "⊂_leset" := LevelExprSet.Subset (at level 90). Infix "=_leset" := LevelExprSet.Equal (at level 90). + Import CommutativeMonoid. + Module Export OfQ := OfQuantity Q. + Definition level : LevelExpr.t -> Level.t := fst. Definition levels (e : t) := @@ -86,7 +133,9 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) Existing Instance LevelExprSet.reflect_eq. Existing Instance Q.comm_monoid. - Existing Instance Q.add_inj. + Existing Instance Q.add_inj_eq. + Existing Instance Q.add_inj_lt. + Existing Instance OfQ.add_inj_le. (* We use uip on the is_empty condition *) #[export, program] Instance reflect_eq : ReflectEq t := @@ -504,10 +553,11 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) firstorder eauto. subst. firstorder. Qed. - Definition add_expr n '((l, k) : LevelExpr.t) := (l, Q.add n k). + Definition add_expr n '((l, k) : LevelExpr.t) := (l, CommutativeMonoid.add n k). - Lemma add_expr_add_expr n n' lk : add_expr n (add_expr n' lk) = add_expr (Q.add n n') lk. - Proof. destruct lk; unfold add_expr. f_equal. symmetry. now rewrite (MRClasses.assoc (f:=Q.add)). Qed. + Lemma add_expr_add_expr n n' lk : add_expr n (add_expr n' lk) = add_expr (CommutativeMonoid.add n n') lk. + Proof. destruct lk; unfold add_expr. f_equal. symmetry. + now rewrite (MRClasses.assoc (f:=CommutativeMonoid.add)). Qed. Definition add_prems n s := map (add_expr n) s. Lemma In_add_prems k (prems : t): @@ -522,14 +572,14 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) Proof. destruct e, e'; cbn; rewrite /add_expr. move=> [=] ->. - now move/(inj (f:=Q.add n)) => ->. + now move/(inj (f:=CommutativeMonoid.add n)) => ->. Qed. Lemma add_prems_inj n prems prems' : add_prems n prems = add_prems n prems' -> prems = prems'. Proof. rewrite /add_prems => /equal_exprsets hm. apply equal_exprsets. - intros [l k]. specialize (hm (l, Q.add n k)). + intros [l k]. specialize (hm (l, CommutativeMonoid.add n k)). rewrite !map_spec in hm. destruct hm as [hl hr]. split; intros hin. - forward hl. exists (l, k); split => //. @@ -544,7 +594,7 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) Lemma inj_add_prems_sub {n u u'} : add_prems n u ⊂_leset add_prems n u' -> u ⊂_leset u'. Proof. rewrite /add_prems. - intros hm [l k]. specialize (hm (l, Q.add n k)). + intros hm [l k]. specialize (hm (l, CommutativeMonoid.add n k)). rewrite !map_spec in hm. intros hin. forward hm. exists (l, k); split => //. @@ -552,7 +602,7 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) apply (@add_expr_inj n (l, k)) in eq. now noconf eq. Qed. - Lemma add_prems_add_prems n n' lk : add_prems n (add_prems n' lk) = add_prems (Q.add n n') lk. + Lemma add_prems_add_prems n n' lk : add_prems n (add_prems n' lk) = add_prems (CommutativeMonoid.add n n') lk. Proof. destruct lk; unfold add_prems. rewrite map_map. apply equal_exprsets. intros x. rewrite !map_spec. cbn in *. @@ -570,12 +620,12 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) firstorder. subst. red in H; subst x0. now left. Qed. - Lemma add_expr_0 e : add_expr Q.zero e = e. + Lemma add_expr_0 e : add_expr CommutativeMonoid.zero e = e. Proof. destruct e => //=. now rewrite neutral. Qed. - Lemma add_prems_0 u : add_prems Q.zero u = u. + Lemma add_prems_0 u : add_prems CommutativeMonoid.zero u = u. Proof. rewrite /add_prems. apply equal_exprsets. @@ -585,5 +635,40 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) - intros inu; exists x. split => //. now rewrite add_expr_0. Qed. + Lemma add_prems_union {n u u'} : add_prems n (u ∪ u') = union (add_prems n u) (add_prems n u'). + Proof. + apply equal_exprsets => l. + rewrite In_add_prems. + setoid_rewrite union_spec. + rewrite !In_add_prems. firstorder. + Qed. + + Lemma add_idem {l x} : add l (add l x) = add l x. + Proof. + apply equal_exprsets => l'. + rewrite !add_spec. firstorder. + Qed. + + Lemma add_prems_singleton n cl : add_prems n (singleton cl) = singleton (add_expr n cl). + Proof. + apply equal_exprsets => [] [l k]. + rewrite In_add_prems LevelExprSet.singleton_spec. + firstorder. + - destruct x; noconf H0. + eapply LevelExprSet.singleton_spec in H. + now red in H; noconf H. + - destruct cl. red in H. noconf H. exists (t0, t1). split => //. + now apply LevelExprSet.singleton_spec. + Qed. + + Definition choose_prems (u : t) : LevelExpr.t := (to_nonempty_list u).1. + Lemma choose_prems_spec u : LevelExprSet.In (choose_prems u) u. + Proof. + rewrite /choose_prems. + have hs := to_nonempty_list_spec u. + destruct to_nonempty_list. cbn. + rewrite -LevelExprSet.elements_spec1 InA_In_eq -hs. + now constructor. + Qed. End NonEmptyLevelExprSet. diff --git a/utils/theories/SemiLattice.v b/utils/theories/SemiLattice.v index c8b109d74..20faa4759 100644 --- a/utils/theories/SemiLattice.v +++ b/utils/theories/SemiLattice.v @@ -1,21 +1,10 @@ (* Distributed under the terms of the MIT license. *) -From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import ssreflect ssrbool ssrfun ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils NonEmptyLevelExprSet. -Module CommutativeMonoid. - Class IsCommMonoid (A : Type) := - { zero : A; - one : A; - add : A -> A -> A; - comm_mon :: CommutativeMonoid zero add }. - - Declare Scope comm_monoid. - Notation "0" := zero : comm_monoid. - Notation "1" := one : comm_monoid. - Notation "+" := add : comm_monoid. -End CommutativeMonoid. +Set Equations Transparent. Module Semilattice. Declare Scope sl_scope. @@ -170,14 +159,3 @@ Module Semilattice. End Derived. End Semilattice. - -Module InitialSemilattice - (Level : OrderedTypeWithLeibniz) (Q : Quantity) - (LevelSet : LevelSet_fun Level) - (LevelExpr : LevelExprT Level Q) - (LevelExprSet : LevelExprSet_fun Level Q LevelExpr). - - - - -End InitialSemilattice. From d04a5e5a304a535554a23db6db30d4003659aefa Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 23 Sep 2025 18:28:16 +0200 Subject: [PATCH 062/164] WIP piecing together all results --- common/theories/LoopChecking/Deciders.v | 103 ++++++++-- .../LoopChecking/HornSemilatticeEquiv.v | 185 ++++++++++++++++-- .../LoopChecking/InitialSemilattice.v | 33 +++- common/theories/LoopChecking/ModelValuation.v | 11 -- .../theories/LoopChecking/UnivLoopChecking.v | 32 --- 5 files changed, 288 insertions(+), 76 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 73a5d4185..882f5e310 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -53,9 +53,8 @@ Module Import I := LoopCheckingImpl LS. Import LS. Local Open Scope Z_scope. -Module Import Equiv := HornSemilattice LS. -Import Equiv.SL. -Import Equiv. +(* Import I.Model.ISL. *) +(* Import Equiv *) Definition init_model cls := max_clause_premises cls. @@ -796,6 +795,8 @@ Module Abstract. intros [= <-]. now cbn. Qed. + Import I.Model.Model.Clauses.ISL. + Definition clause_sem {S} {SL : Semilattice S Q.t} V (cl : clause) : Prop := let '(prems, concl) := cl in le (interp_expr V concl) (interp_prems V prems). @@ -805,18 +806,91 @@ Module Abstract. Lemma enforce_clauses_inconsistent m cls u : enforce_clauses m cls = Some (inr u) -> - entails_L (relations_of_clauses (Clauses.union (clauses m) cls)) (loop_univ u, succ_prems (loop_univ u)). - (* ~ exists V, clauses_sem (SL := Zsemilattice) V (Clauses.union (clauses m) cls). *) + entails_L_clauses (Clauses.union (clauses m) cls) (loop_univ u ≡ succ_prems (loop_univ u)). Proof. funelim (enforce_clauses m cls) => //=. intros [= <-]. clear -u. destruct u as [u loop]. cbn [loop_univ]. - eapply Theory.to_entails_all in loop. - Admitted. + eapply to_entails_all in loop. + apply entails_L_clauses_eq; split; revgoals. + - now eapply entails_ℋ_entails_L. + - eapply entails_ℋ_entails_L. + eapply to_entails_all. + apply entails_all_succ. + Qed. Definition check_clauses m cls := check_clauses (clauses m) cls. + Instance entails_L_pres_clauses_proper : Proper (Logic.eq ==> Clauses.Equal ==> iff) entails_L_pres_clauses. + Proof. + intros ?? -> ? ? h. + rewrite /entails_L_pres_clauses. now rewrite h. + Qed. + + Lemma entails_L_pres_clauses_union {p cls cls'} : entails_L_pres_clauses p (Clauses.union cls cls') <-> + entails_L_pres_clauses p cls /\ + entails_L_pres_clauses p cls'. + Proof. + rewrite /entails_L_pres_clauses /Clauses.For_all. + setoid_rewrite Clauses.union_spec. by firstorder. + Qed. + + Lemma entails_L_rels_entails_rels p rs : + entails_L_rels p rs <-> entails_L_clauses (clauses_of_relations p) (clauses_of_relations rs). + Proof. + induction rs. + - split => //. + * intros ent cl hin. cbn in hin. clsets. + * cbn. constructor. + - split. + * intros ent; depelim ent. + unfold entails_L_clauses. + destruct a as [l r]. rewrite clauses_of_relations_cons entails_L_pres_clauses_union. split. + now eapply entails_L_clauses_relations, entails_L_pres_clauses_of_relations_eq. + apply IHrs, ent. + * unfold entails_L_clauses. + destruct a as [l r]. rewrite clauses_of_relations_cons entails_L_pres_clauses_union. + move=> [] lr ih. constructor. + apply (proj1 entails_L_pres_clauses_of_relations_eq) in lr. + now apply entails_L_clauses_pres_all in lr. + apply IHrs, ih. + Qed. + + Lemma entails_clauses_of_relations cls : entails_clauses cls (clauses_of_relations (relations_of_clauses cls)). + Proof. + apply entails_ℋ_clauses_of_relations_equiv. apply entails_clauses_tauto. + Qed. + + Lemma entails_clauses_trans {cls cls' cls''} : cls ⊢ℋ cls' -> cls' ⊢ℋ cls'' -> cls ⊢ℋ cls''. + Proof. + intros ent ent'. + eapply entails_clauses_cut; tea. + eapply entails_ℋ_clauses_subset; tea. clsets. + Qed. + + Lemma entails_L_rels_entails_L_clauses cls cls' : + entails_L_rels (relations_of_clauses cls) (relations_of_clauses cls') <-> entails_L_clauses cls cls'. + Proof. + rewrite entails_L_rels_entails_rels. + rewrite !entails_L_entails_ℋ_equiv. + split. + - intros cl. eapply entails_clauses_cut. eapply entails_ℋ_clauses_of_relations. tea. + eapply entails_ℋ_clauses_subset. eapply entails_clauses_tauto. intros cl' hin. + apply clauses_of_relations_relations_of_clauses in hin. + rewrite Clauses.union_spec. now left. + - intros hent. eapply (proj1 entails_ℋ_clauses_of_relations_equiv). + eapply entails_clauses_trans; tea. eapply entails_clauses_of_relations. + Qed. + + Definition to_val (v : LevelMap.t nat) l := + match LevelMap.find l v with + | Some n => n + | None => 0%nat + end. + + Definition to_Z_val (v : Level.t -> nat) := fun l => Z.of_nat (v l). + Lemma check_clauses_spec m cls : check_clauses m cls <-> entails_clauses (clauses m) cls. Proof. @@ -830,13 +904,18 @@ Module Abstract. eapply Clauses.for_all_spec; tc => cl hin. destruct check eqn:hc => //. * exfalso; eapply check_entails_looping in hc; tea. - eapply Theory.to_entails_all in hc. - Search entails_L. - - + eapply to_entails_all in hc. + eapply entails_L_entails_ℋ_equiv in hc. + eapply entails_L_rels_entails_L_clauses in hc. + apply completeness_all in hc. + red in hc. specialize (hc {| carrier := Z; sl := _ |}). cbn in hc. + specialize (hc (to_Z_val (to_val (valuation_of_model m.(model).(model_valid).(model_model))))). + cbn in *. + admit. +(* 2:eapply m.(model).(model_valid).(model_ok). eapply enabled_clauses_ext, m.(model).(enabled_model). - eapply (is_update_of_ext m.(model).(model_valid).(I.model_updates)). + eapply (is_update_of_ext m.(model).(model_valid).(I.model_updates)). *) * move/check_invalid: hc => he. exfalso. elim he. now apply hv. Qed. diff --git a/common/theories/LoopChecking/HornSemilatticeEquiv.v b/common/theories/LoopChecking/HornSemilatticeEquiv.v index f524eefbe..2a13e9204 100644 --- a/common/theories/LoopChecking/HornSemilatticeEquiv.v +++ b/common/theories/LoopChecking/HornSemilatticeEquiv.v @@ -11,7 +11,7 @@ Set Equations Transparent. Module HornSemilattice (LS : LevelSets). Module Export Clauses := Clauses LS. - Module Export SL := InitialSemilattice LS. + Module Import ISL := InitialSemilattice LS. Import NES. Local Open Scope sl_scope. @@ -87,8 +87,11 @@ Module HornSemilattice (LS : LevelSets). Definition entails_L_clause p cl := p ⊢ℒ singleton (concl cl) ≤ premise cl. + Definition entails_L_pres_clauses p cls := + Clauses.For_all (entails_L_clause p) cls. + Definition entails_L_clauses cls cls' := - Clauses.For_all (entails_L_clause (relations_of_clauses cls)) cls'. + entails_L_pres_clauses (relations_of_clauses cls) cls'. Lemma entails_L_idem_gen {le} {prems : premises} {p} : LevelExprSet.In le prems -> @@ -254,31 +257,62 @@ Module HornSemilattice (LS : LevelSets). + eapply entails_L_eq_le_1. eapply entails_sym. now constructor. Qed. + Lemma entails_L_pres_clauses_of_le {p s t} : + entails_L_pres_clauses p (s ⋞ t) <-> + p ⊢ℒ s ≤ t. + Proof. + split. + - unfold entails_L_clauses. + intros hf. do 2 red in hf. + rw_in clauses_of_le_spec hf. + eapply entails_L_split. + move=> le hin. + move: (hf (t, le)) => /fwd. + { exists le; split => //. } + now move=> h; red in h. + - intros hf. rewrite /entails_L_pres_clauses. + intros cl. rewrite clauses_of_le_spec => -[] le [hin ->]. + red. cbn. eapply entails_L_le_trans; tea. now eapply entails_L_in. + Qed. + Lemma entails_L_clauses_pres_le {p s t} : entails_L_clauses (clauses_of_relations p) (s ⋞ t) -> p ⊢ℒ s ≤ t. Proof. - intros hf. do 2 red in hf. - rw_in clauses_of_le_spec hf. - eapply entails_L_split. - move=> le hin. - move: (hf (t, le)) => /fwd. - { exists le; split => //. } - move=> h; red in h. cbn in h. - now eapply entails_L_clauses_pres_all in h. + rewrite /entails_L_clauses entails_L_pres_clauses_of_le. + now move/entails_L_clauses_pres_all. + Qed. + + + Lemma entails_L_pres_clauses_of_eq_split {p s t} : + entails_L_pres_clauses p (s ≡ t) <-> + entails_L_pres_clauses p (s ⋞ t) /\ + entails_L_pres_clauses p (t ⋞ s). + Proof. + rewrite /entails_L_pres_clauses /clauses_of_eq /Clauses.For_all. + setoid_rewrite Clauses.union_spec. + split. + - intros h; split. + * intros h' hcl. apply h. now left. + * intros h' hcl. apply h. now right. + - intros [] x []; eauto. + Qed. + + Lemma entails_L_pres_clauses_of_relations_eq {p s t} : + entails_L_pres_clauses p (s ≡ t) <-> + p ⊢ℒ s ≡ t. + Proof. + rewrite entails_L_pres_clauses_of_eq_split. + rewrite !entails_L_pres_clauses_of_le. + eapply entails_L_eq_antisym. Qed. Lemma entails_L_clauses_of_relations_eq {p s t} : entails_L_clauses (clauses_of_relations p) (s ≡ t) -> p ⊢ℒ s ≡ t. Proof. - intros hf. do 2 red in hf. - eapply entails_L_eq_antisym. - all: apply entails_L_clauses_pres_le. - - intros cl hin; red. eapply hf. - rewrite /clauses_of_eq. clsets. - - intros cl hin; red. eapply hf. - rewrite /clauses_of_eq. clsets. + rewrite /entails_L_clauses entails_L_pres_clauses_of_relations_eq. + now move/entails_L_clauses_pres_all. Qed. Lemma completeness_eq p s t : @@ -334,6 +368,15 @@ Module HornSemilattice (LS : LevelSets). now move/eq. Qed. + Lemma entails_ℋ_clauses_of_relations_equiv {cls cls'} : + cls ⊢ℋ cls' <-> + clauses_of_relations (relations_of_clauses cls) ⊢ℋ cls'. + Proof. + split. + - move/entails_ℋ_clauses_subset; apply. apply clauses_of_relations_relations_of_clauses. + - apply entails_ℋ_clauses_of_relations. + Qed. + (* - move/clauses_of_relations_spec => [] [l r] [] /relations_of_clauses_spec [] prems [] [concl k] [] incls [=] -> -> //=. rewrite /clauses_of_eq Clauses.union_spec. !clauses_of_le_spec => -[[lk [hin heq]]|[lk [hin heq]]]. * subst cl. @@ -372,4 +415,112 @@ Module HornSemilattice (LS : LevelSets). - apply entails_ℋ_entails_L. Qed. + Lemma entails_L_clauses_entails_L_relations cls r : + relations_of_clauses cls ⊢ℒ r <-> + entails_L_clauses cls (clauses_of_eq r.1 r.2). + Proof. + rewrite entails_L_clauses_eq. + destruct r as [l r]; cbn. + rewrite -entails_L_eq_antisym. + split; intros [le le']; split. + all:by apply entails_L_pres_clauses_of_le. + Qed. + + Lemma clauses_of_relations_cons {l r rels} : + clauses_of_relations ((l, r) :: rels) =_clset + Clauses.union (clauses_of_eq l r) (clauses_of_relations rels). + Proof. + cbn. reflexivity. + Qed. + + Lemma entails_L_cut {Γ r r'} : + Γ ⊢ℒ r -> + r :: Γ ⊢ℒ r' -> + Γ ⊢ℒ r'. + Proof. + destruct r as [l r], r' as [l' r']. + move/completeness_eq => h1. + move/completeness_eq => h2. + apply completeness_eq. + rewrite clauses_of_relations_cons in h2. + eapply entails_clauses_cut; tea. + Qed. + + Lemma relations_of_clauses_mon {s s'}: s ⊂_clset s' -> incl (relations_of_clauses s) (relations_of_clauses s'). + Proof. + intros hs. + move=> x /relations_of_clauses_spec [] prems [] concl [hin heq]. subst x. + apply hs in hin. eapply relations_of_clauses_spec_inv in hin. now cbn in *. + Qed. + + Lemma entails_L_clauses_subset {cls cls' r} : + entails_L_clauses cls r -> + Clauses.Subset cls cls' -> + entails_L_clauses cls' r. + Proof. + intros ent sub. + red. red. do 2 red in ent. + move=> cl /ent. unfold entails_L_clause. + intros ent'. + eapply entails_L_rels_subset; tea. + now apply relations_of_clauses_mon. + Qed. + + Lemma entails_clauses_tauto cls : cls ⊢ℋ cls. + Proof. + intros cl hin. now apply entails_in. + Qed. + + Lemma entails_L_clauses_tauto cls : entails_L_clauses cls cls. + Proof. + intros cl hin. red. eapply entails_L_entails_ℋ_equiv; tea. + apply entails_clauses_tauto. + Qed. + + Lemma entails_L_relations_of_clauses_le l r : + relations_of_clauses (l ⋞ r) ⊢ℒ l ≤ r. + Proof. + eapply completeness_eq. + rewrite -entails_ℋ_clauses_of_relations_equiv. + apply Theory.eq_antisym. split. + - apply Theory.join_le_left. split. apply entails_clauses_tauto. + apply Theory.le_refl. + - apply Theory.join_right. + Qed. + + Lemma entails_L_relations_of_clauses_eq l r : + relations_of_clauses (l ≡ r) ⊢ℒ l ≡ r. + Proof. + eapply completeness_eq. + rewrite -entails_ℋ_clauses_of_relations_equiv. + apply entails_clauses_tauto. + Qed. + + Lemma entails_L_to_clauses_pres_all {p r} : + p ⊢ℒ r -> + (relations_of_clauses (clauses_of_relations p)) ⊢ℒ r. + Proof. + intros h; depind h. + all:try solve [econstructor; eauto]. + apply clauses_of_relations_spec_inv in H. cbn in H. + have hr := relations_of_clauses_spec_inv (cls := clauses_of_relations p). + rewrite entails_L_clauses_entails_L_relations. cbn. + eapply entails_L_clauses_subset; tea. + eapply entails_L_clauses_tauto. + Qed. + + Lemma entails_L_clause_rels {p cl} : + entails_L_clause p cl -> + entails_L_clause (relations_of_clauses (clauses_of_relations p)) cl. + Proof. + now move/entails_L_to_clauses_pres_all. + Qed. + + Lemma entails_L_clauses_relations {p cls} : + entails_L_pres_clauses p cls -> + entails_L_pres_clauses (relations_of_clauses (clauses_of_relations p)) cls. + Proof. + now move=> hcls cl /hcls/entails_L_clause_rels. + Qed. + End HornSemilattice. diff --git a/common/theories/LoopChecking/InitialSemilattice.v b/common/theories/LoopChecking/InitialSemilattice.v index 27973349c..2436dfabc 100644 --- a/common/theories/LoopChecking/InitialSemilattice.v +++ b/common/theories/LoopChecking/InitialSemilattice.v @@ -63,6 +63,10 @@ Module InitialSemilattice (LS : LevelSets). where " p ⊢ℒ r " := (entails_L p r%_rel). Derive Signature for entails_L. + + Definition entails_L_rels p q := + List.Forall (entails_L p) q. + Lemma entails_join_congr_all {p} {x x' y y'} : p ⊢ℒ x ≡ x' -> p ⊢ℒ y ≡ y' -> p ⊢ℒ (x ∨ y) ≡ (x' ∨ y'). Proof. @@ -252,11 +256,13 @@ Module InitialSemilattice (LS : LevelSets). eapply entails_sym in eq. now eapply entails_L_eq_le_1 in eq. Qed. - Lemma entails_L_eq_antisym {cls} {l r} : cls ⊢ℒ r ≤ l -> cls ⊢ℒ l ≤ r -> cls ⊢ℒ l ≡ r. + Lemma entails_L_eq_antisym {cls} {l r} : (cls ⊢ℒ l ≤ r /\ cls ⊢ℒ r ≤ l) <-> cls ⊢ℒ l ≡ r. Proof. - unfold rel_le. intros le le'. - eapply entails_trans with (l ∨ r) => //. - apply entails_sym. now rewrite union_comm. + split. + - unfold rel_le. intros [le le']. + eapply entails_trans with (l ∨ r) => //. + apply entails_sym. now rewrite union_comm. + - intros eq; split. now apply entails_L_eq_le_1. now apply entails_L_eq_le_2. Qed. Lemma entails_L_le_join_l {p x x' r} : @@ -632,6 +638,9 @@ End ForSemilattice. Definition valid_relation rels c := (forall (s : semilattice) (v : Level.t -> s), interp_rels v rels -> interp_rel v c). + Definition valid_relations rels rels' := + (forall (s : semilattice) (v : Level.t -> s), interp_rels v rels -> interp_rels v rels'). + Lemma entails_L_valid {p r} : p ⊢ℒ r -> valid_relation p r. Proof. @@ -740,4 +749,20 @@ End ForSemilattice. - apply entails_L_valid. Qed. + Lemma completeness_all {p rs} : + valid_relations p rs <-> entails_L_rels p rs. + Proof. + induction rs. + - split. constructor. intros _; red. intros; constructor. + - split. cbn. + * intros vr. red. constructor. + apply completeness. intros s v hi. + now move: (vr s v hi) => h; depelim h. + apply IHrs. intros s v hi. specialize (vr s v hi). now depelim vr. + * intros ent; depelim ent. + apply completeness in H. + intros s v hi. constructor. + now apply H. now apply IHrs. + Qed. + End InitialSemilattice. diff --git a/common/theories/LoopChecking/ModelValuation.v b/common/theories/LoopChecking/ModelValuation.v index 50fda1ab6..2505f191a 100644 --- a/common/theories/LoopChecking/ModelValuation.v +++ b/common/theories/LoopChecking/ModelValuation.v @@ -18,17 +18,6 @@ End Semantics. - - - - Definition to_val (v : LevelMap.t nat) l := - match LevelMap.find l v with - | Some n => n - | None => 0%nat - end. - - Definition to_Z_val (v : Level.t -> nat) := fun l => Z.of_nat (v l). - (* Interprest in a nat semilattice only *) Definition correct_model {SL : Semilattice Z Z} (cls : clauses) (m : model) := enabled_clauses m cls /\ clauses_sem (to_Z_val (to_val (valuation_of_model m))) cls. diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v index 56804d449..2dde05319 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -1576,38 +1576,6 @@ Qed. *) - exists l; split => //. right; now apply LevelExprSet.singleton_spec. Qed. - Lemma clauses_of_relations_cons {l r rels} : - clauses_of_relations ((l, r) :: rels) =_clset - Clauses.union (clauses_of_eq l r) (clauses_of_relations rels). - Proof. - cbn. reflexivity. - Qed. -(* - Lemma entails_deduction {cls prems prems' concl} : - entails cls (union prems prems', concl) <-> - entails (Clauses.add (prems, concl) cls) (prems', concl). - Proof. - split. - - intros entc. - depind entc. - * *) - - - - Lemma entails_L_cut {Γ r r'} : - Γ ⊢ℒ r -> - r :: Γ ⊢ℒ r' -> - Γ ⊢ℒ r'. - Proof. - destruct r as [l r], r' as [l' r']. - move/completeness_eq => h1. - move/completeness_eq => h2. - apply completeness_eq. - rewrite clauses_of_relations_cons in h2. - eapply entails_clauses_cut; tea. - Qed. - - Class Decidable (A : Prop) := dec : A \/ ~ A. From 80f15dca51e736328d68163c7396db866dde4aff Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 24 Sep 2025 01:55:19 +0200 Subject: [PATCH 063/164] Adapted Deciders --- common/theories/LoopChecking/Deciders.v | 251 ++++++++++++++++-- common/theories/LoopChecking/ModelValuation.v | 58 ---- 2 files changed, 234 insertions(+), 75 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 882f5e310..a87ea5b3d 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -891,6 +891,194 @@ Module Abstract. Definition to_Z_val (v : Level.t -> nat) := fun l => Z.of_nat (v l). + (** Enabled and valid clauses are satisfied by valuation *) + Lemma valid_clause_model model cl : + enabled_clause model cl -> + valid_clause model cl -> + clause_sem (to_Z_val (to_val (valuation_of_model model))) cl. + Proof. + unfold enabled_clause, valid_clause. + destruct min_premise eqn:hmin => //= => //. + 2:{ intros [k' eq]. congruence. } + intros [k' eq]. noconf eq. + destruct cl as [prems [concl k]]. cbn -[le]. + unfold level_value_above. + destruct level_value eqn:hl => //. + unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. + move/Z.leb_le => hrel. + eapply LevelMap.find_2 in hfind. + have conclm := valuation_of_model_spec _ _ _ hfind. + set (v := (model_max _ - _)) in *. + cbn in conclm. + eapply LevelMap.find_1 in conclm. + subst v. + pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. + rewrite hmin in premeq. + eapply transitivity. 2:{ eapply interp_prems_ge; tea. } + unfold interp_expr. destruct prem as [prem k']. + symmetry in premeq. + move: premeq. unfold min_atom_value. + unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. + destruct o => //. + intros [= <-]. + eapply LevelMap.find_2 in findp. + have premm := valuation_of_model_spec _ _ _ findp. + eapply LevelMap.find_1 in premm. + assert (z1 - k' <= z0 - k). lia. + have hm : z0 <= model_max model. + { eapply model_max_spec in hfind; tea. now depelim hfind. } + have hm' : z1 <= model_max model. + { eapply model_max_spec in findp; tea. now depelim findp. } + have hmi : model_min model <= z0. + { eapply model_min_spec; tea. } + have hmi' : model_min model <= z1. + { eapply model_min_spec; tea. } + assert (0 <= model_max model)%Z by apply model_max_spec2. + assert (model_min model <= 0)%Z by apply model_min_spec2. + rewrite /to_Z_val /to_val premm conclm. + cbn. lia. + Qed. + + Lemma valid_clauses_model model cls : + enabled_clauses model cls -> + is_model cls model -> + clauses_sem (to_Z_val (to_val (valuation_of_model model))) cls. + Proof. + move=> en ism cl hin. + apply valid_clause_model. + now apply en. + now move/Clauses.for_all_spec: ism; apply. + Qed. + + Lemma clauses_of_le_singleton le r : + (singleton le ⋞ r)%cls =_clset Clauses.singleton (r, le). + Proof. + intros l. + rewrite Clauses.singleton_spec clauses_of_le_spec. + firstorder. + - subst l. apply LevelExprSet.singleton_spec in H. + now red in H; subst x. + - subst l. exists le. split => //. now apply LevelExprSet.singleton_spec. + Qed. + + Lemma clauses_of_le_add le l r : + (NES.add le l ⋞ r)%cls =_clset Clauses.add (r, le) (l ⋞ r). + Proof. + intros cl. + rewrite Clauses.add_spec clauses_of_le_spec. + split. + - move=> [] x [] /LevelExprSet.add_spec; rewrite /LevelExprSet.E.eq. + move=> [->|hin]. now left. + intros ->. right. rewrite clauses_of_le_spec. now exists x. + - move=> [->|]. exists le. split => //. + * now apply LevelExprSet.add_spec; left. + * rewrite clauses_of_le_spec => -[] k [] hin ->. + exists k. split => //. now apply LevelExprSet.add_spec. + Qed. + + Instance clauses_sem_proper {S} {SL : Semilattice S Q.t} : + Proper (Logic.eq ==> Clauses.Equal ==> iff) clauses_sem. + Proof. + move=> ?? -> ?? h. + rewrite /clauses_sem. + now rewrite h. + Qed. + + Lemma clauses_sem_singleton {S} {SL : Semilattice S Q.t} {V cl} : + clauses_sem V (Clauses.singleton cl) <-> clause_sem V cl. + Proof. + rewrite /clauses_sem /Clauses.For_all. + split; firstorder. apply H. clsets. + apply Clauses.singleton_spec in H0. now subst. + Qed. + + Lemma clauses_sem_add {S} {SL : Semilattice S Q.t} {V cl cls} : + clauses_sem V (Clauses.add cl cls) <-> clause_sem V cl /\ clauses_sem V cls. + Proof. + rewrite /clauses_sem /Clauses.For_all. + split. + - intros hcl. split. + * apply hcl, Clauses.add_spec; now left. + * move=> x hin; apply hcl, Clauses.add_spec; now right. + - move=> [] hcl hcls x /Clauses.add_spec -[]. now subst. + apply hcls. + Qed. + + Lemma clauses_sem_union {S} {SL : Semilattice S Q.t} {V cls cls'} : + clauses_sem V (Clauses.union cls cls') <-> clauses_sem V cls /\ clauses_sem V cls'. + Proof. + rewrite /clauses_sem /Clauses.For_all. + setoid_rewrite Clauses.union_spec. firstorder. + Qed. + + Lemma clauses_sem_leq {S} {SL : Semilattice S Q.t} (V : Level.t -> S) l r : + clauses_sem V (l ⋞ r) <-> + (interp_prems V l ≤ interp_prems V r)%sl. + Proof. + move: l. + apply: elim. + - intros le; cbn. + rewrite clauses_of_le_singleton clauses_sem_singleton. + cbn. now rewrite interp_prems_singleton. + - move=> le x xr hnin. + rewrite clauses_of_le_add clauses_sem_add xr. + cbn. rewrite interp_prems_add. + symmetry; apply join_le_left_eq. + Qed. + + Lemma clauses_sem_eq {S} {SL : Semilattice S Q.t} (V : Level.t -> S) l r : + clauses_sem V (l ≡ r) <-> + (interp_prems V l ≡ interp_prems V r)%sl. + Proof. + rewrite /clauses_of_eq clauses_sem_union !clauses_sem_leq. + symmetry; apply eq_antisym. + Qed. + + Definition relation_of_clause cl := (singleton (concl cl) ≤ premise cl). + + Lemma interp_rels_of_clauses {S} {SL : Semilattice S Q.t} {V cls} : + interp_rels V (relations_of_clauses cls) <-> + forall cl, Clauses.In cl cls -> interp_rel V (relation_of_clause cl). + Proof. + rewrite /interp_rels Forall_forall. + split. + - move=> hx cl /relations_of_clauses_spec_inv. + now move/hx. + - move=> hcl x /relations_of_clauses_spec => -[] prems [] concl. + now move=> [] /hcl hin ->. + Qed. + + Lemma interp_rels_clauses_sem {S} {SL : Semilattice S Q.t} {V cls} : + clauses_sem V cls <-> interp_rels V (relations_of_clauses cls). + Proof. + rewrite interp_rels_of_clauses. + split. + - move=> sem [prems concl] /sem //=. + now rewrite /le interp_prems_union interp_prems_singleton. + - move=> hcl [prems concl] /hcl /=. + now rewrite /le interp_prems_union interp_prems_singleton. + Qed. + + Definition Z_valuation_of_model m := + to_Z_val (to_val (valuation_of_model m.(model).(model_valid).(model_model))). + + Lemma model_entails_succ m v : clauses m ⊢a v → succ v -> False. + Proof. + move/to_entails_all/entails_L_entails_ℋ_equiv. + move/entails_L_rels_entails_L_clauses/completeness_all. + move/(_ {| carrier := Z; sl := _ |}). cbn. + move/(_ (Z_valuation_of_model m)). + rewrite -!interp_rels_clauses_sem => /fwd. + cbn in *. + have mok := m.(model).(model_valid).(model_ok). + eapply valid_clauses_model. + eapply enabled_clauses_ext, m.(model).(enabled_model). + now eapply (is_update_of_ext m.(model).(model_valid).(I.model_updates)). + exact mok. + move/clauses_sem_leq. + rewrite interp_add_prems. cbn. lia. + Qed. + Lemma check_clauses_spec m cls : check_clauses m cls <-> entails_clauses (clauses m) cls. Proof. @@ -904,22 +1092,30 @@ Module Abstract. eapply Clauses.for_all_spec; tc => cl hin. destruct check eqn:hc => //. * exfalso; eapply check_entails_looping in hc; tea. - eapply to_entails_all in hc. - eapply entails_L_entails_ℋ_equiv in hc. - eapply entails_L_rels_entails_L_clauses in hc. - apply completeness_all in hc. - red in hc. specialize (hc {| carrier := Z; sl := _ |}). cbn in hc. - specialize (hc (to_Z_val (to_val (valuation_of_model m.(model).(model_valid).(model_model))))). - cbn in *. - admit. -(* - 2:eapply m.(model).(model_valid).(model_ok). - eapply enabled_clauses_ext, m.(model).(enabled_model). - eapply (is_update_of_ext m.(model).(model_valid).(I.model_updates)). *) + now apply model_entails_succ in hc. * move/check_invalid: hc => he. exfalso. elim he. now apply hv. Qed. + Definition valid_entailments cls cls' := + forall S (SL : Semilattice S Q.t) (V : Level.t -> S), clauses_sem V cls -> clauses_sem V cls'. + + Lemma check_clauses_complete m cls : + check_clauses m cls <-> valid_entailments (clauses m) cls. + Proof. + rewrite check_clauses_spec. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -completeness_all. + split. + - move=> vr s sl v. + move: (vr {| carrier := _; sl := sl |} v). + rewrite !interp_rels_clauses_sem //. + - intros ve s v. + move: (ve s (sl s) v). + now rewrite //= !interp_rels_clauses_sem. + Qed. + End Abstract. End Deciders. @@ -1001,11 +1197,25 @@ Module LoopChecking (LS : LevelSets). apply enforce_clauses_not_None. Qed. + Import Impl.Abstract. + Import Impl.CorrectModel. + Lemma enforce_inconsistent {m cls u} : enforce m cls = Some (inr u) -> ~ exists V, clauses_sem V (Clauses.union (clauses m) (to_clauses cls)). Proof. - apply enforce_clauses_inconsistent. + rewrite /enforce. + move/enforce_clauses_inconsistent. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -ISL.completeness_all. + move=> vr [] V. + specialize (vr {| ISL.carrier := Z; ISL.sl := _ |} V). + move: vr. + rewrite !interp_rels_clauses_sem // => vr /vr. + rewrite -interp_rels_clauses_sem. + rewrite clauses_sem_eq. + setoid_rewrite ISL.interp_add_prems; cbn -[Z.add]. + lia. Qed. Lemma enforce_clauses {m cls m'} : @@ -1020,6 +1230,9 @@ Module LoopChecking (LS : LevelSets). levels m' = levels m. Proof. apply enforce_clauses_levels. Qed. + Definition valid_entailments cls cls' := + forall S (SL : Semilattice.Semilattice S Q.t) (V : Level.t -> S), clauses_sem V cls -> clauses_sem V cls'. + (* Returns true is the constraint is valid in the model and all its possible consistent extensions. Returns false if the constraint results in an inconsistent set of constraints or it simply is not valid. *) @@ -1030,17 +1243,21 @@ Module LoopChecking (LS : LevelSets). check m c <-> entails_clauses (clauses m) (to_clauses c). Proof. apply check_clauses_spec. Qed. + Lemma check_complete m c : + check m c <-> valid_entailments (clauses m) (to_clauses c). + Proof. apply check_clauses_complete. Qed. + (* Returns the valuation of the model: a minimal assignement from levels to constraints that make the enforced clauses valid. *) - Definition valuation m := Model.valuation_of_model m.(Impl.Abstract.model).(Impl.CorrectModel.model_valid).(model_model). + Definition valuation m := to_val (Model.valuation_of_model m.(Impl.Abstract.model).(Impl.CorrectModel.model_valid).(model_model)). - Definition model_valuation m : clauses_sem (to_Z_val (to_val (valuation m))) (clauses m). + Definition model_valuation m : clauses_sem (to_Z_val (valuation m)) (clauses m). Proof. destruct m as [levels clauses []]; cbn. apply valid_clauses_model; tea; cbn. - eapply enabled_clauses_ext; tea. - exact: is_update_of_ext (model_updates model_valid). - - apply model_valid. + eapply is_update_of_ext, model_valid0. + - apply model_valid0. Qed. End LoopChecking. diff --git a/common/theories/LoopChecking/ModelValuation.v b/common/theories/LoopChecking/ModelValuation.v index 2505f191a..1d6584087 100644 --- a/common/theories/LoopChecking/ModelValuation.v +++ b/common/theories/LoopChecking/ModelValuation.v @@ -42,66 +42,8 @@ now rewrite join_sub. Qed. - (** Enabled and valid clauses are satisfied by valuation *) - Lemma valid_clause_model model cl : - enabled_clause model cl -> - valid_clause model cl -> - clause_sem (to_Z_val (to_val (valuation_of_model model))) cl. - Proof. - unfold enabled_clause, valid_clause. - destruct min_premise eqn:hmin => //= => //. - 2:{ intros [k' eq]. congruence. } - intros [k' eq]. noconf eq. - destruct cl as [prems [concl k]]. cbn -[le]. - unfold level_value_above. - destruct level_value eqn:hl => //. - unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. - move/Z.leb_le => hrel. - eapply LevelMap.find_2 in hfind. - have conclm := valuation_of_model_spec _ _ _ hfind. - set (v := (model_max _ - _)) in *. - cbn in conclm. - eapply LevelMap.find_1 in conclm. - subst v. - pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. - rewrite hmin in premeq. - eapply transitivity. 2:{ eapply interp_prems_ge; tea. } - unfold interp_expr. destruct prem as [prem k']. - symmetry in premeq. - move: premeq. unfold min_atom_value. - unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. - destruct o => //. - intros [= <-]. - eapply LevelMap.find_2 in findp. - have premm := valuation_of_model_spec _ _ _ findp. - eapply LevelMap.find_1 in premm. - assert (z1 - k' <= z0 - k). lia. - have hm : z0 <= model_max model. - { eapply model_max_spec in hfind; tea. now depelim hfind. } - have hm' : z1 <= model_max model. - { eapply model_max_spec in findp; tea. now depelim findp. } - have hmi : model_min model <= z0. - { eapply model_min_spec; tea. } - have hmi' : model_min model <= z1. - { eapply model_min_spec; tea. } - assert (0 <= model_max model)%Z by apply model_max_spec2. - assert (model_min model <= 0)%Z by apply model_min_spec2. - rewrite /to_Z_val /to_val premm conclm. - cbn. lia. - Qed. - Lemma valid_clauses_model model cls : - enabled_clauses model cls -> - is_model cls model -> - clauses_sem (to_Z_val (to_val (valuation_of_model model))) cls. - Proof. - move=> en ism cl hin. - apply valid_clause_model. - now apply en. - now move/Clauses.for_all_spec: ism; apply. - Qed. - Definition valid_entailment cls cl := forall V, clauses_sem V cls -> clause_sem V cl. Definition invalid_entailment cls cl := forall V, clauses_sem V cls -> clause_sem V cl -> False. From 88c5310d52f16d59b1a6712573cf58eaf778a7d5 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 24 Sep 2025 02:21:58 +0200 Subject: [PATCH 064/164] Fixing UnivLoopChecking --- common/_RocqProject.in | 3 +- common/theories/LoopChecking/Deciders.v | 9 +---- .../theories/LoopChecking/UnivLoopChecking.v | 37 ++++++++----------- 3 files changed, 20 insertions(+), 29 deletions(-) diff --git a/common/_RocqProject.in b/common/_RocqProject.in index c293edad6..0dfacbcc1 100644 --- a/common/_RocqProject.in +++ b/common/_RocqProject.in @@ -24,4 +24,5 @@ theories/LoopChecking/HornSemilatticeEquiv.v theories/LoopChecking/Model.v theories/LoopChecking/Models.v theories/LoopChecking/PartialLoopChecking.v -theories/LoopChecking/Deciders.v \ No newline at end of file +theories/LoopChecking/Deciders.v +theories/LoopChecking/UnivLoopChecking.v \ No newline at end of file diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index a87ea5b3d..90ec7b1df 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -164,8 +164,6 @@ Proof. apply Clauses.for_all_spec. tc. apply ism. Qed. -Print valid_clause. - Lemma valid_enabled_clause_spec model cl : enabled_clause model cl -> valid_clause model cl -> @@ -1197,9 +1195,6 @@ Module LoopChecking (LS : LevelSets). apply enforce_clauses_not_None. Qed. - Import Impl.Abstract. - Import Impl.CorrectModel. - Lemma enforce_inconsistent {m cls u} : enforce m cls = Some (inr u) -> ~ exists V, clauses_sem V (Clauses.union (clauses m) (to_clauses cls)). @@ -1256,8 +1251,8 @@ Module LoopChecking (LS : LevelSets). destruct m as [levels clauses []]; cbn. apply valid_clauses_model; tea; cbn. - eapply enabled_clauses_ext; tea. - eapply is_update_of_ext, model_valid0. - - apply model_valid0. + eapply is_update_of_ext, model_valid. + - apply model_valid. Qed. End LoopChecking. diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/template-rocq/theories/LoopChecking/UnivLoopChecking.v index 2dde05319..56a884599 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/template-rocq/theories/LoopChecking/UnivLoopChecking.v @@ -5,7 +5,7 @@ From Stdlib Require Import ssreflect ssrfun ssrbool. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils SemiLattice. +From MetaRocq.Utils Require Import utils NonEmptyLevelExprSet SemiLattice. From MetaRocq.Common Require Import UnivConstraintType Universes. From MetaRocq.Common.LoopChecking Require Import Common Interfaces Deciders. From Equations Require Import Equations. @@ -101,6 +101,7 @@ Module LS <: LevelSets. Module LevelExpr := LevelExprZ. Module LevelExprSet := LevelExprZSet. Module LevelMap := LevelMap. + Module NES := NonEmptyLevelExprSet MoreLevel Q LevelSet LevelExprZ LevelExprZSet. End LS. Definition to_levelexprzset (u : LevelExprSet.t) : LS.LevelExprSet.t := @@ -164,7 +165,10 @@ Qed. Module UnivLoopChecking. Module LoopCheck := LoopChecking LS. + Import LoopCheck.Impl.Abstract. Import LoopCheck.Impl.I. + Import ISL. + Program Definition to_atoms (u : Universe.t) : NES.t := {| NES.t_set := to_levelexprzset u |}. Next Obligation. @@ -245,7 +249,7 @@ Module ZUnivConstraint. Lemma eq_dec x y : {eq x y} + {~ eq x y}. Proof. - unfold eq. decide equality; apply eq_dec. + unfold eq. decide equality; apply Classes.eq_dec. Defined. Definition eq_leibniz (x y : t) : eq x y -> x = y := id. @@ -472,7 +476,7 @@ End ZUnivConstraint. move: (repr_constraints m c' hin) => h. clsets. - move/LoopCheck.enforce_clauses: eq0. rewrite /LoopCheck.clauses => -> c'. - rewrite UnivLoopChecking.Clauses.union_spec => -[]. + rewrite UnivLoopChecking.Clauses.Clauses.union_spec => -[]. * move/(repr_constraints_inv m c') => [] c2 []. exists c2. split => //. rewrite UnivConstraintSet.add_spec. now right. @@ -625,7 +629,7 @@ End ZUnivConstraint. let add_val l := LevelMap.add l (val v l) in LevelSet.fold add_val V (LevelMap.empty _). - Lemma clauses_sem_subset {v cls cls'} : clauses_sem v cls -> cls' ⊂_clset cls -> clauses_sem v cls'. + Lemma clauses_sem_subset {S} {SL : Semilattice.Semilattice S Q.t} {v cls cls'} : clauses_sem v cls -> cls' ⊂_clset cls -> clauses_sem v cls'. Proof. now move=> hall hsub cl /hsub. Qed. @@ -654,7 +658,7 @@ End ZUnivConstraint. cbn. cbn in ih. lia. Qed. - Lemma to_atoms_singleton l k : to_atoms (Universe.singleton (l, k)) = singleton (l, Z.of_nat k). + Lemma to_atoms_singleton l k : to_atoms (Universe.singleton (l, k)) = NES.singleton (l, Z.of_nat k). Proof. apply NES.equal_exprsets. rewrite /to_atoms //=. @@ -685,15 +689,6 @@ End ZUnivConstraint. rewrite Universes.LevelExprSet.add_spec. now right. Qed. - Lemma clauses_sem_union v cls cls' : clauses_sem v (Clauses.Clauses.union cls cls') <-> - clauses_sem v cls /\ clauses_sem v cls'. - Proof. - unfold clauses_sem. split. - intros hf. split; eapply clauses_sem_subset; tea; clsets. - intros []. intros cl. rewrite Clauses.Clauses.union_spec. - specialize (H cl). specialize (H0 cl). intros []; auto. - Qed. - Lemma interp_prem_to_atom v le : interp_expr (to_Z_val v) (to_atom le) = Z.of_nat (val (to_valuation v) le). Proof. destruct le => //=. cbn. @@ -718,18 +713,18 @@ End ZUnivConstraint. Qed. Lemma clauses_sem_val m l r : - clauses_sem (to_Z_val (to_val (LoopCheck.valuation m))) (clauses_of_le (to_atoms l) (to_atoms r)) -> - Universes.val (to_valuation (to_val (LoopCheck.valuation m))) l <= - Universes.val (to_valuation (to_val (LoopCheck.valuation m))) r. + clauses_sem (to_Z_val (LoopCheck.valuation m)) (clauses_of_le (to_atoms l) (to_atoms r)) -> + Universes.val (to_valuation (LoopCheck.valuation m)) l <= + Universes.val (to_valuation (LoopCheck.valuation m)) r. Proof. move/clauses_sem_clauses_of_le. - have he := interp_prems_to_atoms (to_val (LoopCheck.valuation m)) l. - have he' := interp_prems_to_atoms (to_val (LoopCheck.valuation m)) r. + have he := interp_prems_to_atoms (LoopCheck.valuation m) l. + have he' := interp_prems_to_atoms (LoopCheck.valuation m) r. cbn in *. lia. Qed. Lemma model_satisfies m : - satisfies (to_valuation (to_val (LoopCheck.valuation (model m)))) (constraints m). + satisfies (to_valuation (LoopCheck.valuation (model m))) (constraints m). Proof. destruct m as [m cstrs repr repr_inv]. cbn. have val := LoopCheck.model_valuation m. @@ -765,7 +760,7 @@ End ZUnivConstraint. - move=> x a s' s'' hin hnin hadd ih. rewrite LevelMapFact.F.add_mapsto_iff /Level.eq ih. rewrite hadd. firstorder; subst; auto. - destruct (eq_dec x l); firstorder. subst. now left. + destruct (Classes.eq_dec x l); firstorder. subst. now left. Qed. Lemma interp_level_of_valuation {V v l} : From 5ffa8ece6b79c6a422d00f828976c34e218439a0 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 24 Sep 2025 18:23:07 +0200 Subject: [PATCH 065/164] Completeness for constraints proven --- .../LoopChecking/HornSemilatticeEquiv.v | 45 + .../LoopChecking/InitialSemilattice.v | 34 +- .../theories/LoopChecking/UnivLoopChecking.v | 853 +++++++++--------- template-rocq/theories/Junk.v | 285 ++++++ 4 files changed, 778 insertions(+), 439 deletions(-) rename {template-rocq => common}/theories/LoopChecking/UnivLoopChecking.v (75%) diff --git a/common/theories/LoopChecking/HornSemilatticeEquiv.v b/common/theories/LoopChecking/HornSemilatticeEquiv.v index 2a13e9204..3b7a4fb3f 100644 --- a/common/theories/LoopChecking/HornSemilatticeEquiv.v +++ b/common/theories/LoopChecking/HornSemilatticeEquiv.v @@ -446,6 +446,51 @@ Module HornSemilattice (LS : LevelSets). eapply entails_clauses_cut; tea. Qed. + Lemma entails_L_all_entails_cut {Γ r r'} : + Γ ⊢ℒ r -> + r :: Γ ⊩ℒ r' -> + Γ ⊩ℒ r'. + Proof. + intros h; elim; constructor. + now eapply entails_L_cut. exact H1. + Qed. + + Lemma entails_L_all_weaken {p q w} : + p ⊩ℒ q -> w ++ p ⊩ℒ q. + Proof. + induction 1; constructor. + eapply entails_L_rels_subset; tea => //. + intros a hin. rewrite in_app_iff. now right. + exact IHForall. + Qed. + + Lemma entails_L_all_cut {p q r} : + p ⊩ℒ q -> q ++ p ⊢ℒ r -> p ⊢ℒ r. + Proof. + move=> hp. move: hp r. elim. + - move=> r hr. eapply entails_L_rels_subset; tea. now red. + - move=> x l px pl ih r hxl. + move: (ih r) => /fwd //. + cbn in hxl. eapply entails_L_cut; tea. + eapply entails_L_rels_subset in px. tea. red => ?. now rewrite in_app_iff. + Qed. + + Lemma entails_L_all_one_trans {p q r} : + p ⊩ℒ q -> q ⊢ℒ r -> p ⊢ℒ r. + Proof. + intros hq hr. eapply entails_L_all_cut; tea. + eapply entails_L_rels_subset; tea. red => ?; now rewrite in_app_iff. + Qed. + + Lemma entails_L_all_trans {p q r} : + p ⊩ℒ q -> q ⊩ℒ r -> p ⊩ℒ r. + Proof. + move=> hp. elim. + - constructor. + - move=> re res ent hres ih. + constructor. eapply entails_L_all_one_trans. exact hp. exact ent. exact ih. + Qed. + Lemma relations_of_clauses_mon {s s'}: s ⊂_clset s' -> incl (relations_of_clauses s) (relations_of_clauses s'). Proof. intros hs. diff --git a/common/theories/LoopChecking/InitialSemilattice.v b/common/theories/LoopChecking/InitialSemilattice.v index 2436dfabc..d626fd251 100644 --- a/common/theories/LoopChecking/InitialSemilattice.v +++ b/common/theories/LoopChecking/InitialSemilattice.v @@ -63,10 +63,13 @@ Module InitialSemilattice (LS : LevelSets). where " p ⊢ℒ r " := (entails_L p r%_rel). Derive Signature for entails_L. - Definition entails_L_rels p q := List.Forall (entails_L p) q. + Notation " p ⊩ℒ q " := (entails_L_rels p q) (at level 72, no associativity) : rel_scope. + + Definition equiv_L_rels p q := p ⊩ℒ q /\ q ⊩ℒ p. + Lemma entails_join_congr_all {p} {x x' y y'} : p ⊢ℒ x ≡ x' -> p ⊢ℒ y ≡ y' -> p ⊢ℒ (x ∨ y) ≡ (x' ∨ y'). Proof. @@ -239,6 +242,35 @@ Module InitialSemilattice (LS : LevelSets). induction 1; try solve [econstructor; eauto]. Qed. + Instance entails_L_proper : Proper (equivlistA Logic.eq ==> Logic.eq ==> iff) entails_L. + Proof. + intros ?? eq ?? ->. + red in eq. rw_in (@InA_In_eq rel) eq. + split => h; eapply entails_L_rels_subset; tea; red; firstorder. + Qed. + + Instance In_proper {A} : Proper (Logic.eq ==> equivlistA Logic.eq ==> iff) (@In A). + Proof. + intros x y -> l l' eq'. + red in eq'. setoid_rewrite InA_In_eq in eq'. firstorder. + Qed. + + Instance Forall_proper {A} (P : A -> Prop) : Proper (equivlistA Logic.eq ==> iff) (Forall P). + Proof. + intros x y eq. + rewrite !Forall_forall. + now setoid_rewrite eq. + Qed. + + Instance entails_L_all_proper : Proper (equivlistA Logic.eq ==> equivlistA Logic.eq ==> iff) entails_L_rels. + Proof. + intros ?? eq ?? eq'. + split. + - unfold entails_L_rels. rewrite eq'. + move/Forall_forall => h. eapply Forall_forall => h'. now rewrite -eq. + - unfold entails_L_rels. rewrite eq'. + move/Forall_forall => h. eapply Forall_forall => h'. now rewrite eq. + Qed. Lemma entails_L_le_eq {cls l r} : cls ⊢ℒ l ≤ r -> cls ⊢ℒ l ∨ r ≡ r. Proof. trivial. Qed. diff --git a/template-rocq/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v similarity index 75% rename from template-rocq/theories/LoopChecking/UnivLoopChecking.v rename to common/theories/LoopChecking/UnivLoopChecking.v index 56a884599..4fd7a09c7 100644 --- a/template-rocq/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -165,9 +165,7 @@ Qed. Module UnivLoopChecking. Module LoopCheck := LoopChecking LS. - Import LoopCheck.Impl.Abstract. Import LoopCheck.Impl.I. - Import ISL. Program Definition to_atoms (u : Universe.t) : NES.t := {| NES.t_set := to_levelexprzset u |}. @@ -629,6 +627,10 @@ End ZUnivConstraint. let add_val l := LevelMap.add l (val v l) in LevelSet.fold add_val V (LevelMap.empty _). + Import LoopCheck.Impl.Abstract (clause_sem, clauses_sem, clauses_sem_union, to_val, to_Z_val). + Import ISL (interp_prems, interp_add_prems, interp_prems_union, + interp_prems_singleton, interp_prems_add, interp_expr). + Lemma clauses_sem_subset {S} {SL : Semilattice.Semilattice S Q.t} {v cls cls'} : clauses_sem v cls -> cls' ⊂_clset cls -> clauses_sem v cls'. Proof. now move=> hall hsub cl /hsub. @@ -936,10 +938,13 @@ End ZUnivConstraint. - intros x y. rewrite interp_prems_union; cbn. lia. Qed. - Definition valid_entailments cls cls' := - forall A {SL : Semilattice A Z} V, clauses_sem V cls -> clauses_sem V cls'. + (* Definition valid_entailment cls cl := + forall A {SL : Semilattice A Z} V, clauses_sem V cls -> clause_sem V cl. *) - Lemma entails_cstr_spec cstrs c : + (* Definition valid_entailments cls cls' := + forall A {SL : Semilattice A Z} V, clauses_sem V cls -> clauses_sem V cls'. *) + + (* Lemma entails_cstr_spec cstrs c : (exists V, clauses_sem V (of_z_constraints cstrs)) -> entails_z_cstr cstrs c -> (forall cl, Clauses.In cl (LoopCheck.to_clauses c) -> @@ -948,12 +953,12 @@ End ZUnivConstraint. rewrite /entails_cstr /entails_clauses. move=> ev hf cl /hf he. red. now eapply clauses_sem_entails in he. - Qed. + Qed. *) - Definition relation_of_constraint c := + Definition relation_of_constraint (c : ZUnivConstraint.t) := let '(l, d, r) := c in match d with - | ConstraintType.Le => (l ∪ r, r) + | ConstraintType.Le => ((l ∪ r)%nes, r) | ConstraintType.Eq => (l, r) end. @@ -984,6 +989,11 @@ End ZUnivConstraint. Definition levels_of_z_constraints c := ZUnivConstraintSet.fold (fun c acc => LevelSet.union (Zuniv_constraint_levels c) acc) c LevelSet.empty. + Import ISL. + + Record presentation := + { V : LevelSet.t; C : rels }. + Definition presentation_of cstrs := {| V := levels_of_z_constraints cstrs; C := relations_of_constraints cstrs |}. @@ -1031,8 +1041,8 @@ End ZUnivConstraint. intros hin. apply Theory.eq_antisym. split. - - rewrite Theory.to_entails_all. now apply entails_clauses_eq_left. - - rewrite Theory.to_entails_all. now apply entails_clauses_eq_right. + - rewrite to_entails_all. now apply entails_clauses_eq_left. + - rewrite to_entails_all. now apply entails_clauses_eq_right. Qed. Lemma entails_clauses_le_cstr {cstrs l r} : @@ -1040,7 +1050,25 @@ End ZUnivConstraint. of_z_constraints cstrs ⊢ℋ l ⋞ r. Proof. intros hin. - rewrite Theory.to_entails_all. now apply entails_clauses_le. + rewrite to_entails_all. now apply entails_clauses_le. + Qed. + + Lemma entails_L_clauses_eq_cstr {cstrs l r} : + ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> + relations_of_clauses (of_z_constraints cstrs) ⊢ℒ l ≡ r. + Proof. + move/entails_clauses_eq_cstr. + rewrite -entails_L_entails_ℋ_equiv. + now rewrite -(entails_L_clauses_entails_L_relations _ (l, r)). + Qed. + + Lemma entails_L_clauses_le_cstr {cstrs l r} : + ZUnivConstraintSet.In (l, ConstraintType.Le, r) cstrs -> + relations_of_clauses (of_z_constraints cstrs) ⊢ℒ l ≤ r. + Proof. + move/entails_clauses_le_cstr. + rewrite -entails_L_entails_ℋ_equiv. + now rewrite /entails_L_clauses Clauses.entails_L_pres_clauses_of_le. Qed. Lemma presentation_of_clauses_spec cls prems concl : @@ -1050,43 +1078,326 @@ End ZUnivConstraint. rewrite /presentation_of_clauses //=. move/relations_of_clauses_spec_inv => //=. Qed. - (* - move/relations_of_clauses_spec => [] prems' [] concl' [hin heq]. - have eqprems : prems = prems'. - noconf heq. *) + Infix "⊫ℒ" := equiv_L_rels (no associativity, at level 72) : rel_scope. + Open Scope rel_scope. + + Lemma entails_L_clauses_leq_def {p l r} : + entails_L_clauses p (l ⋞ r) <-> entails_L_clauses p (l ∨ r ≡ r). + Proof. + rewrite /entails_L_clauses. + rewrite entails_L_pres_clauses_of_relations_eq. + now rewrite Clauses.entails_L_pres_clauses_of_le. + Qed. + + Lemma entails_L_in_cls {prems concl cls} : + Clauses.In (prems, concl) cls -> relations_of_clauses cls ⊢ℒ singleton concl ≤ prems. + Proof. + intros hin. eapply entails_c. + apply relations_of_clauses_spec_inv in hin. now cbn in hin. + Qed. + + Lemma entails_L_relations_of_clauses_le l r : + equiv_L_rels (relations_of_clauses (l ⋞ r)) [l ≤ r]. + Proof. + split. + - constructor. apply entails_L_relations_of_clauses_le. constructor. + - apply Forall_forall => rel. + move/relations_of_clauses_spec => [] prems [] concl [] hin ->. + unfold rel_le. + eapply clauses_of_le_spec in hin as [k [hin heq]]. noconf heq. + eapply entails_trans with (l ∨ r). 2:{ eapply entails_c. constructor. now constructor. } + apply entails_L_eq_antisym. split. + eapply entails_L_le_join_l. now eapply entails_L_in. + eapply entails_L_le_trans with r. + eapply entails_L_eq_le_1. eapply entails_c; now constructor. + eapply entails_L_le_right. + Qed. + + Lemma entails_L_all_refl r : r ⊩ℒ r. + Proof. induction r. + - constructor. + - constructor. destruct a; eapply entails_c. now constructor. + now eapply (entails_L_all_weaken (w := [a])). + Qed. + + Instance entails_L_all_preorder : PreOrder entails_L_rels. + Proof. + split. + - red. apply entails_L_all_refl. + - red. intros x y z. apply entails_L_all_trans. + Qed. + + Instance equiv_L_rels_equiv : Equivalence equiv_L_rels. + Proof. + split. + - intros r. split; eapply entails_L_all_refl. + - intros r r' []; split; auto. + - intros r r0 r1 [] []; split; eapply entails_L_all_trans; eauto. + Qed. + + Instance entails_L_all_partial_order : PartialOrder equiv_L_rels entails_L_rels. + Proof. + split; tc; auto. + Qed. + + Lemma equiv_L_rels_eq {l r} : equiv_L_rels [l ≡ r] (relations_of_clauses (clauses_of_le l r) ++ relations_of_clauses (clauses_of_le r l)). + Proof. + rewrite /clauses_of_eq. split. + - apply app_Forall. + * apply Forall_forall => rel. + have [he he'] := entails_L_relations_of_clauses_le l r. + red in he, he'. + rewrite Forall_forall in he'. move/he'. + intros ent. destruct rel. + eapply entails_L_all_one_trans; tea. + constructor. apply entails_L_eq_le_1, entails_c; repeat constructor. constructor. + * apply Forall_forall => rel. + have [he he'] := entails_L_relations_of_clauses_le r l. + red in he, he'. + rewrite Forall_forall in he'. move/he'. + intros ent. destruct rel. + eapply entails_L_all_one_trans; tea. + constructor. apply entails_L_eq_le_2, entails_c; repeat constructor. constructor. + - constructor; [|constructor]. + apply entails_L_eq_antisym. split. + * have [he he'] := entails_L_relations_of_clauses_le l r. + eapply entails_L_rels_subset. depelim he. tea. + red. intros r' hin. rewrite in_app_iff. now left. + * have [he he'] := entails_L_relations_of_clauses_le r l. + eapply entails_L_rels_subset. depelim he. tea. + red. intros r' hin. rewrite in_app_iff. now right. + Qed. + + Instance entails_L_proper_equiv : Proper (equiv_L_rels ==> Logic.eq ==> iff) entails_L. + Proof. + intros r r' h ?? ->. split. + - intros h'. destruct h. eapply entails_L_all_one_trans; tea. + - intros h'. destruct h. eapply entails_L_all_one_trans; tea. + Qed. + + + Lemma entails_L_relations_of_clauses_eq l r : + equiv_L_rels (relations_of_clauses (l ≡ r)) [l ≡ r]. + Proof. + split. + - constructor. apply entails_L_relations_of_clauses_eq. constructor. + - apply Forall_forall => rel. + move/relations_of_clauses_spec => [] prems [] concl [] hin ->. + move: hin; rewrite /clauses_of_eq Clauses.union_spec => -[] hin. + * setoid_rewrite equiv_L_rels_eq. + eapply entails_L_rels_subset; revgoals. + { intros rel'. rewrite in_app_iff. left. tea. } + now eapply entails_L_in_cls. + * setoid_rewrite equiv_L_rels_eq. + eapply entails_L_rels_subset; revgoals. + { intros rel'. rewrite in_app_iff. right. tea. } + now eapply entails_L_in_cls. + Qed. + + Lemma entails_to_clauses {prems concl cstr} : Clauses.In (prems, concl) (LoopCheck.to_clauses cstr) -> + [relation_of_constraint cstr] ⊢ℒ (singleton concl ≤ prems). + Proof. + destruct cstr as [[l []] r]. + - intros hin. cbn -[le]. + have en := entails_L_relations_of_clauses_le l r. + setoid_rewrite <- en. cbn in hin. + now eapply entails_L_in_cls. + - intros hin; cbn in hin |- *. + rewrite -entails_L_relations_of_clauses_eq. + now eapply entails_L_in_cls. + Qed. + +(* entails_L_to_clauses_pres_all *) + Lemma relation_of_constraint_of_clause cstr : + relations_of_clauses (LoopCheck.to_clauses cstr) ⊫ℒ [relation_of_constraint cstr]. + Proof. + split. + - constructor. + destruct cstr as [[l []] r]. cbn. + apply Clauses.entails_L_relations_of_clauses_le. + apply Clauses.entails_L_relations_of_clauses_eq. + constructor. + - red. apply Forall_forall => [] [] l r /relations_of_clauses_spec [] prems [] concl [] hin [=] -> ->. + now apply entails_to_clauses. + Qed. + + Lemma entails_equiv_cons {rs r rs'} : rs ⊫ℒ r :: rs' <-> rs ⊩ℒ [r] /\ rs ⊩ℒ rs' /\ r :: rs' ⊩ℒ rs. + Proof. + split. + - move=> [] h; depelim h. intros hrs. + split. constructor => //. constructor => //. + - move=> [] rsr [] rsr' a. + split => //. constructor => //. now depelim rsr. + Qed. + + Lemma relations_of_clauses_eq {s s' : clauses} : + s =_clset s' -> + equivlistA Logic.eq (Clauses.relations_of_clauses s) (Clauses.relations_of_clauses s'). + Proof. + intros eq. + red. intros []; rewrite !InA_In_eq. + split. + Admitted. + + Lemma entails_L_all_relations_of_clauses {cls cls'} : + cls =_clset cls' -> + relations_of_clauses cls ⊩ℒ relations_of_clauses cls'. + Proof. + intros heq. rewrite (relations_of_clauses_eq heq). + reflexivity. + Qed. + + Lemma entails_L_clauses_incl {rs rs'} : + incl rs rs' -> + rs' ⊩ℒ rs. + Proof. + induction rs in rs' |- *. + - constructor. + - intros i. constructor. destruct a; eapply entails_c. apply i. now constructor. + apply IHrs. intros r hin. apply i. now right. + Qed. + + Lemma entails_L_clauses_subset_all {cls cls'} : + cls ⊂_clset cls' -> + relations_of_clauses cls' ⊩ℒ relations_of_clauses cls. + Proof. + intros heq. + have hm := relations_of_clauses_mon heq. + now eapply entails_L_clauses_incl. + Qed. + + Lemma of_z_constraints_subset {cstrs cstrs'} : + ZUnivConstraintSet.Subset cstrs cstrs' -> + of_z_constraints cstrs ⊂_clset of_z_constraints cstrs'. + Proof. + Admitted. + + Lemma entails_L_c {rs r} : In r rs -> rs ⊢ℒ r. + Proof. destruct r; apply entails_c. Qed. + + Lemma entails_L_clauses_cons {rs r rs'} : + rs ⊢ℒ r -> rs ⊩ℒ rs' -> rs ⊩ℒ r :: rs'. + Proof. intros h h'; now constructor. Qed. +Print of_z_constraints. + Lemma of_z_constraints_add x s : + of_z_constraints (ZUnivConstraintSet.add x s) =_clset Clauses.union (LoopCheck.to_clauses x) (of_z_constraints s). + Proof. Admitted. + + Instance entails_L_rels_proper : Proper (equivlistA Logic.eq ==> equivlistA Logic.eq ==> iff) entails_L_rels. + Proof. + intros l l' h ?? h'. split; now rewrite h h'. + Qed. + + Instance entails_L_equiv_proper : Proper (equivlistA Logic.eq ==> equivlistA Logic.eq ==> iff) equiv_L_rels. + Proof. + intros l l' h ?? h'. split; split. 1-2:rewrite -h -h'; apply H. + rewrite h h'; apply H. + rewrite h h'; apply H. + Qed. + + Instance relations_of_clauses_proper : Proper (Clauses.Equal ==> equivlistA Logic.eq) relations_of_clauses. + Proof. + intros cls cls' H. split; rewrite !InA_In_eq. + all:eapply relations_of_clauses_mon; now rewrite H. + Qed. + + Lemma relations_of_clauses_union {cls cls'} : + equivlistA Logic.eq (relations_of_clauses (Clauses.union cls cls')) + (relations_of_clauses cls ++ relations_of_clauses cls'). + Proof. + intros eq. split; rewrite !InA_In_eq; rewrite in_app_iff. + - move/relations_of_clauses_spec => -[] prems [] concl [] hin ->. + eapply Clauses.union_spec in hin as [hin|hin]; [left|right]; + now apply (relations_of_clauses_spec_inv (_, _)). + - move=> [] /relations_of_clauses_spec => -[] prems [] concl [] hin ->; + apply (relations_of_clauses_spec_inv (_, _)); now apply Clauses.union_spec. + Qed. + + Lemma equivlistA_app_comm {A} (l l' : list A) : + equivlistA Logic.eq (l ++ l') (l' ++ l). + Proof. + intros x. rewrite !InA_In_eq !in_app_iff. firstorder. + Qed. + + Lemma equivlistA_app_cons_comm {A} (x : A) (l l' : list A) : + equivlistA Logic.eq (l ++ x :: l') (x :: l' ++ l). + Proof. + intros y. rewrite !InA_In_eq !in_app_iff //= in_app_iff. firstorder. + Qed. + + Lemma entails_L_all_app {x y x' y'} : + x ⊩ℒ x' -> y ⊩ℒ y' -> x ++ y ⊩ℒ x' ++ y'. + Proof. + intros hx hy. + rewrite equivlistA_app_comm. + induction hy. + - rewrite app_nil_r. + now eapply entails_L_all_weaken. + - rewrite equivlistA_app_cons_comm. constructor. + rewrite -equivlistA_app_comm. eapply entails_L_rels_subset; tea. + move=> ?; rewrite in_app_iff; now right. + rewrite (equivlistA_app_comm l x'). exact IHhy. + Qed. + + Lemma entails_L_all_union {x y x' y'} : + x ⊫ℒ x' -> y ⊫ℒ y' -> x ++ y ⊫ℒ x' ++ y'. + Proof. + intros [hx hx'] [hy hy']. + split; now apply entails_L_all_app. + Qed. + + Lemma relations_of_clauses_constraints_add {x s} : + (relation_of_constraint x :: relations_of_clauses (of_z_constraints s)) ⊫ℒ + (relations_of_clauses (of_z_constraints (ZUnivConstraintSet.add x s))). + Proof. + rewrite of_z_constraints_add relations_of_clauses_union. + eapply (entails_L_all_union (x := [_])). + 2:{ reflexivity. } + now rewrite relation_of_constraint_of_clause. + Qed. + + Lemma rels_of_z_constraints_spec {cstrs} : + (relations_of_clauses (of_z_constraints cstrs)) ⊫ℒ (relations_of_constraints cstrs). + Proof. + rewrite /relations_of_constraints. + have he := ZUnivConstraintSetProp.fold_rec (P := fun s f => relations_of_clauses (of_z_constraints s) +⊫ℒ f). apply: he. + - split. constructor. red. apply Forall_forall => [] l r. + eapply relations_of_clauses_spec in r as [prems [concl [hin heq]]]. subst l. + eapply of_z_constraints_spec in hin as [cstr [hin ]]. now apply H in hin. + - move=> x a s' s'' hin hnin hadd hr. + rewrite entails_equiv_cons. + split; [|split] => //. + * have hins'' : ZUnivConstraintSet.In x s''. + { apply hadd; now left. } + rewrite -relation_of_constraint_of_clause. + apply entails_L_clauses_subset_all. + move=> cl incl. apply of_z_constraints_spec. now exists x. + * have ha := @entails_L_clauses_subset_all (of_z_constraints s') (of_z_constraints s''). + transitivity (relations_of_clauses (of_z_constraints s')) => //. + apply ha. apply of_z_constraints_subset => ? hin'. apply hadd. now right. + apply hr. + * destruct hr. + transitivity (relation_of_constraint x :: relations_of_clauses (of_z_constraints s')). + apply entails_L_clauses_cons. now apply entails_L_c; constructor. + now eapply (entails_L_all_weaken (w:=[_])). + clear -hadd; intros. + rewrite relations_of_clauses_constraints_add. + eapply entails_L_clauses_subset_all. + eapply of_z_constraints_subset. + apply ZUnivConstraintSetProp.Add_Equal in hadd. now rewrite hadd. + Qed. Lemma entails_L_clauses_all {cstrs s t} : - (relations_of_clauses (of_z_constraints cstrs)) ⊢ℒ s ≡ t -> + (relations_of_clauses (of_z_constraints cstrs)) ⊢ℒ s ≡ t <-> (relations_of_constraints cstrs) ⊢ℒ s ≡ t. Proof. - induction 1; try solve [econstructor; eauto]. cbn in H. - move/relations_of_clauses_spec: H => [prems [concl [hin heq]]]. - noconf heq. - move/of_z_constraints_spec: hin => [cstr [hin hin']]. - destruct cstr as [[l d] r]. - eapply LoopCheck.to_clauses_spec in hin'. - destruct d; eapply entails_L_le_eq. - - destruct hin' as [? [hin' heq]]. noconf heq. - eapply entails_L_le_trans with l. - * now eapply entails_L_in. - * constructor. cbn. rewrite relations_of_constraints_spec. - eexists; split; tea. now cbn. - - destruct hin' as [hin'|hin']; - destruct hin' as [? [hin' heq]]; noconf heq. - * eapply entails_L_le_trans with l. - + now eapply entails_L_in. - + eapply entails_L_eq_le_1. - constructor. cbn. rewrite relations_of_constraints_spec. - eexists; split; tea. cbn. now cbn. - * eapply entails_L_le_trans with r. - + now eapply entails_L_in. - + eapply entails_L_eq_le_1. apply entails_sym. - constructor. cbn. rewrite relations_of_constraints_spec. - eexists; split; tea. cbn. now cbn. + now rewrite rels_of_z_constraints_spec. Qed. Lemma entails_L_clauses_le {cstrs s t} : - entails_L_clauses (relations_of_clauses (of_z_constraints cstrs)) (s ⋞ t) -> + entails_L_pres_clauses (relations_of_clauses (of_z_constraints cstrs)) (s ⋞ t) -> relations_of_constraints cstrs ⊢ℒ s ≤ t. Proof. intros hf. do 2 red in hf. rw_in clauses_of_le_spec hf. @@ -1099,11 +1410,11 @@ End ZUnivConstraint. Qed. Lemma entails_L_clauses_of_eq {cstrs s t} : - entails_L_clauses (relations_of_clauses (of_z_constraints cstrs)) (s ≡ t) -> + entails_L_pres_clauses (relations_of_clauses (of_z_constraints cstrs)) (s ≡ t) -> relations_of_constraints cstrs ⊢ℒ s ≡ t. Proof. intros hf. do 2 red in hf. - eapply entails_L_eq_antisym. + eapply entails_L_eq_antisym. split. all: apply entails_L_clauses_le. - intros cl hin; red. eapply hf. rewrite /clauses_of_eq. clsets. @@ -1119,7 +1430,7 @@ End ZUnivConstraint. end. Lemma entails_L_clauses_cstr {cstrs c} : - entails_L_clauses (relations_of_clauses (of_z_constraints cstrs)) (LoopCheck.to_clauses c) -> + entails_L_clauses (of_z_constraints cstrs) (LoopCheck.to_clauses c) -> entails_L_cstr (relations_of_constraints cstrs) c. Proof. destruct c as [[l []] r]. @@ -1149,10 +1460,6 @@ End ZUnivConstraint. End interp. - Structure semilattice := - { carrier :> Type; - sl : Semilattice carrier Z }. - Definition Z_semilattice := {| carrier := Z; sl := _ |}. Instance semlattice_Semilattice (s : semilattice) : Semilattice (carrier s) Z := sl s. @@ -1228,11 +1535,11 @@ End ZUnivConstraint. split. - move/completeness_eq_cstrs. cbn. intros h; red in h. cbn in h. - eapply Theory.le_spec. now rewrite /C.le. + eapply Theory.le_spec. now rewrite /Clauses.le. - move/entails_ℋ_entails_L. apply entails_L_clauses_le. Qed. - Import LoopCheck.Impl.I.Model.Model.Clauses.FLS. + (* Import LoopCheck.Impl.I.Model.Model.Clauses.FLS. *) Definition presentation_entails cstrs c := let '(l, d, r) := to_constraint c in @@ -1254,14 +1561,13 @@ End ZUnivConstraint. now rewrite to_clauses_of_z_constraints. Qed. - Section SemiLatticeInterp. - Import Semilattice. - + Import Semilattice. + Import ISL. Lemma presentation_entails_valid_eq {p l r} : p ⊢ℒ l ≡ r -> valid_constraint p (l, ConstraintType.Eq, r). Proof. - move/presentation_entails_valid_rel. + move/completeness. rewrite /valid_relation /valid_constraint /interp_z_cstr //=. Qed. @@ -1313,8 +1619,7 @@ End ZUnivConstraint. (* Lemma model_valuation_of_cstrs : interp_rels (LoopCheck.valuation m) *) - Definition model_Z_val m := (to_Z_val (to_val (LoopCheck.valuation (model m)))). - + Definition model_Z_val m := (to_Z_val (LoopCheck.valuation (model m))). Lemma interp_rels_of_m m : interp_rels (model_Z_val m) (relations_of_constraints (to_z_cstrs (constraints m))). Proof. @@ -1325,11 +1630,11 @@ End ZUnivConstraint. have hrepr := repr_constraints m _ hin. destruct cstr as [[l' []] r']; cbn in heq; noconf heq. - rewrite /interp_rel interp_prems_union. cbn in hrepr. - eapply clauses_sem_subset in hv; tea. + eapply UnivLoopChecking.clauses_sem_subset in hv; tea. apply clauses_sem_clauses_of_le in hv. cbn in hv |- *. unfold model_Z_val in *. lia. - cbn in hrepr. - eapply clauses_sem_subset in hv; tea. + eapply UnivLoopChecking.clauses_sem_subset in hv; tea. rewrite /Clauses.clauses_of_eq in hv. eapply clauses_sem_union in hv. destruct hv as [hv hv']. apply clauses_sem_clauses_of_le in hv. @@ -1389,193 +1694,15 @@ End ZUnivConstraint. | ConstraintType.Le => ~ (interp_prems v (to_atoms l) <= interp_prems v (to_atoms r))%Z end. - Section Completeness. - - Definition add_presentation eq p := - {| V := p.(V); C := eq :: p.(C) |}. - - Definition relation_levels (r : rel) := NES.levels r.1 ∪ NES.levels r.2. - - Definition wf_presentation p := - forall r, List.In r p.(C) -> relation_levels r ⊂_lset p.(V). - - Definition levels_position (l : Level.t) (ls : LevelSet.t) i := - List.nth_error (LevelSet.elements ls) i = Some l. - - Equations level_position (l : Level.t) (ls : list Level.t) : option nat := - level_position l [] := None ; - level_position l (x :: xs) with Level.eqb l x := - { | true => Some 0 - | false with level_position l xs := - | None => None - | Some n => Some (S n) }. - - Definition levelexpr_pos (l : LevelExpr.t) (ls : LevelSet.t) := - match level_position l.1 (LevelSet.elements ls) with - | None => 0 - | Some pos => LevelSet.cardinal ls * Z.to_nat l.2 + pos - end. - - Section Enum. - - Inductive enumeration : premises × premises -> Type := - | enum_single le le' : enumeration (singleton le, singleton le') - | enum_add_left le (u v : premises) : ~ LevelExprSet.In le u -> enumeration (u, v) -> enumeration (NES.add le u, v) - | enum_add_right le (u v : premises) : ~ LevelExprSet.In le v -> enumeration (u, v) -> enumeration (u, NES.add le v). - - Lemma acc_enum : forall r, enumeration r. - Proof. - intros [l r]. - move: l r. apply: NES.elim. - - intros le. - apply: NES.elim. - * intros le'. constructor. - * intros le' x. now constructor. - - intros le x ihr nin r. now constructor. - Qed. - End Enum. - Definition strict_subset (s s' : LevelExprSet.t) := - LevelExprSet.Subset s s' /\ ~ LevelExprSet.Equal s s'. - -(* Lemma strict_subset_incl (x y z : LevelSet.t) : LevelSet.Subset x y -> strict_subset y z -> strict_subset x z. -Proof. - intros hs []. split => //. lsets. - intros heq. apply H0. lsets. -Qed. *) - - Definition premises_strict_subset (x y : premises) := strict_subset x y. - - Definition ord := lexprod premises_strict_subset premises_strict_subset. - Derive Signature for lexprod. - - Lemma premises_incl_singleton (u : premises) le : - u ⊂_leset (singleton le) -> LevelExprSet.Equal u (singleton le). - Proof. - intros incl; split => //. - - apply incl. - - intros hin. eapply LevelExprSet.singleton_spec in hin. subst. - move: u incl. apply: NES.elim. - * intros le' hs. specialize (hs le'). forward hs. apply LevelExprSet.singleton_spec. lesets. - apply LevelExprSet.singleton_spec in hs. subst le'. - now apply LevelExprSet.singleton_spec. - * intros le' x ih hnin hadd. - rewrite LevelExprSet.add_spec. right; apply ih. - intros ? hin. apply hadd. now rewrite LevelExprSet.add_spec; right. - Qed. - - Lemma subset_add {a l x} : - ~ LevelExprSet.In l a -> a ⊂_leset NES.add l x -> a ⊂_leset x. - Proof. - intros hnin; rewrite -union_add_singleton. - move=> hsub lk /[dup]/hsub. rewrite union_spec. - intros [] => //. apply LevelExprSet.singleton_spec in H. subst. contradiction. - Qed. - - (* Lemma subset_add_2 {a l x} : - LevelExprSet.In l a -> a ⊂_leset NES.add l x -> a ⊂_leset x. - Proof. - intros hnin; rewrite -union_add_singleton. - move=> hsub lk /[dup]/hsub. rewrite union_spec. - intros [] => //. apply LevelExprSet.singleton_spec in H. subst. contradiction. - Qed. *) - - Section LevelExprSetCardinal. - - Import LevelExprSet. - Import LevelExprSetProp. - - Lemma cardinal_1_is_singleton a : cardinal a = 1 <-> exists x, Equal a (singleton x). - Proof. Admitted. - - Lemma premises_cardinal (p : premises) : cardinal p > 0. - Proof. Admitted. - - Lemma not_Equal_exists_diff (p p' : premises) : - p ⊂_leset p' -> ~ Equal p p' -> - exists le, (In le p' /\ ~ In le p). - Proof. - intros hsub neq. - pose c := choose (diff p' p). - case hc : c => [elt|]. move/choose_spec1: hc. - rewrite diff_spec => -[hin nin]. now exists elt. - move/choose_spec2: hc => hc. - have hsub' : p' ⊂_leset p. lesets. elim neq. - lesets. - Qed. - - Lemma premises_strict_subset_spec p p' : premises_strict_subset p p' <-> - (p ⊂_leset p') /\ exists le, In le p' /\ ~ In le p. - Proof. - split. - - intros [hincl hneq]. split => //. - now apply not_Equal_exists_diff. - - intros [hincl [le [inp' ninp]]]. - split => // => he. rewrite -he in inp'. contradiction. - Qed. - - Lemma premises_strict_subset_cardinal (p p' : premises) : - premises_strict_subset p p' -> (cardinal p < cardinal p')%nat. - Proof. - rewrite premises_strict_subset_spec => -[incl [le [inp' ninp]]]. - eapply subset_cardinal_lt; tea. - Qed. - - Lemma cardinal_add {le x} : ~ In le x -> cardinal (add le x) = 1 + cardinal x. - Proof. lesets. Qed. - - Lemma premises_eq_singleton {a : premises} {x} : a = singleton x :> LevelExprSet.t -> a = NES.singleton x. - Proof. - intros he. rewrite -equal_exprsets. cbn. now rewrite he. - Qed. - - Lemma premises_strict_subset_wf : well_founded premises_strict_subset. - Proof. - red. intros a. - have hr : LevelExprSet.cardinal a <= LevelExprSet.cardinal a by lesets. - revert hr. generalize a at 2 => a'. move: a' a. - apply: NES.elim. - - intros le a. rewrite NES.LevelExprSetProp.singleton_cardinal. - have carda := premises_cardinal a => cardle. - have : cardinal a = 1 by lia. - rewrite cardinal_1_is_singleton => -[x heq]. - move/eq_leibniz/premises_eq_singleton: heq. intros ->. - constructor. intros y hp. - destruct hp. eapply premises_incl_singleton in H. contradiction. - - intros le x accx hnin. - intros a asub. - constructor => y. - move/premises_strict_subset_cardinal => hc. - apply accx. rewrite cardinal_add // in asub. lia. - Qed. - End LevelExprSetCardinal. - - Lemma acc_ord r : Acc ord r. - Proof. - apply wf_lexprod; apply premises_strict_subset_wf. - Qed. - Instance ord_wf : WellFounded ord. - Proof. red. exact acc_ord. Qed. - - Definition check_pres_clause p r := - LoopCheck.Impl.check_clauses (clauses_of_relations p) (clauses_of_eq r.1 r.2). - - Lemma check_pres_clause_spec p r : p ⊢ℒ r \/ ~ (p ⊢ℒ r). - Proof. Admitted. - - Lemma premises_strict_subset_add {l} {u : premises} : - ~ LevelExprSet.In l u -> premises_strict_subset u (NES.add l u). - Proof. - intros hnin; rewrite premises_strict_subset_spec. - rewrite -union_add_singleton. setoid_rewrite union_spec. split. - - intros l'. rewrite union_spec; lesets. - - exists l; split => //. right; now apply LevelExprSet.singleton_spec. - Qed. - - - Class Decidable (A : Prop) := dec : A \/ ~ A. Arguments dec A {Decidable}. + Definition check_pres_clause p r := + LoopCheck.Impl.check_clauses (clauses_of_relations p) (clauses_of_eq r.1 r.2). + + Lemma check_pres_clause_spec p r : p ⊢ℒ r \/ ~ (p ⊢ℒ r). + Proof. Admitted. + Instance dec_entails_L {p s t} : Decidable (p ⊢ℒ s ≡ t). Proof. red. eapply check_pres_clause_spec. @@ -1587,221 +1714,71 @@ Qed. *) Definition satisfiable (s : semilattice) (r : rels) := exists v, interp_rels (SL := sl s) v r. - Definition neg_r p e := - p ⊢ℒ add_prems 1 e.1 ≤ e.2 \/ p ⊢ℒ add_prems 1 e.2 ≤ e.1. - - Definition consistent (r : rels) := - ~ (exists e, r ⊢ℒ e /\ neg_r r e). - - (* Lemma not_provable_neg p l r : ~ (p ⊢ℒ l ≡ r) -> neg_r p l r. - Proof. - intros np. red. - Admitted. *) - - Lemma entails_L_completeness {p l r} : - (forall (s : semilattice) (v : Level.t -> s), interp_rels v p -> interp_prems v l ≡ interp_prems v r) -> + (forall (s : semilattice) (v : Level.t -> s), interp_rels v p -> interp_prems v l ≡ interp_prems v r)%sl -> p ⊢ℒ l ≡ r. Proof. intros hv. - specialize (hv (initial_semilattice p) ids). + specialize (hv (initial_semilattice p) (ids p)). forward hv. { apply interp_rels_init. } rewrite !interp_triv in hv. exact hv. Qed. - Lemma check_completeness {m c} : - LoopCheck.Impl.Abstract.check_clauses m c <-> (forall (s : semilattice) (v : Level.t -> s), clauses_sem v (LoopCheck.Impl.Abstract.clauses m) -> clauses_sem v c). + Lemma equiv_constraints_clauses m : + relations_of_constraints (to_z_cstrs (constraints m)) ⊫ℒ Clauses.relations_of_clauses (LoopCheck.clauses (model m)). Proof. - rewrite LoopCheck.Impl.Abstract.check_clauses_spec. - split. - - move/entails_ℋ_entails_L. - move=> ent s v hyps cl /ent. - admit. - - intros valid. - Search entails_clauses. - Set Printing All. - rewrite /entails_L_clause. - Qed. + have repr := repr_constraints. + have repr_inv := repr_constraints_inv. + Admitted. - Lemma check_completeness {m c} : - check m c <-> (forall (s : semilattice) (v : Level.t -> s), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + (* Instance interp_rel_proper {S} {SL : Semilattice S Q.t} V : Proper (equiv_L_rels ==> iff) (interp_rel V). Proof. - destruct check eqn:hc. - - split => // _ s v hu. - eapply check_valid_pres in hc. - destruct c as [[l []] r]; cbn in hc. - * red in hu. have := presentation_entails_satisfies hc. v => /fwd. - { admit. } - rewrite interp_prems_union. cbn. lia. - * have := presentation_entails_satisfies hc v => /fwd. - -(* - Lemma satisfies_entails_presentation {m c} : - check m c = false <-> exists v, interp_univ_cstrs v (constraints m) -> invalid_cstr v c. + intros rs rs' h. *) + Instance interp_rels_entails_proper {S} {SL : Semilattice S Q.t} V : Proper (entails_L_rels ==> impl) (interp_rels V). Proof. - split; revgoals. - - intros [v hv]. - - have vm := LoopCheck.model_valuation (model m). - - intros he. eapply presentation_entails_valid in he. - red in he. intros v hv. apply (he v). cbn. - now rewrite -interp_univ_cstrs_relations. - - intros hv. - have hvm := (LoopCheck.model_valuation m.(model)). - red. - specialize (hv (LoopCheck.valuation m.(model))). - forward hv. apply interp_univ_cstrs_of_m. cbn in hv. - destruct c as [[l []] r]; cbn in *. - - eapply - - - - - - apply interp_univ_cstrs_of_m. - apply he. cbn. - apply interp_rels_of_m. - - move=> [v [ics ic]]. *) - + intros rs rs' hl. + induction rs' in rs, hl |- *. + * constructor. + * intros H0. depelim hl. specialize (IHrs' _ hl H0). constructor => //. + eapply entails_L_valid in H. + now apply (H {| carrier := S; sl := SL |} V H0). + Qed. - Lemma satisfies_entails_presentation {m c} : - check m c <-> (forall v, interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + Instance interp_rels_proper {S} {SL : Semilattice S Q.t} V : Proper (equiv_L_rels ==> iff) (interp_rels V). Proof. - destruct check eqn:hc. - - split => // _ v hu. - eapply check_valid_pres in hc. - destruct c as [[l []] r]; cbn in hc. - * have := presentation_entails_satisfies hc v => /fwd. - { admit. } - rewrite interp_prems_union. cbn. lia. - * have := presentation_entails_satisfies hc v => /fwd. - + intros rs rs' [hl hr]. + split; now apply interp_rels_entails_proper. + Qed. - rewrite check_ + Lemma check_completeness {m c} : + check m c <-> (forall (s : semilattice) (v : Level.t -> s), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + Proof. + rewrite LoopCheck.check_complete /LoopCheck.valid_entailments. split. - - - intros hv. - have [v hc] : exists v, interp_rels v (C p). - admit. - specialize (hv _ hc). - - induction 1; cbn; move=> v hv. - 1:by red in hv; rewrite Forall_forall in hv; eapply hv in H. - all:try specialize (IHentails_L _ hv). - all:try specialize (IHentails_L1 _ hv). - all:try specialize (IHentails_L2 _ hv). - all:try lia; eauto. - all:rewrite ?interp_add_prems ?interp_prems_union ?interp_add_prems; try lia. - rewrite ?interp_add_prems in IHentails_L. lia. + - intros hv s v hp. + move: (hv s (sl s) v) => /fwd. + { rewrite interp_univ_cstrs_relations in hp. + rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. + rewrite -[Clauses.relations_of_clauses _]equiv_constraints_clauses. + exact hp. } + rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. + rewrite relation_of_constraint_of_clause. + rewrite /Clauses.ISL.interp_rels => h. depelim h. clear h. + red. red. destruct c as [[l []] r]; cbn in H |- * => //. + red. now rewrite interp_prems_union in H. + - intros hs S SL V hsem. + move: (hs {| carrier := S; sl := SL |} V) => /fwd. + { rewrite interp_univ_cstrs_relations. + rewrite equiv_constraints_clauses. + rewrite -[interp_rels _ _]LoopCheck.Impl.Abstract.interp_rels_clauses_sem. + exact hsem. } + rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. + rewrite relation_of_constraint_of_clause. + rewrite /Clauses.ISL.interp_rels => h. constructor; [|constructor]. + red. red. destruct c as [[l []] r]; cbn in hsem |- * => //. + red. now rewrite interp_prems_union. Qed. - End UnivLoopChecking. - -(* Completeness try *) -(* - - - Parameter ϕ : nat -> rel. - Parameter ϕ_exists : forall r, exists n, ϕ n = r. - Parameter ϕ_inj : forall n n', ϕ n = ϕ n' -> n = n'. - - Definition neg_r p e := - p ⊢ℒ add_prems 1 e.1 ≤ e.2 \/ p ⊢ℒ add_prems 1 e.2 ≤ e.1. - - (* Definition consistent (r : rels) := - ~ (exists e, r ⊢ℒ e /\ neg_r r e). - - Definition satisfiable (r : rels) := - exists v, interp_rels v r. - - Definition satisfiable_consistent {p} : - satisfiable p -> consistent p. - Proof. - move=> [v it] [[l r] [hx [hnl|hnl]]]; - eapply presentation_entails_valid_eq in hx; - eapply presentation_entails_valid_le in hnl; - move: (hx _ it); move: (hnl _ it); cbn; - rewrite !interp_add_prems; lia. - Qed. *) - - (* Definition consistent' (Γ : rels) := - exists r, ~ (Γ ⊢ℒ r). *) - - Definition bottom (s : semilattice) := - exists x : s, add 1%Z x ≤ x. - - Notation "⟘" := (bottom _) : sl_scope. - - Definition consistent Γ := - ~ exists e, Γ ⊢ℒ e ≡ add_prems 1 e. - - Inductive 𝒮 (r : rels) : rels -> nat -> Prop := - | S_0 Γ : List.incl Γ r -> 𝒮 r Γ 0 - | S_incl Γ n : 𝒮 r Γ n -> - (* ~ consistent (ϕ n :: Γ) -> *) - 𝒮 r Γ (S n) - | S_phi Γ n : 𝒮 r Γ n -> consistent (ϕ n :: Γ) -> 𝒮 r (ϕ n :: Γ) (S n). - - Definition 𝒮ω rs (Γ : rels) := exists (n: nat), 𝒮 rs Γ n. - - Definition in𝒮ω rs r := exists (n: nat) Γ, 𝒮 rs Γ n /\ Γ ⊢ℒ r. - - (* /\ Γ ⊢ℒ r *) - - Definition maximally_consistent (Γ : rels) := - consistent Γ /\ forall r, (~ consistent (r :: Γ) \/ Γ ⊢ℒ r). - - Definition satisfiable (s : semilattice) (r : rels) := - exists v, interp_rels (SL := sl s) v r. - - Lemma consistent_satisfiable Γ : - satisfiable Z_semilattice Γ -> consistent Γ. - Proof. - move=> [v sat] [e]. - move/presentation_entails_valid_rel/(_ Z_semilattice v sat). cbn. - rewrite interp_add_prems. change (add 1%Z (interp_prems v e)) with (Z.add 1 (interp_prems v e)). - cbn -[Z.add]. lia. - Qed. - - Section MaximallyConsistent. - - Lemma 𝒮ω_consistent_maximal Γ Γ' n : consistent Γ -> 𝒮 Γ Γ' n -> consistent Γ'. - (* /\ (consistent' (ϕ n :: Γ') \/ Γ' ⊢ℒ ϕ n). *) - Proof. - move=> con sprf. induction sprf. - - intros [e pe]. apply con. exists e. - eapply entails_L_rels_subset; tea. - - exact IHsprf. - - intros [e neq]. - destruct H. now exists e. - Qed. - - Definition 𝒮ω_exists rs (crs : consistent rs) n : exists Γ, 𝒮 rs Γ n. - Proof. - induction n. - - exists rs. by constructor. - - destruct IHn as [Γ' sn]. - destruct (check_pres_clause_spec Γ' (ϕ n)). - * exists (ϕ n :: Γ'). apply S_phi => //. - intros [e he]. apply 𝒮ω_consistent_maximal in sn => //. - eapply entails_L_cut in H; tea. - apply sn. now exists e. - * exists Γ'. apply S_incl => //. - Qed. - - Definition inSw rs r := exists n Γ, 𝒮 rs Γ n /\ Γ ⊢ℒ r. - - Import Semilattice. - - Lemma axiom_inSw {rs r} : rs ⊢ℒ r -> inSw rs r. - Proof. - intros hs. exists 0, rs; split. constructor. red; auto. - exact: hs. - Qed. - -*) \ No newline at end of file diff --git a/template-rocq/theories/Junk.v b/template-rocq/theories/Junk.v index e3cfc2831..ab7f6fd21 100644 --- a/template-rocq/theories/Junk.v +++ b/template-rocq/theories/Junk.v @@ -592,3 +592,288 @@ Section Completeness. Lemma all_terms (x : s) : exists t : term, + + + + Section Completeness. + + Definition add_presentation eq p := + {| V := p.(V); C := eq :: p.(C) |}. + + Definition relation_levels (r : rel) := (NES.levels r.1 ∪ NES.levels r.2)%levels. + + Definition wf_presentation p := + forall r, List.In r p.(C) -> relation_levels r ⊂_lset p.(V). + + Definition levels_position (l : Level.t) (ls : LevelSet.t) i := + List.nth_error (LevelSet.elements ls) i = Some l. + + Equations level_position (l : Level.t) (ls : list Level.t) : option nat := + level_position l [] := None ; + level_position l (x :: xs) with Level.eqb l x := + { | true => Some 0 + | false with level_position l xs := + | None => None + | Some n => Some (S n) }. + + Definition levelexpr_pos (l : LevelExpr.t) (ls : LevelSet.t) := + match level_position l.1 (LevelSet.elements ls) with + | None => 0 + | Some pos => LevelSet.cardinal ls * Z.to_nat l.2 + pos + end. + + Section Enum. + + Inductive enumeration : premises × premises -> Type := + | enum_single le le' : enumeration (singleton le, singleton le') + | enum_add_left le (u v : premises) : ~ LevelExprSet.In le u -> enumeration (u, v) -> enumeration (NES.add le u, v) + | enum_add_right le (u v : premises) : ~ LevelExprSet.In le v -> enumeration (u, v) -> enumeration (u, NES.add le v). + + Lemma acc_enum : forall r, enumeration r. + Proof. + intros [l r]. + move: l r. apply: NES.elim. + - intros le. + apply: NES.elim. + * intros le'. constructor. + * intros le' x. now constructor. + - intros le x ihr nin r. now constructor. + Qed. + End Enum. + Definition strict_subset (s s' : LevelExprSet.t) := + LevelExprSet.Subset s s' /\ ~ LevelExprSet.Equal s s'. + +(* Lemma strict_subset_incl (x y z : LevelSet.t) : LevelSet.Subset x y -> strict_subset y z -> strict_subset x z. +Proof. + intros hs []. split => //. lsets. + intros heq. apply H0. lsets. +Qed. *) + + Definition premises_strict_subset (x y : premises) := strict_subset x y. + + Definition ord := lexprod premises_strict_subset premises_strict_subset. + Derive Signature for lexprod. + + Lemma premises_incl_singleton (u : premises) le : + u ⊂_leset (singleton le) -> LevelExprSet.Equal u (singleton le). + Proof. + intros incl; split => //. + - apply incl. + - intros hin. eapply LevelExprSet.singleton_spec in hin. subst. + move: u incl. apply: NES.elim. + * intros le' hs. specialize (hs le'). forward hs. apply LevelExprSet.singleton_spec. lesets. + apply LevelExprSet.singleton_spec in hs. subst le'. + now apply LevelExprSet.singleton_spec. + * intros le' x ih hnin hadd. + rewrite LevelExprSet.add_spec. right; apply ih. + intros ? hin. apply hadd. now rewrite LevelExprSet.add_spec; right. + Qed. + + Lemma subset_add {a l x} : + ~ LevelExprSet.In l a -> a ⊂_leset NES.add l x -> a ⊂_leset x. + Proof. + intros hnin; rewrite -union_add_singleton. + move=> hsub lk /[dup]/hsub. rewrite union_spec. + intros [] => //. apply LevelExprSet.singleton_spec in H. subst. contradiction. + Qed. + + (* Lemma subset_add_2 {a l x} : + LevelExprSet.In l a -> a ⊂_leset NES.add l x -> a ⊂_leset x. + Proof. + intros hnin; rewrite -union_add_singleton. + move=> hsub lk /[dup]/hsub. rewrite union_spec. + intros [] => //. apply LevelExprSet.singleton_spec in H. subst. contradiction. + Qed. *) + + Section LevelExprSetCardinal. + + Import LevelExprSet. + Import LevelExprSetProp. + + Lemma cardinal_1_is_singleton a : cardinal a = 1 <-> exists x, Equal a (singleton x). + Proof. Admitted. + + Lemma premises_cardinal (p : premises) : cardinal p > 0. + Proof. Admitted. + + Lemma not_Equal_exists_diff (p p' : premises) : + p ⊂_leset p' -> ~ Equal p p' -> + exists le, (In le p' /\ ~ In le p). + Proof. + intros hsub neq. + pose c := choose (diff p' p). + case hc : c => [elt|]. move/choose_spec1: hc. + rewrite diff_spec => -[hin nin]. now exists elt. + move/choose_spec2: hc => hc. + have hsub' : p' ⊂_leset p. lesets. elim neq. + lesets. + Qed. + + Lemma premises_strict_subset_spec p p' : premises_strict_subset p p' <-> + (p ⊂_leset p') /\ exists le, In le p' /\ ~ In le p. + Proof. + split. + - intros [hincl hneq]. split => //. + now apply not_Equal_exists_diff. + - intros [hincl [le [inp' ninp]]]. + split => // => he. rewrite -he in inp'. contradiction. + Qed. + + Lemma premises_strict_subset_cardinal (p p' : premises) : + premises_strict_subset p p' -> (cardinal p < cardinal p')%nat. + Proof. + rewrite premises_strict_subset_spec => -[incl [le [inp' ninp]]]. + eapply subset_cardinal_lt; tea. + Qed. + + Lemma cardinal_add {le x} : ~ In le x -> cardinal (add le x) = 1 + cardinal x. + Proof. lesets. Qed. + + Lemma premises_eq_singleton {a : premises} {x} : a = singleton x :> LevelExprSet.t -> a = NES.singleton x. + Proof. + intros he. rewrite -equal_exprsets. cbn. now rewrite he. + Qed. + + Lemma premises_strict_subset_wf : well_founded premises_strict_subset. + Proof. + red. intros a. + have hr : LevelExprSet.cardinal a <= LevelExprSet.cardinal a by lesets. + revert hr. generalize a at 2 => a'. move: a' a. + apply: NES.elim. + - intros le a. rewrite NES.LevelExprSetProp.singleton_cardinal. + have carda := premises_cardinal a => cardle. + have : cardinal a = 1 by lia. + rewrite cardinal_1_is_singleton => -[x heq]. + move/eq_leibniz/premises_eq_singleton: heq. intros ->. + constructor. intros y hp. + destruct hp. eapply premises_incl_singleton in H. contradiction. + - intros le x accx hnin. + intros a asub. + constructor => y. + move/premises_strict_subset_cardinal => hc. + apply accx. rewrite cardinal_add // in asub. lia. + Qed. + End LevelExprSetCardinal. + + Lemma acc_ord r : Acc ord r. + Proof. + apply wf_lexprod; apply premises_strict_subset_wf. + Qed. + Instance ord_wf : WellFounded ord. + Proof. red. exact acc_ord. Qed. + + Lemma premises_strict_subset_add {l} {u : premises} : + ~ LevelExprSet.In l u -> premises_strict_subset u (NES.add l u). + Proof. + intros hnin; rewrite premises_strict_subset_spec. + rewrite -union_add_singleton. setoid_rewrite union_spec. split. + - intros l'. rewrite union_spec; lesets. + - exists l; split => //. right; now apply LevelExprSet.singleton_spec. + Qed. + + + + +(* Completeness try *) +(* + + + Parameter ϕ : nat -> rel. + Parameter ϕ_exists : forall r, exists n, ϕ n = r. + Parameter ϕ_inj : forall n n', ϕ n = ϕ n' -> n = n'. + + Definition neg_r p e := + p ⊢ℒ add_prems 1 e.1 ≤ e.2 \/ p ⊢ℒ add_prems 1 e.2 ≤ e.1. + + (* Definition consistent (r : rels) := + ~ (exists e, r ⊢ℒ e /\ neg_r r e). + + Definition satisfiable (r : rels) := + exists v, interp_rels v r. + + Definition satisfiable_consistent {p} : + satisfiable p -> consistent p. + Proof. + move=> [v it] [[l r] [hx [hnl|hnl]]]; + eapply presentation_entails_valid_eq in hx; + eapply presentation_entails_valid_le in hnl; + move: (hx _ it); move: (hnl _ it); cbn; + rewrite !interp_add_prems; lia. + Qed. *) + + (* Definition consistent' (Γ : rels) := + exists r, ~ (Γ ⊢ℒ r). *) + + Definition bottom (s : semilattice) := + exists x : s, add 1%Z x ≤ x. + + Notation "⟘" := (bottom _) : sl_scope. + + Definition consistent Γ := + ~ exists e, Γ ⊢ℒ e ≡ add_prems 1 e. + + Inductive 𝒮 (r : rels) : rels -> nat -> Prop := + | S_0 Γ : List.incl Γ r -> 𝒮 r Γ 0 + | S_incl Γ n : 𝒮 r Γ n -> + (* ~ consistent (ϕ n :: Γ) -> *) + 𝒮 r Γ (S n) + | S_phi Γ n : 𝒮 r Γ n -> consistent (ϕ n :: Γ) -> 𝒮 r (ϕ n :: Γ) (S n). + + Definition 𝒮ω rs (Γ : rels) := exists (n: nat), 𝒮 rs Γ n. + + Definition in𝒮ω rs r := exists (n: nat) Γ, 𝒮 rs Γ n /\ Γ ⊢ℒ r. + + (* /\ Γ ⊢ℒ r *) + + Definition maximally_consistent (Γ : rels) := + consistent Γ /\ forall r, (~ consistent (r :: Γ) \/ Γ ⊢ℒ r). + + Definition satisfiable (s : semilattice) (r : rels) := + exists v, interp_rels (SL := sl s) v r. + + Lemma consistent_satisfiable Γ : + satisfiable Z_semilattice Γ -> consistent Γ. + Proof. + move=> [v sat] [e]. + move/presentation_entails_valid_rel/(_ Z_semilattice v sat). cbn. + rewrite interp_add_prems. change (add 1%Z (interp_prems v e)) with (Z.add 1 (interp_prems v e)). + cbn -[Z.add]. lia. + Qed. + + Section MaximallyConsistent. + + Lemma 𝒮ω_consistent_maximal Γ Γ' n : consistent Γ -> 𝒮 Γ Γ' n -> consistent Γ'. + (* /\ (consistent' (ϕ n :: Γ') \/ Γ' ⊢ℒ ϕ n). *) + Proof. + move=> con sprf. induction sprf. + - intros [e pe]. apply con. exists e. + eapply entails_L_rels_subset; tea. + - exact IHsprf. + - intros [e neq]. + destruct H. now exists e. + Qed. + + Definition 𝒮ω_exists rs (crs : consistent rs) n : exists Γ, 𝒮 rs Γ n. + Proof. + induction n. + - exists rs. by constructor. + - destruct IHn as [Γ' sn]. + destruct (check_pres_clause_spec Γ' (ϕ n)). + * exists (ϕ n :: Γ'). apply S_phi => //. + intros [e he]. apply 𝒮ω_consistent_maximal in sn => //. + eapply entails_L_cut in H; tea. + apply sn. now exists e. + * exists Γ'. apply S_incl => //. + Qed. + + Definition inSw rs r := exists n Γ, 𝒮 rs Γ n /\ Γ ⊢ℒ r. + + Import Semilattice. + + Lemma axiom_inSw {rs r} : rs ⊢ℒ r -> inSw rs r. + Proof. + intros hs. exists 0, rs; split. constructor. red; auto. + exact: hs. + Qed. + +*) \ No newline at end of file From 9dc5b6a8c33a22385c1f9862e557a19666414ebf Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 24 Sep 2025 20:01:13 +0200 Subject: [PATCH 066/164] Cleaned up a bit UnivLoopChecking, need to dispatch lemmas from there next --- .../theories/LoopChecking/UnivLoopChecking.v | 193 ++++++++---------- template-rocq/theories/Junk.v | 28 ++- 2 files changed, 109 insertions(+), 112 deletions(-) diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 4fd7a09c7..9d5ff45b4 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -503,16 +503,6 @@ End ZUnivConstraint. apply levels_spec. now exists k. Qed. - (* Lemma univ_in_add n u : Universes.LevelSet.Equal - (Universe.levels (Universe.add_prems n u)) - (Universe.levels u). - Proof. - intros l. rewrite !Universe.levels_spec. - rw Universe.add_spec. - firstorder. subst n. destruct n; noconf H; cbn. now exists n0. - exists (n + x), (l, x). split => //. - Qed. *) - Lemma clauses_levels_union cls cls' : clauses_levels (Clauses.union cls cls') =_lset LevelSet.union (clauses_levels cls) (clauses_levels cls'). Proof. @@ -738,17 +728,6 @@ End ZUnivConstraint. eapply Nat.le_antisymm; now apply clauses_sem_val. Qed. - Lemma to_of_valuation V v : - forall l, LevelSet.In l.1 V -> val (to_valuation (to_val (of_valuation V v))) l = val v l. - Proof. - Admitted. - - Lemma to_of_valuation_univ V v : - forall u : Universe.t, LevelSet.Subset (Universe.levels u) V -> - val (to_valuation (to_val (of_valuation V v))) u = val v u. - Proof. - Admitted. - Lemma of_valuation_spec V v : forall l k, LevelMap.MapsTo l k (of_valuation V v) <-> (LevelSet.In l V /\ k = val v l). @@ -777,6 +756,51 @@ End ZUnivConstraint. split => //. Qed. + + Lemma to_of_valuation V v : + forall l, LevelSet.In l.1 V -> val (to_valuation (to_val (of_valuation V v))) l = val v l. + Proof. + intros l hin. + destruct l; cbn. f_equal. + destruct e; cbn => //. todo ("mono valuation"). + unfold to_val. + destruct (find_spec (Level.lvar n0) (of_valuation V v)). + - eapply of_valuation_spec in H. + destruct H as [hin' ->]. cbn in *. + reflexivity. + - cbn in *. elim H. + exists (val v (Level.lvar n0)). + rewrite [LevelMap.Raw.MapsTo _ _ _]of_valuation_spec. + split => //. + Qed. + + Lemma to_of_valuation_univ V v : + forall u : Universe.t, LevelSet.Subset (Universe.levels u) V -> + val (to_valuation (to_val (of_valuation V v))) u = val v u. + Proof. + apply: Universe.NES.elim. + - move=> le incl. + cbn. + rewrite to_of_valuation. + apply incl. + rewrite Universe.levels_spec. exists le.2. + now destruct le; apply Universes.LevelExprSet.singleton_spec. + reflexivity. + - move=> le u hincl hnin hincl'. + have hl : Universe.levels u ⊂_lset V. + { intros ? hin. apply hincl'. + rewrite Universe.levels_spec in hin. + destruct hin as [k hin]. + rewrite Universe.levels_spec. exists k. + rewrite Universes.LevelExprSet.add_spec. now right. } + rewrite !val_add // hincl //. + forward hincl by assumption. + rewrite to_of_valuation //. + apply hincl'. + rewrite Universe.levels_spec. exists le.2. + rewrite Universes.LevelExprSet.add_spec. now left; destruct le. + Qed. + Lemma clauses_levels_mon {cls cls'} : cls ⊂_clset cls' -> clauses_levels cls ⊂_lset clauses_levels cls'. @@ -905,15 +929,6 @@ End ZUnivConstraint. exists cstr. firstorder. Qed. - (* Lemma to_z_cstrs_spec {cstrs} : - forall c, UnivConstraintSet.In c cstrs <-> ZUnivConstraintSet.In (to_constraint c) (to_z_cstrs cstrs). - Proof. - intros c; split. - - by move/to_z_cstrs_spec_1 => [] cstrz [] hin heq; subst cstrz. - - move/to_z_cstrs_spec_2 => [] cstr [] hin heq. - destruct c as [[] ?], cstr as [[] ?]; cbn in heq. noconf heq. *) - - Lemma check_valid m c : check m c <-> entails_cstr (constraints m) c. Proof. @@ -938,23 +953,6 @@ End ZUnivConstraint. - intros x y. rewrite interp_prems_union; cbn. lia. Qed. - (* Definition valid_entailment cls cl := - forall A {SL : Semilattice A Z} V, clauses_sem V cls -> clause_sem V cl. *) - - (* Definition valid_entailments cls cls' := - forall A {SL : Semilattice A Z} V, clauses_sem V cls -> clauses_sem V cls'. *) - - (* Lemma entails_cstr_spec cstrs c : - (exists V, clauses_sem V (of_z_constraints cstrs)) -> - entails_z_cstr cstrs c -> - (forall cl, Clauses.In cl (LoopCheck.to_clauses c) -> - valid_entailment (of_z_constraints cstrs) cl). - Proof. - rewrite /entails_cstr /entails_clauses. - move=> ev hf cl /hf he. red. - now eapply clauses_sem_entails in he. - Qed. *) - Definition relation_of_constraint (c : ZUnivConstraint.t) := let '(l, d, r) := c in match d with @@ -1238,7 +1236,9 @@ End ZUnivConstraint. intros eq. red. intros []; rewrite !InA_In_eq. split. - Admitted. + - apply relations_of_clauses_mon. clsets. + - apply relations_of_clauses_mon. clsets. + Qed. Lemma entails_L_all_relations_of_clauses {cls cls'} : cls =_clset cls' -> @@ -1271,7 +1271,9 @@ End ZUnivConstraint. ZUnivConstraintSet.Subset cstrs cstrs' -> of_z_constraints cstrs ⊂_clset of_z_constraints cstrs'. Proof. - Admitted. + move=> hsub cl /of_z_constraints_spec => -[] cstr [] hin incl. + rewrite of_z_constraints_spec. exists cstr. split => //. now apply hsub. + Qed. Lemma entails_L_c {rs r} : In r rs -> rs ⊢ℒ r. Proof. destruct r; apply entails_c. Qed. @@ -1279,10 +1281,29 @@ End ZUnivConstraint. Lemma entails_L_clauses_cons {rs r rs'} : rs ⊢ℒ r -> rs ⊩ℒ rs' -> rs ⊩ℒ r :: rs'. Proof. intros h h'; now constructor. Qed. -Print of_z_constraints. + Lemma of_z_constraints_add x s : of_z_constraints (ZUnivConstraintSet.add x s) =_clset Clauses.union (LoopCheck.to_clauses x) (of_z_constraints s). - Proof. Admitted. + Proof. + move=> cl; split. + - move/of_z_constraints_spec => -[] cstr [] hin incl. + rewrite Clauses.union_spec. rewrite ZUnivConstraintSet.add_spec in hin. + move: hin => [<-|]. now left. + move=> ins. right. rewrite of_z_constraints_spec. exists cstr; split => //; now right. + - rewrite Clauses.union_spec => -[]; destruct x as [[l []] r]. + * move/LoopCheck.to_clauses_spec => [] k [hin] ->. + rewrite of_z_constraints_spec. eexists; split => //. + rewrite ZUnivConstraintSet.add_spec; left; trea. + cbn. now eapply in_clause_of_le. + * intros hcl; rewrite of_z_constraints_spec //. eexists; split. + rewrite ZUnivConstraintSet.add_spec; left; trea. exact hcl. + * rewrite of_z_constraints_spec => -[] cstr [] hin heq. + rewrite of_z_constraints_spec. exists cstr. split => //. + rewrite ZUnivConstraintSet.add_spec; now right. + * rewrite of_z_constraints_spec => -[] cstr [] hin heq. + rewrite of_z_constraints_spec. exists cstr. split => //. + rewrite ZUnivConstraintSet.add_spec; now right. + Qed. Instance entails_L_rels_proper : Proper (equivlistA Logic.eq ==> equivlistA Logic.eq ==> iff) entails_L_rels. Proof. @@ -1489,18 +1510,6 @@ Print of_z_constraints. apply to_z_cstrs_spec_2 in hin as [cstr' [hin ->]]. exists cstr'. split => //. Qed. -(* - Lemma clauses_of_relations_of_z_constraints {cstrs} : - Clauses.eq (clauses_of_relations (relations_of_constraints cstrs)) (of_z_constraints cstrs). - Proof. - intros cl; split. rewrite of_z_constraints_spec. - - move/clauses_of_relations_spec => [[l r]] [] /relations_of_constraints_spec => -[] [[u []] v] [] hin heq //=. - * cbn in heq. noconf heq. - cbn. move/Clauses.union_spec. => -[] /clauses_of_le_spec => -[] le []. - rewrite LevelExprSet.union_spec => -[] hin' eq. - + rewrite eq. eexists; split; tea. rewrite LoopCheck.to_clauses_spec. exists le; split => //. - + subst cl. eexists (u, ConstraintType.Le, v); split; tea. rewrite LoopCheck.to_clauses_spec. exists le; split => //. *) - Lemma completeness_eq_cstrs cstrs s t : relations_of_constraints cstrs ⊢ℒ s ≡ t <-> @@ -1595,30 +1604,6 @@ Print of_z_constraints. now apply presentation_entails_valid. Qed. - (* Lemma entails_L_cstrs_spec {p cstrs} : - entails_L_cstrs p cstrs <-> entails_L_clauses p (of_z_constraints cstrs). - Proof. - rewrite /entails_L_cstrs. - split => //. - - intros hf cl hin. - eapply of_z_constraints_spec in hin as [cstr' [hin hin']]. - specialize (hf cstr' hin). - destruct cstr' as [[l []] r]. cbn in hf. - eapply LoopCheck.to_clauses_spec in hin'. - destruct hin' as [le [hin' eq]]. noconf eq. red. cbn. - apply entails_L_le_trans with l => //. now eapply entails_L_in. - cbn in hf. - eapply LoopCheck.to_clauses_spec in hin'. - destruct hin' as [[le [hin' eq]] | [le [hin' eq]]]; noconf eq; red; cbn. - apply entails_L_le_trans with l => //. now eapply entails_L_in. now apply entails_L_eq_le_1. - apply entails_L_le_trans with r => //. now eapply entails_L_in. now apply entails_L_eq_le_2. - - intros hf c hin. - admit. - Admitted. *) - - - (* Lemma model_valuation_of_cstrs : interp_rels (LoopCheck.valuation m) *) - Definition model_Z_val m := (to_Z_val (LoopCheck.valuation (model m))). Lemma interp_rels_of_m m : interp_rels (model_Z_val m) (relations_of_constraints (to_z_cstrs (constraints m))). @@ -1694,26 +1679,6 @@ Print of_z_constraints. | ConstraintType.Le => ~ (interp_prems v (to_atoms l) <= interp_prems v (to_atoms r))%Z end. - Class Decidable (A : Prop) := dec : A \/ ~ A. - Arguments dec A {Decidable}. - - Definition check_pres_clause p r := - LoopCheck.Impl.check_clauses (clauses_of_relations p) (clauses_of_eq r.1 r.2). - - Lemma check_pres_clause_spec p r : p ⊢ℒ r \/ ~ (p ⊢ℒ r). - Proof. Admitted. - - Instance dec_entails_L {p s t} : Decidable (p ⊢ℒ s ≡ t). - Proof. - red. eapply check_pres_clause_spec. - Qed. - - Lemma contra_prop A B (decB : Decidable B) : (~ B -> ~ A) -> (A -> B). - Proof. intros he a. destruct (dec B). exact H. specialize (he H). contradiction. Qed. - - Definition satisfiable (s : semilattice) (r : rels) := - exists v, interp_rels (SL := sl s) v r. - Lemma entails_L_completeness {p l r} : (forall (s : semilattice) (v : Level.t -> s), interp_rels v p -> interp_prems v l ≡ interp_prems v r)%sl -> p ⊢ℒ l ≡ r. @@ -1731,11 +1696,17 @@ Print of_z_constraints. Proof. have repr := repr_constraints. have repr_inv := repr_constraints_inv. - Admitted. + rewrite -rels_of_z_constraints_spec. + rewrite -to_clauses_of_z_constraints. + rewrite (@relations_of_clauses_eq (to_clauses (constraints m)) (LoopCheck.clauses (model m))) //. + 2:{ reflexivity. } + intros cl; rewrite to_clauses_spec. + split. + - move=> [] cstrs [] /repr incl intocl. + apply incl, intocl. + - now move/repr_inv. + Qed. - (* Instance interp_rel_proper {S} {SL : Semilattice S Q.t} V : Proper (equiv_L_rels ==> iff) (interp_rel V). - Proof. - intros rs rs' h. *) Instance interp_rels_entails_proper {S} {SL : Semilattice S Q.t} V : Proper (entails_L_rels ==> impl) (interp_rels V). Proof. intros rs rs' hl. diff --git a/template-rocq/theories/Junk.v b/template-rocq/theories/Junk.v index ab7f6fd21..5a05fa9db 100644 --- a/template-rocq/theories/Junk.v +++ b/template-rocq/theories/Junk.v @@ -876,4 +876,30 @@ Qed. *) exact: hs. Qed. -*) \ No newline at end of file +*) + + + Class Decidable (A : Prop) := dec : A \/ ~ A. + Arguments dec A {Decidable}. + + (* Definition check_pres_clause p r := + LoopCheck.Impl.check_clauses (clauses_of_relations p) (clauses_of_eq r.1 r.2). + + Lemma check_pres_clause_spec p r : p ⊢ℒ r \/ ~ (p ⊢ℒ r). + Proof. + destruct (check_pres_clause p r) eqn:eq. + - move: eq. + rewrite /check_pres_clause. + Admitted. + + Instance dec_entails_L {p s t} : Decidable (p ⊢ℒ s ≡ t). + Proof. + red. eapply check_pres_clause_spec. + Qed. + + Lemma contra_prop A B (decB : Decidable B) : (~ B -> ~ A) -> (A -> B). + Proof. intros he a. destruct (dec B). exact H. specialize (he H). contradiction. Qed. + + Definition satisfiable (s : semilattice) (r : rels) := + exists v, interp_rels (SL := sl s) v r. + *) From a0cc9a482a0b841c8b1b40176fa1a8629aef1c90 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 24 Sep 2025 21:02:11 +0200 Subject: [PATCH 067/164] Minor refactorings --- common/theories/LoopChecking/Common.v | 11 ++++ common/theories/LoopChecking/Deciders.v | 3 +- .../theories/LoopChecking/UnivLoopChecking.v | 63 ++++++++----------- utils/theories/All_Forall.v | 8 +++ 4 files changed, 47 insertions(+), 38 deletions(-) diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v index c2ae1c153..56097c962 100644 --- a/common/theories/LoopChecking/Common.v +++ b/common/theories/LoopChecking/Common.v @@ -392,3 +392,14 @@ Proof. red. lia. Qed. #[export, refine] Instance ge_trans : Transitive Z.ge := _. Proof. red. lia. Qed. +Lemma equivlistA_app_comm {A} (l l' : list A) : + equivlistA Logic.eq (l ++ l') (l' ++ l). +Proof. + intros x. rewrite !InA_In_eq !in_app_iff. firstorder. +Qed. + +Lemma equivlistA_app_cons_comm {A} (x : A) (l l' : list A) : + equivlistA Logic.eq (l ++ x :: l') (x :: l' ++ l). +Proof. + intros y. rewrite !InA_In_eq !in_app_iff //= in_app_iff. firstorder. +Qed. diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 90ec7b1df..e2182b4c5 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -889,7 +889,8 @@ Module Abstract. Definition to_Z_val (v : Level.t -> nat) := fun l => Z.of_nat (v l). - (** Enabled and valid clauses are satisfied by valuation *) + (** Enabled and valid clauses are satisfied by valuation. + *) Lemma valid_clause_model model cl : enabled_clause model cl -> valid_clause model cl -> diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 9d5ff45b4..ce26e70fc 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -149,7 +149,8 @@ Proof. Qed. Lemma from_levelexprzset_spec_2 u : - forall l k, LevelExprSet.In (l, k) (from_levelexprzset u) -> exists z, LevelExprZSet.In (l, z) u /\ k = Z.to_nat z. + forall l k, LevelExprSet.In (l, k) (from_levelexprzset u) -> + exists z, LevelExprZSet.In (l, z) u /\ k = Z.to_nat z. Proof. intros l k. rewrite /from_levelexprzset. @@ -1335,18 +1336,6 @@ End ZUnivConstraint. apply (relations_of_clauses_spec_inv (_, _)); now apply Clauses.union_spec. Qed. - Lemma equivlistA_app_comm {A} (l l' : list A) : - equivlistA Logic.eq (l ++ l') (l' ++ l). - Proof. - intros x. rewrite !InA_In_eq !in_app_iff. firstorder. - Qed. - - Lemma equivlistA_app_cons_comm {A} (x : A) (l l' : list A) : - equivlistA Logic.eq (l ++ x :: l') (x :: l' ++ l). - Proof. - intros y. rewrite !InA_In_eq !in_app_iff //= in_app_iff. firstorder. - Qed. - Lemma entails_L_all_app {x y x' y'} : x ⊩ℒ x' -> y ⊩ℒ y' -> x ++ y ⊩ℒ x' ++ y'. Proof. @@ -1669,9 +1658,6 @@ End ZUnivConstraint. rewrite interp_prems_union //=. Qed. - Lemma prop_dec (b : bool) P : b <-> P -> (b = false <-> ~ P). - Proof. intuition. now subst b. destruct b => //. destruct (H (H0 eq_refl)). Qed. - Definition invalid_cstr v c := let '(l, d, r) := c in match d with @@ -1723,33 +1709,36 @@ End ZUnivConstraint. split; now apply interp_rels_entails_proper. Qed. + Lemma interp_cstr_clauses_sem {c} {s : semilattice} {v : Level.t -> s} : + interp_univ_cstr v c <-> clauses_sem v (LoopCheck.to_clauses (to_constraint c)). + Proof. + rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. + rewrite relation_of_constraint_of_clause. + rewrite /Clauses.ISL.interp_rels Forall_tip. + destruct c as [[l []] r]; cbn => //. + now rewrite interp_prems_union. + Qed. + + Lemma interp_cstrs_clauses_sem {m} {s : semilattice} {v : Level.t -> s} : + interp_univ_cstrs v (constraints m) <-> clauses_sem v (LoopCheck.clauses (model m)). + Proof. + rewrite interp_univ_cstrs_relations. + rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. + now rewrite -[Clauses.relations_of_clauses _]equiv_constraints_clauses. + Qed. + Lemma check_completeness {m c} : check m c <-> (forall (s : semilattice) (v : Level.t -> s), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). Proof. rewrite LoopCheck.check_complete /LoopCheck.valid_entailments. + setoid_rewrite interp_cstrs_clauses_sem. split. - intros hv s v hp. - move: (hv s (sl s) v) => /fwd. - { rewrite interp_univ_cstrs_relations in hp. - rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. - rewrite -[Clauses.relations_of_clauses _]equiv_constraints_clauses. - exact hp. } - rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. - rewrite relation_of_constraint_of_clause. - rewrite /Clauses.ISL.interp_rels => h. depelim h. clear h. - red. red. destruct c as [[l []] r]; cbn in H |- * => //. - red. now rewrite interp_prems_union in H. - - intros hs S SL V hsem. - move: (hs {| carrier := S; sl := SL |} V) => /fwd. - { rewrite interp_univ_cstrs_relations. - rewrite equiv_constraints_clauses. - rewrite -[interp_rels _ _]LoopCheck.Impl.Abstract.interp_rels_clauses_sem. - exact hsem. } - rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. - rewrite relation_of_constraint_of_clause. - rewrite /Clauses.ISL.interp_rels => h. constructor; [|constructor]. - red. red. destruct c as [[l []] r]; cbn in hsem |- * => //. - red. now rewrite interp_prems_union. + move: (hv s (sl s) v hp). + now rewrite interp_cstr_clauses_sem. + - intros hs S SL V hsem. + move: (hs {| carrier := S; sl := SL |} V) => /fwd //. + now rewrite interp_cstr_clauses_sem. Qed. End UnivLoopChecking. diff --git a/utils/theories/All_Forall.v b/utils/theories/All_Forall.v index 483caf4c0..8216465ad 100644 --- a/utils/theories/All_Forall.v +++ b/utils/theories/All_Forall.v @@ -411,6 +411,14 @@ Qed. 4) optionally simplify and call eauto. *) +Lemma Forall_tip {A} {P : A -> Prop} {a : A} : + Forall P [a] <-> P a. +Proof. + split. + - intros h; now depelim h. + - constructor; auto. +Qed. + Lemma Forall_mix {A} (P Q : A -> Prop) : forall l, Forall P l -> Forall Q l -> Forall (fun x => P x /\ Q x) l. Proof. intros l Hl Hq. induction Hl; inv Hq; constructor; auto. From bd7f395c4b370da487f6b322bd83bc14fd53af1a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 25 Sep 2025 09:17:05 +0200 Subject: [PATCH 068/164] Move lemmas to the right place --- .../LoopChecking/HornSemilatticeEquiv.v | 97 ++++++- .../LoopChecking/InitialSemilattice.v | 107 +++++++- .../theories/LoopChecking/OldPresentation.v | 72 +++++ .../theories/LoopChecking/UnivLoopChecking.v | 254 +----------------- 4 files changed, 263 insertions(+), 267 deletions(-) create mode 100644 common/theories/LoopChecking/OldPresentation.v diff --git a/common/theories/LoopChecking/HornSemilatticeEquiv.v b/common/theories/LoopChecking/HornSemilatticeEquiv.v index 3b7a4fb3f..1dbddb5c5 100644 --- a/common/theories/LoopChecking/HornSemilatticeEquiv.v +++ b/common/theories/LoopChecking/HornSemilatticeEquiv.v @@ -455,15 +455,6 @@ Module HornSemilattice (LS : LevelSets). now eapply entails_L_cut. exact H1. Qed. - Lemma entails_L_all_weaken {p q w} : - p ⊩ℒ q -> w ++ p ⊩ℒ q. - Proof. - induction 1; constructor. - eapply entails_L_rels_subset; tea => //. - intros a hin. rewrite in_app_iff. now right. - exact IHForall. - Qed. - Lemma entails_L_all_cut {p q r} : p ⊩ℒ q -> q ++ p ⊢ℒ r -> p ⊢ℒ r. Proof. @@ -491,6 +482,34 @@ Module HornSemilattice (LS : LevelSets). constructor. eapply entails_L_all_one_trans. exact hp. exact ent. exact ih. Qed. + + Instance entails_L_all_preorder : PreOrder entails_L_rels. + Proof. + split. + - red. apply entails_L_all_refl. + - red. intros x y z. apply entails_L_all_trans. + Qed. + + Instance equiv_L_rels_equiv : Equivalence equiv_L_rels. + Proof. + split. + - intros r. split; eapply entails_L_all_refl. + - intros r r' []; split; auto. + - intros r r0 r1 [] []; split; eapply entails_L_all_trans; eauto. + Qed. + + Instance entails_L_all_partial_order : PartialOrder equiv_L_rels entails_L_rels. + Proof. + split; tc; auto. + Qed. + + Instance entails_L_proper_equiv : Proper (equiv_L_rels ==> Logic.eq ==> iff) entails_L. + Proof. + intros r r' h ?? ->. split. + - intros h'. destruct h. eapply entails_L_all_one_trans; tea. + - intros h'. destruct h. eapply entails_L_all_one_trans; tea. + Qed. + Lemma relations_of_clauses_mon {s s'}: s ⊂_clset s' -> incl (relations_of_clauses s) (relations_of_clauses s'). Proof. intros hs. @@ -498,6 +517,22 @@ Module HornSemilattice (LS : LevelSets). apply hs in hin. eapply relations_of_clauses_spec_inv in hin. now cbn in *. Qed. + Lemma relations_of_clauses_eq {s s' : clauses} : + s =_clset s' -> + equivlistA Logic.eq (relations_of_clauses s) (relations_of_clauses s'). + Proof. + intros eq. + red. intros []; rewrite !InA_In_eq. + split. + - apply relations_of_clauses_mon. clsets. + - apply relations_of_clauses_mon. clsets. + Qed. + + Instance relations_of_clauses_proper : Proper (Clauses.Equal ==> equivlistA Logic.eq) relations_of_clauses. + Proof. + intros cls cls' H. now apply relations_of_clauses_eq. + Qed. + Lemma entails_L_clauses_subset {cls cls' r} : entails_L_clauses cls r -> Clauses.Subset cls cls' -> @@ -511,6 +546,23 @@ Module HornSemilattice (LS : LevelSets). now apply relations_of_clauses_mon. Qed. + Lemma entails_L_all_relations_of_clauses {cls cls'} : + cls =_clset cls' -> + relations_of_clauses cls ⊩ℒ relations_of_clauses cls'. + Proof. + intros heq. rewrite (relations_of_clauses_eq heq). + reflexivity. + Qed. + + Lemma entails_L_clauses_subset_all {cls cls'} : + cls ⊂_clset cls' -> + relations_of_clauses cls' ⊩ℒ relations_of_clauses cls. + Proof. + intros heq. + have hm := relations_of_clauses_mon heq. + now eapply entails_L_clauses_incl. + Qed. + Lemma entails_clauses_tauto cls : cls ⊢ℋ cls. Proof. intros cl hin. now apply entails_in. @@ -522,7 +574,7 @@ Module HornSemilattice (LS : LevelSets). apply entails_clauses_tauto. Qed. - Lemma entails_L_relations_of_clauses_le l r : + Lemma entails_L_relations_of_clauses_le_impl l r : relations_of_clauses (l ⋞ r) ⊢ℒ l ≤ r. Proof. eapply completeness_eq. @@ -568,4 +620,29 @@ Module HornSemilattice (LS : LevelSets). now move=> hcls cl /hcls/entails_L_clause_rels. Qed. + + Lemma entails_L_in_cls {prems concl cls} : + Clauses.In (prems, concl) cls -> relations_of_clauses cls ⊢ℒ singleton concl ≤ prems. + Proof. + intros hin. eapply entails_c. + apply relations_of_clauses_spec_inv in hin. now cbn in hin. + Qed. + + Lemma entails_L_relations_of_clauses_le l r : + relations_of_clauses (l ⋞ r) ⊫ℒ [l ≤ r]. + Proof. + split. + - constructor. apply entails_L_relations_of_clauses_le_impl. constructor. + - apply Forall_forall => rel. + move/relations_of_clauses_spec => [] prems [] concl [] hin ->. + unfold rel_le. + eapply clauses_of_le_spec in hin as [k [hin heq]]. noconf heq. + eapply entails_trans with (l ∨ r). 2:{ eapply entails_c. constructor. now constructor. } + apply entails_L_eq_antisym. split. + eapply entails_L_le_join_l. now eapply entails_L_in. + eapply entails_L_le_trans with r. + eapply entails_L_eq_le_1. eapply entails_c; now constructor. + eapply entails_L_le_right. + Qed. + End HornSemilattice. diff --git a/common/theories/LoopChecking/InitialSemilattice.v b/common/theories/LoopChecking/InitialSemilattice.v index d626fd251..9344919f8 100644 --- a/common/theories/LoopChecking/InitialSemilattice.v +++ b/common/theories/LoopChecking/InitialSemilattice.v @@ -70,6 +70,8 @@ Module InitialSemilattice (LS : LevelSets). Definition equiv_L_rels p q := p ⊩ℒ q /\ q ⊩ℒ p. + Infix "⊫ℒ" := equiv_L_rels (no associativity, at level 72) : rel_scope. + Lemma entails_join_congr_all {p} {x x' y y'} : p ⊢ℒ x ≡ x' -> p ⊢ℒ y ≡ y' -> p ⊢ℒ (x ∨ y) ≡ (x' ∨ y'). Proof. @@ -242,6 +244,23 @@ Module InitialSemilattice (LS : LevelSets). induction 1; try solve [econstructor; eauto]. Qed. + Lemma entails_L_c {rs r} : In r rs -> rs ⊢ℒ r. + Proof. destruct r; apply entails_c. Qed. + + Lemma entails_L_clauses_cons {rs r rs'} : + rs ⊢ℒ r -> rs ⊩ℒ rs' -> rs ⊩ℒ r :: rs'. + Proof. intros h h'; now constructor. Qed. + + Lemma entails_L_clauses_incl {rs rs'} : + incl rs rs' -> + rs' ⊩ℒ rs. + Proof. + induction rs in rs' |- *. + - constructor. + - intros i. constructor. destruct a; eapply entails_c. apply i. now constructor. + apply IHrs. intros r hin. apply i. now right. + Qed. + Instance entails_L_proper : Proper (equivlistA Logic.eq ==> Logic.eq ==> iff) entails_L. Proof. intros ?? eq ?? ->. @@ -262,14 +281,34 @@ Module InitialSemilattice (LS : LevelSets). now setoid_rewrite eq. Qed. - Instance entails_L_all_proper : Proper (equivlistA Logic.eq ==> equivlistA Logic.eq ==> iff) entails_L_rels. + Instance Forall_ext_proper {A} : Proper ((Logic.eq ==> iff) ==> equivlistA Logic.eq ==> iff) (@Forall A). + Proof. + intros x y eq ? ? ->. red in eq. + rewrite !Forall_forall. + split; intros hyp ? hin. now rewrite -eq; trea. + now rewrite eq; trea. + Qed. + + Instance entails_L_rels_proper : Proper (equivlistA Logic.eq ==> equivlistA Logic.eq ==> iff) entails_L_rels. + Proof. + intros l l' h ?? h'. unfold entails_L_rels. split; now rewrite h h'. + Qed. + + Instance entails_L_equiv_proper : Proper (equivlistA Logic.eq ==> equivlistA Logic.eq ==> iff) equiv_L_rels. + Proof. + intros l l' h ?? h'. split; split. 1-2:rewrite -h -h'; apply H. + rewrite h h'; apply H. + rewrite h h'; apply H. + Qed. + + + Lemma entails_equiv_cons {rs r rs'} : rs ⊫ℒ r :: rs' <-> rs ⊩ℒ [r] /\ rs ⊩ℒ rs' /\ r :: rs' ⊩ℒ rs. Proof. - intros ?? eq ?? eq'. split. - - unfold entails_L_rels. rewrite eq'. - move/Forall_forall => h. eapply Forall_forall => h'. now rewrite -eq. - - unfold entails_L_rels. rewrite eq'. - move/Forall_forall => h. eapply Forall_forall => h'. now rewrite eq. + - move=> [] h; depelim h. intros hrs. + split. constructor => //. constructor => //. + - move=> [] rsr [] rsr' a. + split => //. constructor => //. now depelim rsr. Qed. Lemma entails_L_le_eq {cls l r} : cls ⊢ℒ l ≤ r -> cls ⊢ℒ l ∨ r ≡ r. @@ -797,4 +836,60 @@ End ForSemilattice. now apply H. now apply IHrs. Qed. + + Open Scope rel_scope. + + Instance interp_rels_entails_proper {S} {SL : Semilattice S Q.t} V : Proper (entails_L_rels ==> impl) (interp_rels V). + Proof. + intros rs rs' hl. + induction rs' in rs, hl |- *. + * constructor. + * intros H0. depelim hl. specialize (IHrs' _ hl H0). constructor => //. + eapply entails_L_valid in H. + now apply (H {| carrier := S; sl := SL |} V H0). + Qed. + + Instance interp_rels_proper {S} {SL : Semilattice S Q.t} V : Proper (equiv_L_rels ==> iff) (interp_rels V). + Proof. + intros rs rs' [hl hr]. + split; now apply interp_rels_entails_proper. + Qed. + + Lemma entails_L_all_weaken {p q w} : + p ⊩ℒ q -> w ++ p ⊩ℒ q. + Proof. + induction 1; constructor. + eapply entails_L_rels_subset; tea => //. + intros a hin. rewrite in_app_iff. now right. + exact IHForall. + Qed. + + Lemma entails_L_all_refl r : r ⊩ℒ r. + Proof. induction r. + - constructor. + - constructor. destruct a; eapply entails_c. now constructor. + now eapply (entails_L_all_weaken (w := [a])). + Qed. + + Lemma entails_L_all_app {x y x' y'} : + x ⊩ℒ x' -> y ⊩ℒ y' -> x ++ y ⊩ℒ x' ++ y'. + Proof. + intros hx hy. + rewrite equivlistA_app_comm. + induction hy. + - rewrite app_nil_r. + now eapply entails_L_all_weaken. + - rewrite equivlistA_app_cons_comm. constructor. + rewrite -equivlistA_app_comm. eapply entails_L_rels_subset; tea. + move=> ?; rewrite in_app_iff; now right. + rewrite (equivlistA_app_comm l x'). exact IHhy. + Qed. + + Lemma entails_L_all_union {x y x' y'} : + x ⊫ℒ x' -> y ⊫ℒ y' -> x ++ y ⊫ℒ x' ++ y'. + Proof. + intros [hx hx'] [hy hy']. + split; now apply entails_L_all_app. + Qed. + End InitialSemilattice. diff --git a/common/theories/LoopChecking/OldPresentation.v b/common/theories/LoopChecking/OldPresentation.v new file mode 100644 index 000000000..c2905faa7 --- /dev/null +++ b/common/theories/LoopChecking/OldPresentation.v @@ -0,0 +1,72 @@ + Record presentation := + { V : LevelSet.t; C : rels }. + + Definition presentation_of cstrs := + {| V := levels_of_z_constraints cstrs; + C := relations_of_constraints cstrs |}. + + + Definition presentation_of_clauses cls := + {| V := Clauses.clauses_levels cls; + C := relations_of_clauses cls |}. + + + Lemma presentation_of_clauses_spec cls prems concl : + Clauses.In (prems, concl) cls -> + In (NES.singleton concl ∨ prems, prems) (C (presentation_of_clauses cls)). + Proof. + rewrite /presentation_of_clauses //=. + move/relations_of_clauses_spec_inv => //=. + Qed. + + (* Import LoopCheck.Impl.I.Model.Model.Clauses.FLS. *) + + Definition presentation_entails cstrs c := + let '(l, d, r) := to_constraint c in + match d with + | ConstraintType.Le => relations_of_constraints (to_z_cstrs cstrs) ⊢ℒ l ≤ r + | ConstraintType.Eq => relations_of_constraints (to_z_cstrs cstrs) ⊢ℒ l ≡ r + end. + + Lemma check_valid_pres m c : + check m c <-> presentation_entails (constraints m) c. + Proof. + rewrite check_valid. + destruct c as [[l []] r]; cbn. + - rewrite completeness_le. + rewrite /entails_cstr /entails_z_cstr. + now rewrite to_clauses_of_z_constraints. + - rewrite completeness_eq_cstrs. + rewrite /entails_cstr /entails_z_cstr. + now rewrite to_clauses_of_z_constraints. + Qed. + Lemma presentation_entails_valid_eq {p l r} : + p ⊢ℒ l ≡ r -> valid_constraint p (l, ConstraintType.Eq, r). + Proof. + move/completeness. + rewrite /valid_relation /valid_constraint /interp_z_cstr //=. + Qed. + + Lemma presentation_entails_valid_le {p l r} : + p ⊢ℒ l ≤ r -> valid_constraint p (l, ConstraintType.Le, r). + Proof. + rewrite /valid_constraint /interp_z_cstr //=. + move/presentation_entails_valid_eq => vc v hc. + specialize (vc v hc). cbn in vc. + rewrite interp_prems_union in vc. apply vc. + Qed. + + Lemma presentation_entails_valid {p c} : + entails_L_cstr p c -> valid_constraint p c. + Proof. + destruct c as [[l []] r]; cbn. + - apply presentation_entails_valid_le. + - apply presentation_entails_valid_eq. + Qed. + + Lemma presentation_entails_satisfies {p cstrs} : + entails_L_cstrs p cstrs -> valid_cstrs p cstrs. + Proof. + intros ha c hin. specialize (ha c hin). + now apply presentation_entails_valid. + Qed. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index ce26e70fc..2a41cb016 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -990,19 +990,6 @@ End ZUnivConstraint. Import ISL. - Record presentation := - { V : LevelSet.t; C : rels }. - - Definition presentation_of cstrs := - {| V := levels_of_z_constraints cstrs; - C := relations_of_constraints cstrs |}. - - - Definition presentation_of_clauses cls := - {| V := Clauses.clauses_levels cls; - C := relations_of_clauses cls |}. - - Lemma entails_clauses_le {cstrs l r} : ZUnivConstraintSet.In (l, ConstraintType.Le, r) cstrs -> of_z_constraints cstrs ⊢a r → l. @@ -1070,17 +1057,6 @@ End ZUnivConstraint. now rewrite /entails_L_clauses Clauses.entails_L_pres_clauses_of_le. Qed. - Lemma presentation_of_clauses_spec cls prems concl : - Clauses.In (prems, concl) cls -> - In (NES.singleton concl ∨ prems, prems) (C (presentation_of_clauses cls)). - Proof. - rewrite /presentation_of_clauses //=. - move/relations_of_clauses_spec_inv => //=. - Qed. - - Infix "⊫ℒ" := equiv_L_rels (no associativity, at level 72) : rel_scope. - Open Scope rel_scope. - Lemma entails_L_clauses_leq_def {p l r} : entails_L_clauses p (l ⋞ r) <-> entails_L_clauses p (l ∨ r ≡ r). Proof. @@ -1089,57 +1065,6 @@ End ZUnivConstraint. now rewrite Clauses.entails_L_pres_clauses_of_le. Qed. - Lemma entails_L_in_cls {prems concl cls} : - Clauses.In (prems, concl) cls -> relations_of_clauses cls ⊢ℒ singleton concl ≤ prems. - Proof. - intros hin. eapply entails_c. - apply relations_of_clauses_spec_inv in hin. now cbn in hin. - Qed. - - Lemma entails_L_relations_of_clauses_le l r : - equiv_L_rels (relations_of_clauses (l ⋞ r)) [l ≤ r]. - Proof. - split. - - constructor. apply entails_L_relations_of_clauses_le. constructor. - - apply Forall_forall => rel. - move/relations_of_clauses_spec => [] prems [] concl [] hin ->. - unfold rel_le. - eapply clauses_of_le_spec in hin as [k [hin heq]]. noconf heq. - eapply entails_trans with (l ∨ r). 2:{ eapply entails_c. constructor. now constructor. } - apply entails_L_eq_antisym. split. - eapply entails_L_le_join_l. now eapply entails_L_in. - eapply entails_L_le_trans with r. - eapply entails_L_eq_le_1. eapply entails_c; now constructor. - eapply entails_L_le_right. - Qed. - - Lemma entails_L_all_refl r : r ⊩ℒ r. - Proof. induction r. - - constructor. - - constructor. destruct a; eapply entails_c. now constructor. - now eapply (entails_L_all_weaken (w := [a])). - Qed. - - Instance entails_L_all_preorder : PreOrder entails_L_rels. - Proof. - split. - - red. apply entails_L_all_refl. - - red. intros x y z. apply entails_L_all_trans. - Qed. - - Instance equiv_L_rels_equiv : Equivalence equiv_L_rels. - Proof. - split. - - intros r. split; eapply entails_L_all_refl. - - intros r r' []; split; auto. - - intros r r0 r1 [] []; split; eapply entails_L_all_trans; eauto. - Qed. - - Instance entails_L_all_partial_order : PartialOrder equiv_L_rels entails_L_rels. - Proof. - split; tc; auto. - Qed. - Lemma equiv_L_rels_eq {l r} : equiv_L_rels [l ≡ r] (relations_of_clauses (clauses_of_le l r) ++ relations_of_clauses (clauses_of_le r l)). Proof. rewrite /clauses_of_eq. split. @@ -1168,13 +1093,6 @@ End ZUnivConstraint. red. intros r' hin. rewrite in_app_iff. now right. Qed. - Instance entails_L_proper_equiv : Proper (equiv_L_rels ==> Logic.eq ==> iff) entails_L. - Proof. - intros r r' h ?? ->. split. - - intros h'. destruct h. eapply entails_L_all_one_trans; tea. - - intros h'. destruct h. eapply entails_L_all_one_trans; tea. - Qed. - Lemma entails_L_relations_of_clauses_eq l r : equiv_L_rels (relations_of_clauses (l ≡ r)) [l ≡ r]. @@ -1207,65 +1125,12 @@ End ZUnivConstraint. now eapply entails_L_in_cls. Qed. -(* entails_L_to_clauses_pres_all *) Lemma relation_of_constraint_of_clause cstr : relations_of_clauses (LoopCheck.to_clauses cstr) ⊫ℒ [relation_of_constraint cstr]. Proof. - split. - - constructor. - destruct cstr as [[l []] r]. cbn. - apply Clauses.entails_L_relations_of_clauses_le. - apply Clauses.entails_L_relations_of_clauses_eq. - constructor. - - red. apply Forall_forall => [] [] l r /relations_of_clauses_spec [] prems [] concl [] hin [=] -> ->. - now apply entails_to_clauses. - Qed. - - Lemma entails_equiv_cons {rs r rs'} : rs ⊫ℒ r :: rs' <-> rs ⊩ℒ [r] /\ rs ⊩ℒ rs' /\ r :: rs' ⊩ℒ rs. - Proof. - split. - - move=> [] h; depelim h. intros hrs. - split. constructor => //. constructor => //. - - move=> [] rsr [] rsr' a. - split => //. constructor => //. now depelim rsr. - Qed. - - Lemma relations_of_clauses_eq {s s' : clauses} : - s =_clset s' -> - equivlistA Logic.eq (Clauses.relations_of_clauses s) (Clauses.relations_of_clauses s'). - Proof. - intros eq. - red. intros []; rewrite !InA_In_eq. - split. - - apply relations_of_clauses_mon. clsets. - - apply relations_of_clauses_mon. clsets. - Qed. - - Lemma entails_L_all_relations_of_clauses {cls cls'} : - cls =_clset cls' -> - relations_of_clauses cls ⊩ℒ relations_of_clauses cls'. - Proof. - intros heq. rewrite (relations_of_clauses_eq heq). - reflexivity. - Qed. - - Lemma entails_L_clauses_incl {rs rs'} : - incl rs rs' -> - rs' ⊩ℒ rs. - Proof. - induction rs in rs' |- *. - - constructor. - - intros i. constructor. destruct a; eapply entails_c. apply i. now constructor. - apply IHrs. intros r hin. apply i. now right. - Qed. - - Lemma entails_L_clauses_subset_all {cls cls'} : - cls ⊂_clset cls' -> - relations_of_clauses cls' ⊩ℒ relations_of_clauses cls. - Proof. - intros heq. - have hm := relations_of_clauses_mon heq. - now eapply entails_L_clauses_incl. + destruct cstr as [[l []] r]. cbn. + apply entails_L_relations_of_clauses_le. + apply entails_L_relations_of_clauses_eq. Qed. Lemma of_z_constraints_subset {cstrs cstrs'} : @@ -1276,13 +1141,6 @@ End ZUnivConstraint. rewrite of_z_constraints_spec. exists cstr. split => //. now apply hsub. Qed. - Lemma entails_L_c {rs r} : In r rs -> rs ⊢ℒ r. - Proof. destruct r; apply entails_c. Qed. - - Lemma entails_L_clauses_cons {rs r rs'} : - rs ⊢ℒ r -> rs ⊩ℒ rs' -> rs ⊩ℒ r :: rs'. - Proof. intros h h'; now constructor. Qed. - Lemma of_z_constraints_add x s : of_z_constraints (ZUnivConstraintSet.add x s) =_clset Clauses.union (LoopCheck.to_clauses x) (of_z_constraints s). Proof. @@ -1306,23 +1164,6 @@ End ZUnivConstraint. rewrite ZUnivConstraintSet.add_spec; now right. Qed. - Instance entails_L_rels_proper : Proper (equivlistA Logic.eq ==> equivlistA Logic.eq ==> iff) entails_L_rels. - Proof. - intros l l' h ?? h'. split; now rewrite h h'. - Qed. - - Instance entails_L_equiv_proper : Proper (equivlistA Logic.eq ==> equivlistA Logic.eq ==> iff) equiv_L_rels. - Proof. - intros l l' h ?? h'. split; split. 1-2:rewrite -h -h'; apply H. - rewrite h h'; apply H. - rewrite h h'; apply H. - Qed. - - Instance relations_of_clauses_proper : Proper (Clauses.Equal ==> equivlistA Logic.eq) relations_of_clauses. - Proof. - intros cls cls' H. split; rewrite !InA_In_eq. - all:eapply relations_of_clauses_mon; now rewrite H. - Qed. Lemma relations_of_clauses_union {cls cls'} : equivlistA Logic.eq (relations_of_clauses (Clauses.union cls cls')) @@ -1336,27 +1177,6 @@ End ZUnivConstraint. apply (relations_of_clauses_spec_inv (_, _)); now apply Clauses.union_spec. Qed. - Lemma entails_L_all_app {x y x' y'} : - x ⊩ℒ x' -> y ⊩ℒ y' -> x ++ y ⊩ℒ x' ++ y'. - Proof. - intros hx hy. - rewrite equivlistA_app_comm. - induction hy. - - rewrite app_nil_r. - now eapply entails_L_all_weaken. - - rewrite equivlistA_app_cons_comm. constructor. - rewrite -equivlistA_app_comm. eapply entails_L_rels_subset; tea. - move=> ?; rewrite in_app_iff; now right. - rewrite (equivlistA_app_comm l x'). exact IHhy. - Qed. - - Lemma entails_L_all_union {x y x' y'} : - x ⊫ℒ x' -> y ⊫ℒ y' -> x ++ y ⊫ℒ x' ++ y'. - Proof. - intros [hx hx'] [hy hy']. - split; now apply entails_L_all_app. - Qed. - Lemma relations_of_clauses_constraints_add {x s} : (relation_of_constraint x :: relations_of_clauses (of_z_constraints s)) ⊫ℒ (relations_of_clauses (of_z_constraints (ZUnivConstraintSet.add x s))). @@ -1537,62 +1357,10 @@ End ZUnivConstraint. - move/entails_ℋ_entails_L. apply entails_L_clauses_le. Qed. - (* Import LoopCheck.Impl.I.Model.Model.Clauses.FLS. *) - - Definition presentation_entails cstrs c := - let '(l, d, r) := to_constraint c in - match d with - | ConstraintType.Le => relations_of_constraints (to_z_cstrs cstrs) ⊢ℒ l ≤ r - | ConstraintType.Eq => relations_of_constraints (to_z_cstrs cstrs) ⊢ℒ l ≡ r - end. - - Lemma check_valid_pres m c : - check m c <-> presentation_entails (constraints m) c. - Proof. - rewrite check_valid. - destruct c as [[l []] r]; cbn. - - rewrite completeness_le. - rewrite /entails_cstr /entails_z_cstr. - now rewrite to_clauses_of_z_constraints. - - rewrite completeness_eq_cstrs. - rewrite /entails_cstr /entails_z_cstr. - now rewrite to_clauses_of_z_constraints. - Qed. Import Semilattice. Import ISL. - Lemma presentation_entails_valid_eq {p l r} : - p ⊢ℒ l ≡ r -> valid_constraint p (l, ConstraintType.Eq, r). - Proof. - move/completeness. - rewrite /valid_relation /valid_constraint /interp_z_cstr //=. - Qed. - - Lemma presentation_entails_valid_le {p l r} : - p ⊢ℒ l ≤ r -> valid_constraint p (l, ConstraintType.Le, r). - Proof. - rewrite /valid_constraint /interp_z_cstr //=. - move/presentation_entails_valid_eq => vc v hc. - specialize (vc v hc). cbn in vc. - rewrite interp_prems_union in vc. apply vc. - Qed. - - Lemma presentation_entails_valid {p c} : - entails_L_cstr p c -> valid_constraint p c. - Proof. - destruct c as [[l []] r]; cbn. - - apply presentation_entails_valid_le. - - apply presentation_entails_valid_eq. - Qed. - - Lemma presentation_entails_satisfies {p cstrs} : - entails_L_cstrs p cstrs -> valid_cstrs p cstrs. - Proof. - intros ha c hin. specialize (ha c hin). - now apply presentation_entails_valid. - Qed. - Definition model_Z_val m := (to_Z_val (LoopCheck.valuation (model m))). Lemma interp_rels_of_m m : interp_rels (model_Z_val m) (relations_of_constraints (to_z_cstrs (constraints m))). @@ -1693,22 +1461,6 @@ End ZUnivConstraint. - now move/repr_inv. Qed. - Instance interp_rels_entails_proper {S} {SL : Semilattice S Q.t} V : Proper (entails_L_rels ==> impl) (interp_rels V). - Proof. - intros rs rs' hl. - induction rs' in rs, hl |- *. - * constructor. - * intros H0. depelim hl. specialize (IHrs' _ hl H0). constructor => //. - eapply entails_L_valid in H. - now apply (H {| carrier := S; sl := SL |} V H0). - Qed. - - Instance interp_rels_proper {S} {SL : Semilattice S Q.t} V : Proper (equiv_L_rels ==> iff) (interp_rels V). - Proof. - intros rs rs' [hl hr]. - split; now apply interp_rels_entails_proper. - Qed. - Lemma interp_cstr_clauses_sem {c} {s : semilattice} {v : Level.t -> s} : interp_univ_cstr v c <-> clauses_sem v (LoopCheck.to_clauses (to_constraint c)). Proof. From d8eec9c97fad95fe233778e008008db6d3663d10 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 25 Sep 2025 11:14:18 +0200 Subject: [PATCH 069/164] More refactorings/cleanups --- common/theories/LoopChecking/Deciders.v | 6 - common/theories/LoopChecking/HornClauses.v | 30 ++ .../LoopChecking/HornSemilatticeEquiv.v | 12 + .../LoopChecking/InitialSemilattice.v | 7 + common/theories/LoopChecking/Interfaces.v | 6 + .../theories/LoopChecking/OldPresentation.v | 194 ++++++++ .../theories/LoopChecking/UnivLoopChecking.v | 433 ++++-------------- 7 files changed, 336 insertions(+), 352 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index e2182b4c5..e3a4e20b2 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -474,12 +474,6 @@ Proof. forward ho by now exists v. now right. Qed. -Lemma in_levels le prems : LevelExprSet.In le prems -> LevelSet.In le.1 (levels prems). -Proof. - destruct le. intros hin. - apply levels_spec. now exists z. -Qed. - Lemma min_model_map_enabled m cls cls' : enabled_clauses m cls -> enabled_clauses (min_model_map m cls') (Clauses.union cls cls'). diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 2b6dd7941..625f1b7ba 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -1732,6 +1732,36 @@ Module Clauses (LS : LevelSets). rewrite ih. right; firstorder. Qed. + Lemma clauses_of_le_nempty l r : ~ Clauses.Empty (clauses_of_le l r). + Proof. + intros he. red in he. eapply he. + rewrite !clauses_of_le_spec. + exists (NES.choose_prems l). split; trea. + apply NES.choose_prems_spec. + Qed. + + Import NES. + Lemma in_clause_levels_of_le lev l r : LevelSet.In lev (clauses_levels (clauses_of_le l r)) <-> + LevelSet.In lev (levels l) \/ LevelSet.In lev (levels r). + Proof. + rewrite clauses_levels_spec. + setoid_rewrite clauses_of_le_spec. + split. + - intros [cl [hex hin]]. + apply clause_levels_spec in hin. + destruct hex as [le [inl ->]]. cbn in *. destruct hin; auto. subst. + left. now apply in_levels. + - move=> [] hin. + * eapply levels_spec in hin as [k hin]. + exists (r, (lev, k)). split => //. exists (lev, k). split => //. + apply clause_levels_spec. now right. + * eapply levels_spec in hin as [k hin]. + exists (r, choose_prems l). split => //. exists (choose_prems l). split => //. + apply choose_prems_spec. + apply clause_levels_spec. left. + apply levels_spec. now exists k. + Qed. + Lemma to_entails_all {cls s t} : cls ⊢ℋ s ⋞ t <-> cls ⊢a t → s. Proof. diff --git a/common/theories/LoopChecking/HornSemilatticeEquiv.v b/common/theories/LoopChecking/HornSemilatticeEquiv.v index 1dbddb5c5..d40925c88 100644 --- a/common/theories/LoopChecking/HornSemilatticeEquiv.v +++ b/common/theories/LoopChecking/HornSemilatticeEquiv.v @@ -84,6 +84,18 @@ Module HornSemilattice (LS : LevelSets). * move: (ih _ ina) => insing. now right. Qed. + Lemma relations_of_clauses_union {cls cls'} : + equivlistA Logic.eq (relations_of_clauses (Clauses.union cls cls')) + (relations_of_clauses cls ++ relations_of_clauses cls'). + Proof. + intros eq. split; rewrite !InA_In_eq; rewrite in_app_iff. + - move/relations_of_clauses_spec => -[] prems [] concl [] hin ->. + eapply Clauses.union_spec in hin as [hin|hin]; [left|right]; + now apply (relations_of_clauses_spec_inv (_, _)). + - move=> [] /relations_of_clauses_spec => -[] prems [] concl [] hin ->; + apply (relations_of_clauses_spec_inv (_, _)); now apply Clauses.union_spec. + Qed. + Definition entails_L_clause p cl := p ⊢ℒ singleton (concl cl) ≤ premise cl. diff --git a/common/theories/LoopChecking/InitialSemilattice.v b/common/theories/LoopChecking/InitialSemilattice.v index 9344919f8..d802de40c 100644 --- a/common/theories/LoopChecking/InitialSemilattice.v +++ b/common/theories/LoopChecking/InitialSemilattice.v @@ -855,6 +855,13 @@ End ForSemilattice. split; now apply interp_rels_entails_proper. Qed. + Lemma entails_L_all_tip {rs r} : rs ⊩ℒ [r] <-> rs ⊢ℒ r. + Proof. + split; intros h. + - now depelim h. + - constructor => //. + Qed. + Lemma entails_L_all_weaken {p q w} : p ⊩ℒ q -> w ++ p ⊩ℒ q. Proof. diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 9322784a9..02f559e77 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -130,6 +130,12 @@ Qed. Lemma in_singleton l : LevelSet.In l (LevelSet.singleton l). Proof. lsets. Qed. +Lemma in_levels le prems : LevelExprSet.In le prems -> LevelSet.In le.1 (levels prems). +Proof. + destruct le. intros hin. + apply levels_spec. now exists z. +Qed. + Lemma not_in_union_inv l ls ls' : ~ LevelSet.In l (LevelSet.union ls ls') -> ~ LevelSet.In l ls /\ ~ LevelSet.In l ls'. diff --git a/common/theories/LoopChecking/OldPresentation.v b/common/theories/LoopChecking/OldPresentation.v index c2905faa7..5965e5538 100644 --- a/common/theories/LoopChecking/OldPresentation.v +++ b/common/theories/LoopChecking/OldPresentation.v @@ -11,6 +11,33 @@ C := relations_of_clauses cls |}. + Definition entails_cstr cstrs c := + entails_clauses (to_clauses cstrs) (LoopCheck.to_clauses (to_constraint c)). + + Definition entails_z_cstr cstrs c := + entails_clauses (of_z_constraints cstrs) (LoopCheck.to_clauses c). + + Definition entails_cstrs cstrs cstrs' := + entails_clauses (of_z_constraints cstrs) (of_z_constraints cstrs'). + + + Lemma check_valid m c : + check m c <-> entails_cstr (constraints m) c. + Proof. + rewrite /check LoopCheck.check_spec. + rewrite /entails_clauses. + enough ((LoopCheck.clauses (model m)) =_clset (to_clauses (constraints m))). + { split; intros ? ?. + move/H0. now rewrite H. + move/H0. now rewrite H. } + intros cl. + rewrite to_clauses_spec. + split. + - now move/(repr_constraints_inv m). + - intros [cstr [hin incl]]. + eapply (repr_constraints m); tea. + Qed. + Lemma presentation_of_clauses_spec cls prems concl : Clauses.In (prems, concl) cls -> In (NES.singleton concl ∨ prems, prems) (C (presentation_of_clauses cls)). @@ -70,3 +97,170 @@ intros ha c hin. specialize (ha c hin). now apply presentation_entails_valid. Qed. + + Lemma completeness_eq_cstrs cstrs s t : + relations_of_constraints cstrs ⊢ℒ s ≡ t <-> + entails_z_cstr cstrs (s, ConstraintType.Eq, t). + Proof. + unfold entails_z_cstr. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -LoopCheck.Impl.Abstract.entails_L_rels_entails_L_clauses. + rewrite relation_of_constraint_of_clause //=. + now rewrite rels_of_z_constraints_spec entails_L_all_tip. + Qed. + + Lemma completeness_le cstrs s t : + relations_of_constraints cstrs ⊢ℒ s ≤ t <-> + entails_z_cstr cstrs (s, ConstraintType.Le, t). + Proof. + unfold entails_z_cstr. + split. + - move/completeness_eq_cstrs. cbn. + intros h; red in h. cbn in h. + eapply Theory.le_spec. now rewrite /Clauses.le. + - move/entails_ℋ_entails_L. apply entails_L_clauses_le. + Qed. + + + + Lemma entails_clauses_le {cstrs l r} : + ZUnivConstraintSet.In (l, ConstraintType.Le, r) cstrs -> + of_z_constraints cstrs ⊢a r → l. + Proof. + intros hin l' cl. + eapply in_pred_closure_entails_clause, incls0. + rewrite of_z_constraints_spec. eexists; split; tea. + now apply in_clause_of_le. + Qed. + + Lemma entails_clauses_eq_left {cstrs l r} : + ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> + of_z_constraints cstrs ⊢a r → l. + Proof. + intros hin l' cl. + eapply in_pred_closure_entails_clause, incls0. + rewrite of_z_constraints_spec. eexists; split; tea. + rewrite LoopCheck.to_clauses_spec. left. exists l'. split => //. + Qed. + + Lemma entails_clauses_eq_right {cstrs l r} : + ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> + of_z_constraints cstrs ⊢a l → r. + Proof. + intros hin l' cl. + eapply in_pred_closure_entails_clause, incls0. + rewrite of_z_constraints_spec. eexists; split; tea. + rewrite LoopCheck.to_clauses_spec. right. exists l'. split => //. + Qed. + + Lemma entails_clauses_eq_cstr {cstrs l r} : + ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> + of_z_constraints cstrs ⊢ℋ l ≡ r. + Proof. + intros hin. + apply Theory.eq_antisym. + split. + - rewrite to_entails_all. now apply entails_clauses_eq_left. + - rewrite to_entails_all. now apply entails_clauses_eq_right. + Qed. + + Lemma entails_clauses_le_cstr {cstrs l r} : + ZUnivConstraintSet.In (l, ConstraintType.Le, r) cstrs -> + of_z_constraints cstrs ⊢ℋ l ⋞ r. + Proof. + intros hin. + rewrite to_entails_all. now apply entails_clauses_le. + Qed. + + Lemma entails_L_clauses_eq_cstr {cstrs l r} : + ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> + relations_of_clauses (of_z_constraints cstrs) ⊢ℒ l ≡ r. + Proof. + move/entails_clauses_eq_cstr. + rewrite -entails_L_entails_ℋ_equiv. + now rewrite -(entails_L_clauses_entails_L_relations _ (l, r)). + Qed. + + Lemma entails_L_clauses_le_cstr {cstrs l r} : + ZUnivConstraintSet.In (l, ConstraintType.Le, r) cstrs -> + relations_of_clauses (of_z_constraints cstrs) ⊢ℒ l ≤ r. + Proof. + move/entails_clauses_le_cstr. + rewrite -entails_L_entails_ℋ_equiv. + now rewrite /entails_L_clauses Clauses.entails_L_pres_clauses_of_le. + Qed. + + Lemma entails_L_clauses_leq_def {p l r} : + entails_L_clauses p (l ⋞ r) <-> entails_L_clauses p (l ∨ r ≡ r). + Proof. + rewrite /entails_L_clauses. + rewrite entails_L_pres_clauses_of_relations_eq. + now rewrite Clauses.entails_L_pres_clauses_of_le. + Qed. + + Lemma entails_to_clauses {prems concl cstr} : + Clauses.In (prems, concl) (LoopCheck.to_clauses cstr) -> + [relation_of_constraint cstr] ⊢ℒ (singleton concl ≤ prems). + Proof. + destruct cstr as [[l []] r]. + - intros hin. cbn -[le]. + have en := entails_L_relations_of_clauses_le l r. + setoid_rewrite <- en. cbn in hin. + now eapply entails_L_in_cls. + - intros hin; cbn in hin |- *. + rewrite -entails_L_relations_of_clauses_eq. + now eapply entails_L_in_cls. + Qed. + + Lemma entails_L_clauses_all {cstrs s t} : + (relations_of_clauses (of_z_constraints cstrs)) ⊢ℒ s ≡ t <-> + (relations_of_constraints cstrs) ⊢ℒ s ≡ t. + Proof. + now rewrite rels_of_z_constraints_spec. + Qed. + + Lemma entails_L_clauses_le {cstrs s t} : + entails_L_pres_clauses (relations_of_clauses (of_z_constraints cstrs)) (s ⋞ t) -> + relations_of_constraints cstrs ⊢ℒ s ≤ t. + Proof. + intros hf. do 2 red in hf. rw_in clauses_of_le_spec hf. + eapply entails_L_split. + move=> le hin. + move: (hf (t, le)) => /fwd. + { exists le; split => //. } + move=> h; red in h. cbn in h. + now eapply entails_L_clauses_all in h. + Qed. + + Lemma entails_L_clauses_of_eq {cstrs s t} : + entails_L_pres_clauses (relations_of_clauses (of_z_constraints cstrs)) (s ≡ t) -> + relations_of_constraints cstrs ⊢ℒ s ≡ t. + Proof. + intros hf. do 2 red in hf. + eapply entails_L_eq_antisym. split. + all: apply entails_L_clauses_le. + - intros cl hin; red. eapply hf. + rewrite /clauses_of_eq. clsets. + - intros cl hin; red. eapply hf. + rewrite /clauses_of_eq. clsets. + Qed. + + + Definition entails_L_cstr p c := + let '(l, d, r) := c in + match d with + | ConstraintType.Le => p ⊢ℒ l ≤ r + | ConstraintType.Eq => p ⊢ℒ l ≡ r + end. + + Lemma entails_L_clauses_cstr {cstrs c} : + entails_L_clauses (of_z_constraints cstrs) (LoopCheck.to_clauses c) -> + entails_L_cstr (relations_of_constraints cstrs) c. + Proof. + destruct c as [[l []] r]. + - cbn. apply entails_L_clauses_le. + - cbn. apply entails_L_clauses_of_eq. + Qed. + + Definition entails_L_cstrs p cstrs := + ZUnivConstraintSet.For_all (entails_L_cstr p) cstrs. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 2a41cb016..a02b5bac3 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -313,6 +313,57 @@ End ZUnivConstraint. + right. exists cstr. split => //. Qed. + Definition to_z_cstrs cstrs := + UnivConstraintSet.fold (fun c acc => ZUnivConstraintSet.add (to_constraint c) acc) + cstrs ZUnivConstraintSet.empty. + + Lemma to_z_cstrs_spec_1 {cstrs} : + forall c, UnivConstraintSet.In c cstrs -> + (exists cstrz, ZUnivConstraintSet.In cstrz (to_z_cstrs cstrs) /\ + cstrz = to_constraint c). + Proof. + rewrite /to_z_cstrs. + eapply UnivConstraintSetProp.fold_rec. + - now move=> s' he c /he. + - intros x a s' s'' hin hnin hadd h cl. + rw ZUnivConstraintSet.add_spec => /hadd []. + * intros ->. eexists; split => //. now left. + * move/h => [cstr [hin' incl]]. subst cstr. + exists (to_constraint cl). firstorder. + Qed. + + Lemma to_z_cstrs_spec_2 {cstrs} : + forall c, ZUnivConstraintSet.In c (to_z_cstrs cstrs) -> + (exists cstr, UnivConstraintSet.In cstr cstrs /\ + c = to_constraint cstr). + Proof. + rewrite /to_z_cstrs. + eapply UnivConstraintSetProp.fold_rec. + - move=> s' he c. zucsets. + - intros x a s' s'' hin hnin hadd h c. + rewrite ZUnivConstraintSet.add_spec => -[]. + * intros ->. eexists; split => //. apply hadd. now left. + * move/h => [cstr [hin' incl]]. subst c. + exists cstr. firstorder. + Qed. + + Lemma to_clauses_of_z_constraints {cstrs} : + to_clauses cstrs =_clset of_z_constraints (to_z_cstrs cstrs). + Proof. + intros l. + rewrite to_clauses_spec of_z_constraints_spec. + split. + - intros [cstr [hin hin']]. + exists (to_constraint cstr). split. + apply to_z_cstrs_spec_1 in hin as [cstrz []]. + now subst cstrz. + assumption. + - intros [cstr [hin hin']]. + apply to_z_cstrs_spec_2 in hin as [cstr' [hin ->]]. + exists cstr'. split => //. + Qed. + + Module Clauses := LoopCheck.Impl.I.Model.Model.Clauses.Clauses. Record univ_model := { @@ -383,23 +434,6 @@ End ZUnivConstraint. rewrite Nat2Z.id //. Qed. - Lemma clauses_of_le_nempty l r : ~ Clauses.Empty (clauses_of_le l r). - Proof. - intros he. red in he. eapply he. - rewrite !clauses_of_le_spec. - exists (choose_prems l). split; trea. - apply choose_prems_spec. - Qed. - - Lemma to_clauses_ne c : ~ Clauses.Empty (LoopCheck.to_clauses c). - Proof. - intros he. red in he. destruct c as [[l []] r]; revgoals. - - eapply he. apply LoopCheck.to_clauses_spec. - right. exists (choose_prems r). split; trea. apply choose_prems_spec. - - eapply he. apply LoopCheck.to_clauses_spec. - exists (choose_prems l). split; trea. apply choose_prems_spec. - Qed. - Equations? init_model : univ_model := init_model := {| model := LoopCheck.init_model; constraints := UnivConstraintSet.empty |}. @@ -483,27 +517,6 @@ End ZUnivConstraint. rewrite UnivConstraintSet.add_spec. now left. Qed. - Lemma in_clause_levels_of_le lev l r : LevelSet.In lev (clauses_levels (clauses_of_le l r)) <-> - LevelSet.In lev (levels l) \/ LevelSet.In lev (levels r). - Proof. - rewrite clauses_levels_spec. - setoid_rewrite clauses_of_le_spec. - split. - - intros [cl [hex hin]]. - apply clause_levels_spec in hin. - destruct hex as [le [inl ->]]. cbn in *. destruct hin; auto. subst. - left. now apply LoopCheck.Impl.in_levels. - - move=> [] hin. - * eapply levels_spec in hin as [k hin]. - exists (r, (lev, k)). split => //. exists (lev, k). split => //. - apply clause_levels_spec. now right. - * eapply levels_spec in hin as [k hin]. - exists (r, choose_prems l). split => //. exists (choose_prems l). split => //. - apply choose_prems_spec. - apply clause_levels_spec. left. - apply levels_spec. now exists k. - Qed. - Lemma clauses_levels_union cls cls' : clauses_levels (Clauses.union cls cls') =_lset LevelSet.union (clauses_levels cls) (clauses_levels cls'). Proof. @@ -887,66 +900,6 @@ End ZUnivConstraint. rewrite !to_of_valuation_univ. lsets. lsets. cbn; lia. Qed. - Definition entails_cstr cstrs c := - entails_clauses (to_clauses cstrs) (LoopCheck.to_clauses (to_constraint c)). - - Definition entails_z_cstr cstrs c := - entails_clauses (of_z_constraints cstrs) (LoopCheck.to_clauses c). - - Definition entails_cstrs cstrs cstrs' := - entails_clauses (of_z_constraints cstrs) (of_z_constraints cstrs'). - - Definition to_z_cstrs cstrs := - UnivConstraintSet.fold (fun c acc => ZUnivConstraintSet.add (to_constraint c) acc) - cstrs ZUnivConstraintSet.empty. - - Lemma to_z_cstrs_spec_1 {cstrs} : - forall c, UnivConstraintSet.In c cstrs -> - (exists cstrz, ZUnivConstraintSet.In cstrz (to_z_cstrs cstrs) /\ - cstrz = to_constraint c). - Proof. - rewrite /to_z_cstrs. - eapply UnivConstraintSetProp.fold_rec. - - now move=> s' he c /he. - - intros x a s' s'' hin hnin hadd h cl. - rw ZUnivConstraintSet.add_spec => /hadd []. - * intros ->. eexists; split => //. now left. - * move/h => [cstr [hin' incl]]. subst cstr. - exists (to_constraint cl). firstorder. - Qed. - - Lemma to_z_cstrs_spec_2 {cstrs} : - forall c, ZUnivConstraintSet.In c (to_z_cstrs cstrs) -> - (exists cstr, UnivConstraintSet.In cstr cstrs /\ - c = to_constraint cstr). - Proof. - rewrite /to_z_cstrs. - eapply UnivConstraintSetProp.fold_rec. - - move=> s' he c. zucsets. - - intros x a s' s'' hin hnin hadd h c. - rewrite ZUnivConstraintSet.add_spec => -[]. - * intros ->. eexists; split => //. apply hadd. now left. - * move/h => [cstr [hin' incl]]. subst c. - exists cstr. firstorder. - Qed. - - Lemma check_valid m c : - check m c <-> entails_cstr (constraints m) c. - Proof. - rewrite /check LoopCheck.check_spec. - rewrite /entails_clauses. - enough ((LoopCheck.clauses (model m)) =_clset (to_clauses (constraints m))). - { split; intros ? ?. - move/H0. now rewrite H. - move/H0. now rewrite H. } - intros cl. - rewrite to_clauses_spec. - split. - - now move/(repr_constraints_inv m). - - intros [cstr [hin incl]]. - eapply (repr_constraints m); tea. - Qed. - Lemma val_respects cls v : @respects _ _ Z _ (horn_semi cls) _ Zsemilattice (fun u => interp_prems v u). Proof. split; cbn. @@ -990,82 +943,8 @@ End ZUnivConstraint. Import ISL. - Lemma entails_clauses_le {cstrs l r} : - ZUnivConstraintSet.In (l, ConstraintType.Le, r) cstrs -> - of_z_constraints cstrs ⊢a r → l. - Proof. - intros hin l' cl. - eapply in_pred_closure_entails_clause, incls0. - rewrite of_z_constraints_spec. eexists; split; tea. - now apply in_clause_of_le. - Qed. - - Lemma entails_clauses_eq_left {cstrs l r} : - ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> - of_z_constraints cstrs ⊢a r → l. - Proof. - intros hin l' cl. - eapply in_pred_closure_entails_clause, incls0. - rewrite of_z_constraints_spec. eexists; split; tea. - rewrite LoopCheck.to_clauses_spec. left. exists l'. split => //. - Qed. - - Lemma entails_clauses_eq_right {cstrs l r} : - ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> - of_z_constraints cstrs ⊢a l → r. - Proof. - intros hin l' cl. - eapply in_pred_closure_entails_clause, incls0. - rewrite of_z_constraints_spec. eexists; split; tea. - rewrite LoopCheck.to_clauses_spec. right. exists l'. split => //. - Qed. - - Lemma entails_clauses_eq_cstr {cstrs l r} : - ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> - of_z_constraints cstrs ⊢ℋ l ≡ r. - Proof. - intros hin. - apply Theory.eq_antisym. - split. - - rewrite to_entails_all. now apply entails_clauses_eq_left. - - rewrite to_entails_all. now apply entails_clauses_eq_right. - Qed. - - Lemma entails_clauses_le_cstr {cstrs l r} : - ZUnivConstraintSet.In (l, ConstraintType.Le, r) cstrs -> - of_z_constraints cstrs ⊢ℋ l ⋞ r. - Proof. - intros hin. - rewrite to_entails_all. now apply entails_clauses_le. - Qed. - - Lemma entails_L_clauses_eq_cstr {cstrs l r} : - ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> - relations_of_clauses (of_z_constraints cstrs) ⊢ℒ l ≡ r. - Proof. - move/entails_clauses_eq_cstr. - rewrite -entails_L_entails_ℋ_equiv. - now rewrite -(entails_L_clauses_entails_L_relations _ (l, r)). - Qed. - - Lemma entails_L_clauses_le_cstr {cstrs l r} : - ZUnivConstraintSet.In (l, ConstraintType.Le, r) cstrs -> - relations_of_clauses (of_z_constraints cstrs) ⊢ℒ l ≤ r. - Proof. - move/entails_clauses_le_cstr. - rewrite -entails_L_entails_ℋ_equiv. - now rewrite /entails_L_clauses Clauses.entails_L_pres_clauses_of_le. - Qed. - - Lemma entails_L_clauses_leq_def {p l r} : - entails_L_clauses p (l ⋞ r) <-> entails_L_clauses p (l ∨ r ≡ r). - Proof. - rewrite /entails_L_clauses. - rewrite entails_L_pres_clauses_of_relations_eq. - now rewrite Clauses.entails_L_pres_clauses_of_le. - Qed. - - Lemma equiv_L_rels_eq {l r} : equiv_L_rels [l ≡ r] (relations_of_clauses (clauses_of_le l r) ++ relations_of_clauses (clauses_of_le r l)). + Lemma equiv_L_rels_eq {l r} : + [l ≡ r] ⊫ℒ relations_of_clauses (clauses_of_le l r) ++ relations_of_clauses (clauses_of_le r l). Proof. rewrite /clauses_of_eq. split. - apply app_Forall. @@ -1093,9 +972,8 @@ End ZUnivConstraint. red. intros r' hin. rewrite in_app_iff. now right. Qed. - Lemma entails_L_relations_of_clauses_eq l r : - equiv_L_rels (relations_of_clauses (l ≡ r)) [l ≡ r]. + relations_of_clauses (l ≡ r) ⊫ℒ [l ≡ r]. Proof. split. - constructor. apply entails_L_relations_of_clauses_eq. constructor. @@ -1112,19 +990,6 @@ End ZUnivConstraint. now eapply entails_L_in_cls. Qed. - Lemma entails_to_clauses {prems concl cstr} : Clauses.In (prems, concl) (LoopCheck.to_clauses cstr) -> - [relation_of_constraint cstr] ⊢ℒ (singleton concl ≤ prems). - Proof. - destruct cstr as [[l []] r]. - - intros hin. cbn -[le]. - have en := entails_L_relations_of_clauses_le l r. - setoid_rewrite <- en. cbn in hin. - now eapply entails_L_in_cls. - - intros hin; cbn in hin |- *. - rewrite -entails_L_relations_of_clauses_eq. - now eapply entails_L_in_cls. - Qed. - Lemma relation_of_constraint_of_clause cstr : relations_of_clauses (LoopCheck.to_clauses cstr) ⊫ℒ [relation_of_constraint cstr]. Proof. @@ -1164,19 +1029,6 @@ End ZUnivConstraint. rewrite ZUnivConstraintSet.add_spec; now right. Qed. - - Lemma relations_of_clauses_union {cls cls'} : - equivlistA Logic.eq (relations_of_clauses (Clauses.union cls cls')) - (relations_of_clauses cls ++ relations_of_clauses cls'). - Proof. - intros eq. split; rewrite !InA_In_eq; rewrite in_app_iff. - - move/relations_of_clauses_spec => -[] prems [] concl [] hin ->. - eapply Clauses.union_spec in hin as [hin|hin]; [left|right]; - now apply (relations_of_clauses_spec_inv (_, _)). - - move=> [] /relations_of_clauses_spec => -[] prems [] concl [] hin ->; - apply (relations_of_clauses_spec_inv (_, _)); now apply Clauses.union_spec. - Qed. - Lemma relations_of_clauses_constraints_add {x s} : (relation_of_constraint x :: relations_of_clauses (of_z_constraints s)) ⊫ℒ (relations_of_clauses (of_z_constraints (ZUnivConstraintSet.add x s))). @@ -1188,11 +1040,11 @@ End ZUnivConstraint. Qed. Lemma rels_of_z_constraints_spec {cstrs} : - (relations_of_clauses (of_z_constraints cstrs)) ⊫ℒ (relations_of_constraints cstrs). + relations_of_clauses (of_z_constraints cstrs) ⊫ℒ relations_of_constraints cstrs. Proof. rewrite /relations_of_constraints. - have he := ZUnivConstraintSetProp.fold_rec (P := fun s f => relations_of_clauses (of_z_constraints s) -⊫ℒ f). apply: he. + have he := ZUnivConstraintSetProp.fold_rec + (P := fun s f => relations_of_clauses (of_z_constraints s) ⊫ℒ f). apply: he. - split. constructor. red. apply Forall_forall => [] l r. eapply relations_of_clauses_spec in r as [prems [concl [hin heq]]]. subst l. eapply of_z_constraints_spec in hin as [cstr [hin ]]. now apply H in hin. @@ -1219,57 +1071,23 @@ End ZUnivConstraint. apply ZUnivConstraintSetProp.Add_Equal in hadd. now rewrite hadd. Qed. - Lemma entails_L_clauses_all {cstrs s t} : - (relations_of_clauses (of_z_constraints cstrs)) ⊢ℒ s ≡ t <-> - (relations_of_constraints cstrs) ⊢ℒ s ≡ t. - Proof. - now rewrite rels_of_z_constraints_spec. - Qed. - - Lemma entails_L_clauses_le {cstrs s t} : - entails_L_pres_clauses (relations_of_clauses (of_z_constraints cstrs)) (s ⋞ t) -> - relations_of_constraints cstrs ⊢ℒ s ≤ t. - Proof. - intros hf. do 2 red in hf. rw_in clauses_of_le_spec hf. - eapply entails_L_split. - move=> le hin. - move: (hf (t, le)) => /fwd. - { exists le; split => //. } - move=> h; red in h. cbn in h. - now eapply entails_L_clauses_all in h. - Qed. - - Lemma entails_L_clauses_of_eq {cstrs s t} : - entails_L_pres_clauses (relations_of_clauses (of_z_constraints cstrs)) (s ≡ t) -> - relations_of_constraints cstrs ⊢ℒ s ≡ t. - Proof. - intros hf. do 2 red in hf. - eapply entails_L_eq_antisym. split. - all: apply entails_L_clauses_le. - - intros cl hin; red. eapply hf. - rewrite /clauses_of_eq. clsets. - - intros cl hin; red. eapply hf. - rewrite /clauses_of_eq. clsets. - Qed. - - Definition entails_L_cstr p c := - let '(l, d, r) := c in - match d with - | ConstraintType.Le => p ⊢ℒ l ≤ r - | ConstraintType.Eq => p ⊢ℒ l ≡ r - end. - - Lemma entails_L_clauses_cstr {cstrs c} : - entails_L_clauses (of_z_constraints cstrs) (LoopCheck.to_clauses c) -> - entails_L_cstr (relations_of_constraints cstrs) c. + Lemma equiv_constraints_clauses m : + relations_of_constraints (to_z_cstrs (constraints m)) ⊫ℒ Clauses.relations_of_clauses (LoopCheck.clauses (model m)). Proof. - destruct c as [[l []] r]. - - cbn. apply entails_L_clauses_le. - - cbn. apply entails_L_clauses_of_eq. + have repr := repr_constraints. + have repr_inv := repr_constraints_inv. + rewrite -rels_of_z_constraints_spec. + rewrite -to_clauses_of_z_constraints. + rewrite (@relations_of_clauses_eq (to_clauses (constraints m)) (LoopCheck.clauses (model m))) //. + 2:{ reflexivity. } + intros cl; rewrite to_clauses_spec. + split. + - move=> [] cstrs [] /repr incl intocl. + apply incl, intocl. + - now move/repr_inv. Qed. - Definition entails_L_cstrs p cstrs := - ZUnivConstraintSet.For_all (entails_L_cstr p) cstrs. + (** Lifting interpretation to constraints (on Z). *) Section interp. Import Semilattice. @@ -1284,9 +1102,7 @@ End ZUnivConstraint. end%Z. Definition interp_univ_cstr c := interp_z_cstr (to_constraint c). - - Definition interp_univ_cstrs c := - UnivConstraintSet.For_all interp_univ_cstr c. + Definition interp_univ_cstrs c := UnivConstraintSet.For_all interp_univ_cstr c. End interp. @@ -1303,61 +1119,6 @@ End ZUnivConstraint. Definition valid_cstrs p cstrs := ZUnivConstraintSet.For_all (valid_constraint p) cstrs. - - Lemma to_clauses_of_z_constraints {cstrs} : - to_clauses cstrs =_clset of_z_constraints (to_z_cstrs cstrs). - Proof. - intros l. - rewrite to_clauses_spec of_z_constraints_spec. - split. - - intros [cstr [hin hin']]. - exists (to_constraint cstr). split. - apply to_z_cstrs_spec_1 in hin as [cstrz []]. - now subst cstrz. - assumption. - - intros [cstr [hin hin']]. - apply to_z_cstrs_spec_2 in hin as [cstr' [hin ->]]. - exists cstr'. split => //. - Qed. - - Lemma completeness_eq_cstrs cstrs s t : - relations_of_constraints cstrs ⊢ℒ s ≡ t <-> - entails_z_cstr cstrs (s, ConstraintType.Eq, t). - Proof. - unfold entails_z_cstr. - split. - - intros h; depind h; cbn. - * move: H => //=; rewrite relations_of_constraints_spec => -[] [[l' []] r'] [hin heq]; noconf heq. - eapply Theory.le_spec. - now apply entails_clauses_le_cstr. - now eapply entails_clauses_eq_cstr. - * eapply Theory.eq_refl. - * now eapply Theory.eq_sym. - * now eapply Theory.eq_trans. - * now eapply Theory.succ_congr. - * now eapply Theory.succ_inj. - * now eapply Theory.join_congr_left. - * eapply Theory.join_assoc. - * eapply Theory.join_idem. - * eapply Theory.join_comm. - * eapply Theory.join_succ. - * eapply Theory.succ_join. - - move/entails_ℋ_entails_L; apply entails_L_clauses_of_eq. - Qed. - - Lemma completeness_le cstrs s t : - relations_of_constraints cstrs ⊢ℒ s ≤ t <-> - entails_z_cstr cstrs (s, ConstraintType.Le, t). - Proof. - unfold entails_z_cstr. - split. - - move/completeness_eq_cstrs. cbn. - intros h; red in h. cbn in h. - eapply Theory.le_spec. now rewrite /Clauses.le. - - move/entails_ℋ_entails_L. apply entails_L_clauses_le. - Qed. - - Import Semilattice. Import ISL. @@ -1384,6 +1145,7 @@ End ZUnivConstraint. unfold model_Z_val in *; lia. Qed. + (** The constraints in the model are already valid. *) Lemma interp_univ_cstrs_of_m m : interp_univ_cstrs (model_Z_val m) (constraints m). Proof. @@ -1403,6 +1165,8 @@ End ZUnivConstraint. by []. Qed. + (** Equivalence of interpretations between constraints and relations derived from them *) + Lemma interp_univ_cstrs_relations {S} {SL : Semilattice S Z} v cstrs : interp_univ_cstrs v cstrs <-> interp_rels v (relations_of_constraints (to_z_cstrs cstrs)). @@ -1426,41 +1190,6 @@ End ZUnivConstraint. rewrite interp_prems_union //=. Qed. - Definition invalid_cstr v c := - let '(l, d, r) := c in - match d with - | ConstraintType.Eq => interp_prems v (to_atoms l) <> interp_prems v (to_atoms r) - | ConstraintType.Le => ~ (interp_prems v (to_atoms l) <= interp_prems v (to_atoms r))%Z - end. - - Lemma entails_L_completeness {p l r} : - (forall (s : semilattice) (v : Level.t -> s), interp_rels v p -> interp_prems v l ≡ interp_prems v r)%sl -> - p ⊢ℒ l ≡ r. - Proof. - intros hv. - specialize (hv (initial_semilattice p) (ids p)). - forward hv. - { apply interp_rels_init. } - rewrite !interp_triv in hv. - exact hv. - Qed. - - Lemma equiv_constraints_clauses m : - relations_of_constraints (to_z_cstrs (constraints m)) ⊫ℒ Clauses.relations_of_clauses (LoopCheck.clauses (model m)). - Proof. - have repr := repr_constraints. - have repr_inv := repr_constraints_inv. - rewrite -rels_of_z_constraints_spec. - rewrite -to_clauses_of_z_constraints. - rewrite (@relations_of_clauses_eq (to_clauses (constraints m)) (LoopCheck.clauses (model m))) //. - 2:{ reflexivity. } - intros cl; rewrite to_clauses_spec. - split. - - move=> [] cstrs [] /repr incl intocl. - apply incl, intocl. - - now move/repr_inv. - Qed. - Lemma interp_cstr_clauses_sem {c} {s : semilattice} {v : Level.t -> s} : interp_univ_cstr v c <-> clauses_sem v (LoopCheck.to_clauses (to_constraint c)). Proof. @@ -1479,6 +1208,18 @@ End ZUnivConstraint. now rewrite -[Clauses.relations_of_clauses _]equiv_constraints_clauses. Qed. + Lemma entails_L_completeness {p l r} : + (forall (s : semilattice) (v : Level.t -> s), interp_rels v p -> interp_prems v l ≡ interp_prems v r)%sl -> + p ⊢ℒ l ≡ r. + Proof. + intros hv. + specialize (hv (initial_semilattice p) (ids p)). + forward hv. + { apply interp_rels_init. } + rewrite !interp_triv in hv. + exact hv. + Qed. + Lemma check_completeness {m c} : check m c <-> (forall (s : semilattice) (v : Level.t -> s), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). Proof. From 76f9b8d64db724c699feb615a82f8ac49c49a5e2 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 25 Sep 2025 12:43:58 +0200 Subject: [PATCH 070/164] WIP Refactor --- common/theories/LoopChecking/Common.v | 58 ----------------- common/theories/LoopChecking/Deciders.v | 6 +- .../LoopChecking/InitialSemilattice.v | 11 +--- common/theories/LoopChecking/Interfaces.v | 3 +- .../theories/LoopChecking/UnivLoopChecking.v | 4 -- common/theories/Universes.v | 7 -- utils/_RocqProject | 1 + utils/theories/MRClasses.v | 16 ++++- utils/theories/MRInstances.v | 65 +++++++++++++++++++ utils/theories/MRPrelude.v | 6 +- utils/theories/MRUtils.v | 1 + utils/theories/NonEmptyLevelExprSet.v | 13 ---- utils/theories/SemiLattice.v | 13 +++- 13 files changed, 103 insertions(+), 101 deletions(-) create mode 100644 utils/theories/MRInstances.v diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v index 56097c962..45667a81b 100644 --- a/common/theories/LoopChecking/Common.v +++ b/common/theories/LoopChecking/Common.v @@ -18,7 +18,6 @@ Next Obligation. destruct (Z.eqb_spec x y); constructor => //. Qed. - Definition option_map2 {A} (f : A -> A -> A) (o o' : option A) : option A := match o, o' with | Some x, Some y => Some (f x y) @@ -64,68 +63,11 @@ Proof. intros com [x|] [y|] => //=. now rewrite comm. Qed. -Instance Zmin_comm : Commutative Z.min := Z.min_comm. -Instance Zmax_comm : Commutative Z.max := Z.max_comm. - -Instance nat_min_comm : Commutative Nat.min := Nat.min_comm. -Instance nat_max_comm : Commutative Nat.max := Nat.max_comm. - Instance option_map_2_assoc {A} f : @Associative A f -> @Associative (option A) (option_map2 f). Proof. intros assoc [x|] [y|] [z|]; cbn => //. now rewrite assoc. Qed. -Instance nat_min_assoc : Associative Nat.min := Nat.min_assoc. -Instance nat_max_assoc : Associative Nat.max := Nat.max_assoc. - -Instance Zmin_assoc : Associative Z.min := Z.min_assoc. -Instance Zmax_assoc : Associative Z.max := Z.max_assoc. - -Instance Zadd_assoc : Associative Z.add := Z.add_assoc. -Instance Zadd_comm : Commutative Z.add := Z.add_comm. - -Instance Nadd_assoc : Associative Nat.add := Nat.add_assoc. -Instance Nadd_comm : Commutative Nat.add := Nat.add_comm. - -Import CommutativeMonoid. - -Instance Zadd_neutral : Neutral Z.add 0%Z. -Proof. red. intros. lia. Qed. - -Instance Nadd_neutral : Neutral Nat.add 0%nat. -Proof. red. intros. lia. Qed. - -Instance Zadd_comm_monoid : CommutativeMonoid 0%Z Z.add := {}. -Instance Nadd_comm_monoid : CommutativeMonoid 0%nat Nat.add := {}. - -Instance Zadd_is_comm_monoid : IsCommMonoid Z := - { zero := 0%Z; - one := 1%Z; - add := Z.add }. - -Instance Nadd_is_comm_monoid : IsCommMonoid nat := - { zero := 0%nat; - one := 1%nat; - add := Nat.add }. - - -Section ZSemiLattice. - Import Semilattice. - - Program Definition Zsemilattice : Semilattice Z Z := - {| add := Z.add; - join := Z.max; |}. - Solve Obligations with program_simpl; try lia. - - Obligation Tactic := idtac. - Next Obligation. - Proof. - intros x; unfold one, Zadd_is_comm_monoid. lia. - Qed. - -End ZSemiLattice. - -#[export] Existing Instance Zsemilattice. Lemma fold_left_comm {A B} (f : B -> A -> B) (l : list A) (x : A) (acc : B) : (forall x y z, f (f z x) y = f (f z y) x) -> diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index e3a4e20b2..0231c8a51 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -789,11 +789,11 @@ Module Abstract. Import I.Model.Model.Clauses.ISL. - Definition clause_sem {S} {SL : Semilattice S Q.t} V (cl : clause) : Prop := + Definition clause_sem {s : semilattice} (V : Level.t -> s) (cl : clause) : Prop := let '(prems, concl) := cl in le (interp_expr V concl) (interp_prems V prems). - Definition clauses_sem {S} {SL : Semilattice S Q.t} V (cls : Clauses.t) : Prop := + Definition clauses_sem {s : semilattice} (V : Leve.t -> s) (cls : Clauses.t) : Prop := Clauses.For_all (clause_sem V) cls. Lemma enforce_clauses_inconsistent m cls u : @@ -1221,7 +1221,7 @@ Module LoopChecking (LS : LevelSets). Proof. apply enforce_clauses_levels. Qed. Definition valid_entailments cls cls' := - forall S (SL : Semilattice.Semilattice S Q.t) (V : Level.t -> S), clauses_sem V cls -> clauses_sem V cls'. + forall s : semilattice, (V : Level.t -> s), clauses_sem V cls -> clauses_sem V cls'. (* Returns true is the constraint is valid in the model and all its possible consistent extensions. Returns false if the constraint results in an inconsistent set of constraints or it simply diff --git a/common/theories/LoopChecking/InitialSemilattice.v b/common/theories/LoopChecking/InitialSemilattice.v index d802de40c..3170659df 100644 --- a/common/theories/LoopChecking/InitialSemilattice.v +++ b/common/theories/LoopChecking/InitialSemilattice.v @@ -21,6 +21,7 @@ Module InitialSemilattice (LS : LevelSets). Import Semilattice. Import CommutativeMonoid. + Existing Instance semilattice_Semilattice. Existing Instance OfQ.add_inj_le. Definition rel := t × t. @@ -698,16 +699,8 @@ End ForSemilattice. End OnInterp. - Structure semilattice := - { carrier :> Type; - sl : Semilattice carrier Q.t }. - - (* Definition incr_semilattice : semilattice_on comm_monoid := {| carrier := Q.t; sl := _ |}. *) - - Instance semlattice_Semilattice (s : semilattice) : Semilattice (carrier s) Q.t := sl s. - Definition valid_relation rels c := - (forall (s : semilattice) (v : Level.t -> s), interp_rels v rels -> interp_rel v c). + (forall (s : semilattice Q.t) (v : Level.t -> s), interp_rels (SL := semilattice_Semilattice s) v rels -> interp_rel v c). Definition valid_relations rels rels' := (forall (s : semilattice) (v : Level.t -> s), interp_rels v rels -> interp_rels v rels'). diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 02f559e77..6a2fbb131 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -48,8 +48,7 @@ Module Q <: Quantity. Include OrdersEx.Z_as_OT. Import CommutativeMonoid. - Instance comm_monoid : IsCommMonoid Z := - { zero := Z.zero ; one := 1%Z; add := Z.add }. + Instance comm_monoid : IsCommMonoid Z := Zadd_is_comm_monoid. Program Instance add_inj_eq z : Injective (Z.add z) eq eq. Next Obligation. unfold eq in *. lia. Qed. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index a02b5bac3..957d2a05c 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -1106,10 +1106,6 @@ End ZUnivConstraint. End interp. - Definition Z_semilattice := {| carrier := Z; sl := _ |}. - - Instance semlattice_Semilattice (s : semilattice) : Semilattice (carrier s) Z := sl s. - Definition valid_relation rels c := (forall (s : semilattice) (v : Level.t -> s), interp_rels v rels -> interp_rel v c). diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 948989fd8..2e9686f3d 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -385,17 +385,10 @@ Module Universe. Include OrdersEx.Nat_as_OT. Import CommutativeMonoid. - #[program] Instance comm_monoid : IsCommMonoid nat := {| zero := 0%nat; one := 1%nat; add := Nat.add |}. - Next Obligation. - split; tc. - - red. apply add_assoc. - - red. apply add_comm. - - red. apply Nat.add_0_l. - Qed. Instance add_inj_eq n : Injective (add n) eq eq. Proof. diff --git a/utils/_RocqProject b/utils/_RocqProject index 1d965812f..0f7cde7fa 100644 --- a/utils/_RocqProject +++ b/utils/_RocqProject @@ -35,6 +35,7 @@ theories/Show.v theories/utils.v theories/MRClasses.v theories/SemiLattice.v +theories/MRInstances.v theories/NonEmptyLevelExprSet.v diff --git a/utils/theories/MRClasses.v b/utils/theories/MRClasses.v index 570a403f2..cae20eaf9 100644 --- a/utils/theories/MRClasses.v +++ b/utils/theories/MRClasses.v @@ -1,14 +1,26 @@ From Corelib Require Import Relation_Definitions. +Class Injective {A B} (f : A -> B) (R : relation A) (R' : relation B) := inj : forall x y, R' (f x) (f y) -> R x y. + Class Neutral {A} (f : A -> A -> A) (z : A) := neutral x : f z x = x. Class Commutative {A} (f : A -> A -> A) := comm : forall x y, f x y = f y x. Class Associative {A} (f : A -> A -> A) := assoc : forall x y z, f x (f y z) = f (f x y) z. - Class CommutativeMonoid {A} (zero : A) (add : A -> A -> A) := { add_assoc :: Associative add; add_comm :: Commutative add; add_neutral :: Neutral add zero }. -Class Injective {A B} (f : A -> B) (R : relation A) (R' : relation B) := inj : forall x y, R' (f x) (f y) -> R x y. +Module CommutativeMonoid. +Class IsCommMonoid (A : Type) := + { zero : A; + one : A; + add : A -> A -> A; + comm_mon :: CommutativeMonoid zero add }. + +Declare Scope comm_monoid. +Notation "0" := zero : comm_monoid. +Notation "1" := one : comm_monoid. +Notation "+" := add : comm_monoid. +End CommutativeMonoid. diff --git a/utils/theories/MRInstances.v b/utils/theories/MRInstances.v new file mode 100644 index 000000000..389965541 --- /dev/null +++ b/utils/theories/MRInstances.v @@ -0,0 +1,65 @@ +From MetaRocq.Utils Require Import MRClasses. +From MetaRocq.Utils Require Import SemiLattice. +From Stdlib Require Import ZArith Lia Program. + +Instance Zmin_comm : Commutative Z.min := Z.min_comm. +Instance Zmax_comm : Commutative Z.max := Z.max_comm. + +Instance nat_min_comm : Commutative Nat.min := Nat.min_comm. +Instance nat_max_comm : Commutative Nat.max := Nat.max_comm. + +Instance nat_min_assoc : Associative Nat.min := Nat.min_assoc. +Instance nat_max_assoc : Associative Nat.max := Nat.max_assoc. + +Instance Zmin_assoc : Associative Z.min := Z.min_assoc. +Instance Zmax_assoc : Associative Z.max := Z.max_assoc. + +Instance Zadd_assoc : Associative Z.add := Z.add_assoc. +Instance Zadd_comm : Commutative Z.add := Z.add_comm. + +Instance Nadd_assoc : Associative Nat.add := Nat.add_assoc. +Instance Nadd_comm : Commutative Nat.add := Nat.add_comm. + +Import CommutativeMonoid. + +Instance Zadd_neutral : Neutral Z.add 0%Z. +Proof. red. intros. lia. Qed. + +Instance Nadd_neutral : Neutral Nat.add 0%nat. +Proof. red. intros. lia. Qed. + +Instance Zadd_comm_monoid : CommutativeMonoid 0%Z Z.add := {}. +Instance Nadd_comm_monoid : CommutativeMonoid 0%nat Nat.add := {}. + +Instance Zadd_is_comm_monoid : IsCommMonoid Z := + { zero := 0%Z; + one := 1%Z; + add := Z.add }. + +Instance Nadd_is_comm_monoid : IsCommMonoid nat := + { zero := 0%nat; + one := 1%nat; + add := Nat.add }. + + +Section ZSemiLattice. + Import Semilattice. + + Program Definition Zsemilattice : Semilattice Z Z := + {| add := Z.add; + join := Z.max; |}. + Solve Obligations with program_simpl; try lia. + + Obligation Tactic := idtac. + Next Obligation. + Proof. + intros x; unfold one, Zadd_is_comm_monoid. lia. + Qed. + +End ZSemiLattice. + +#[export] Existing Instance Zsemilattice. + +Import Semilattice. + +Canonical Structure Z_semilattice : Semilattice.semilattice Z := {| carrier := Z; comm_monoid := _; sl := _ |}. diff --git a/utils/theories/MRPrelude.v b/utils/theories/MRPrelude.v index c5c86a72e..0fb52ffd4 100644 --- a/utils/theories/MRPrelude.v +++ b/utils/theories/MRPrelude.v @@ -38,8 +38,10 @@ Notation "x .π2" := (@projT2 _ _ x) (at level 3, format "x '.π2'"). (** Shorthand for pointwise equality relation in Proper signatures *) Notation "`=1`" := (pointwise_relation _ Logic.eq) (at level 80). -Infix "=1" := (pointwise_relation _ Logic.eq) (at level 70) : type_scope. +#[warnings="-notation-overridden"] +Infix "≐1" := (pointwise_relation _ Logic.eq) (at level 70) : type_scope. Notation "`=2`" := (pointwise_relation _ (pointwise_relation _ Logic.eq)) (at level 80). +#[warnings="-notation-overridden"] Infix "=2" := (pointwise_relation _ (pointwise_relation _ Logic.eq)) (at level 70) : type_scope. (** Higher-order lemma to simplify Proper proofs. *) @@ -134,7 +136,7 @@ Record sigP {A : Prop} {B : A -> Prop} := existP { projP1 : A ; projP2 : B projP Arguments sigP {A} B. Arguments existP {A} B _ _. -Notation fwd := (ltac:(move=> /(_ _)/Wrap[])). +Notation fwd := (ltac:(move=> /(_ _)/Wrap[])) (only parsing). Arguments exist {A P}. Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. diff --git a/utils/theories/MRUtils.v b/utils/theories/MRUtils.v index ea3e90404..fb497698f 100644 --- a/utils/theories/MRUtils.v +++ b/utils/theories/MRUtils.v @@ -2,6 +2,7 @@ From Stdlib Require Import Nat ZArith Bool. From MetaRocq.Utils Require Export MRPrelude MRClasses + MRInstances MRReflect All_Forall MRArith diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v index 7593614fe..c76c9c46e 100644 --- a/utils/theories/NonEmptyLevelExprSet.v +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -17,19 +17,6 @@ Module Type OrderedTypeWithLeibnizWithReflect. Parameter to_string : t -> string. End OrderedTypeWithLeibnizWithReflect. -Module CommutativeMonoid. -Class IsCommMonoid (A : Type) := - { zero : A; - one : A; - add : A -> A -> A; - comm_mon :: CommutativeMonoid zero add }. - -Declare Scope comm_monoid. -Notation "0" := zero : comm_monoid. -Notation "1" := one : comm_monoid. -Notation "+" := add : comm_monoid. -End CommutativeMonoid. - Module Type Quantity. Include OrderedTypeWithLeibniz. Import CommutativeMonoid. diff --git a/utils/theories/SemiLattice.v b/utils/theories/SemiLattice.v index 20faa4759..8fa4eda6f 100644 --- a/utils/theories/SemiLattice.v +++ b/utils/theories/SemiLattice.v @@ -2,7 +2,7 @@ From Stdlib Require Import ssreflect ssrbool ssrfun ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils NonEmptyLevelExprSet. +From MetaRocq.Utils Require Import MRClasses NonEmptyLevelExprSet. Set Equations Transparent. @@ -158,4 +158,15 @@ Module Semilattice. Qed. End Derived. + + Structure semilattice {Q} := + { carrier :> Type; + comm_monoid : IsCommMonoid Q ; + sl : Semilattice carrier Q }. + Arguments semilattice : clear implicits. + + Instance semilattice_CommMonoid {Q} (s : semilattice Q) : IsCommMonoid Q := comm_monoid s. + + Instance semilattice_Semilattice {Q} (s : semilattice Q) : @Semilattice (carrier s) Q (comm_monoid s) := sl s. + End Semilattice. From 6cec4345b1aee2a688a94e45b90215b6fd4d54c8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 25 Sep 2025 13:20:18 +0200 Subject: [PATCH 071/164] Finish refactor, rename =1 to \doteq1 to avoid notation conflict --- common/theories/BasicAst.v | 24 +- common/theories/LoopChecking/Common.v | 2 +- common/theories/LoopChecking/Deciders.v | 17 +- .../LoopChecking/InitialSemilattice.v | 28 +-- .../theories/LoopChecking/UnivLoopChecking.v | 25 +- common/theories/uGraph.v | 10 +- oldLoopChecking.v | 2 +- .../theories/Bidirectional/BDStrengthening.v | 8 +- pcuic/theories/Conversion/PCUICInstConv.v | 20 +- pcuic/theories/Conversion/PCUICNamelessConv.v | 2 +- pcuic/theories/Conversion/PCUICRenameConv.v | 8 +- pcuic/theories/PCUICAst.v | 42 ++-- pcuic/theories/PCUICContextReduction.v | 2 +- pcuic/theories/PCUICExpandLetsCorrectness.v | 4 +- pcuic/theories/PCUICInductiveInversion.v | 2 +- pcuic/theories/PCUICInductives.v | 2 +- pcuic/theories/PCUICParallelReduction.v | 12 +- .../PCUICParallelReductionConfluence.v | 2 +- pcuic/theories/PCUICSR.v | 4 +- pcuic/theories/PCUICSigmaCalculus.v | 238 +++++++++--------- pcuic/theories/PCUICSpine.v | 4 +- pcuic/theories/PCUICSubstitution.v | 4 +- pcuic/theories/PCUICUnivLevels.v | 2 +- pcuic/theories/Syntax/PCUICInstDef.v | 2 +- pcuic/theories/Syntax/PCUICLiftSubst.v | 4 +- pcuic/theories/Syntax/PCUICOnFreeVars.v | 78 +++--- pcuic/theories/Typing/PCUICRenameTyp.v | 2 +- pcuic/theories/utils/PCUICAstUtils.v | 2 +- template-rocq/theories/Ast.v | 6 +- template-rocq/theories/LoopChecking.v | 2 +- template-rocq/theories/LoopCheckingNat.v | 2 +- utils/theories/All_Forall.v | 6 +- utils/theories/MROption.v | 8 +- utils/theories/MRPred.v | 8 +- utils/theories/MRPrelude.v | 14 +- utils/theories/MR_ExtrOCamlZPosInt.v | 2 +- utils/theories/wGraph.v | 2 +- 37 files changed, 301 insertions(+), 301 deletions(-) diff --git a/common/theories/BasicAst.v b/common/theories/BasicAst.v index 4aff7c3be..ac24ad7ce 100644 --- a/common/theories/BasicAst.v +++ b/common/theories/BasicAst.v @@ -276,12 +276,12 @@ Proof. now rewrite (H t). Qed. -#[global] Instance map_decl_proper {term term'} : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@map_decl term term'). +#[global] Instance map_decl_proper {term term'} : Proper (`≐1` ==> Logic.eq ==> Logic.eq) (@map_decl term term'). Proof. intros f g Hfg x y ->. now apply map_decl_ext. Qed. -#[global] Instance map_decl_pointwise {term term'} : Proper (`=1` ==> `=1`) (@map_decl term term'). +#[global] Instance map_decl_pointwise {term term'} : Proper (`≐1` ==> `≐1`) (@map_decl term term'). Proof. intros f g Hfg x. rewrite /map_decl. destruct x => /=. f_equal. - now rewrite Hfg. @@ -289,12 +289,12 @@ Proof. intros f g Hfg x. rewrite /map_decl. Qed. (* -#[global] Instance pointwise_subrelation {A B} : subrelation (`=1`) (@Logic.eq A ==> @Logic.eq B)%signature. +#[global] Instance pointwise_subrelation {A B} : subrelation (`≐1`) (@Logic.eq A ==> @Logic.eq B)%signature. Proof. intros f g Hfg x y ->. now rewrite Hfg. Qed. -#[global] Instance pointwise_subrelation_inv {A B} : subrelation (@Logic.eq A ==> @Logic.eq B)%signature (`=1`). +#[global] Instance pointwise_subrelation_inv {A B} : subrelation (@Logic.eq A ==> @Logic.eq B)%signature (`≐1`). Proof. intros f g Hfg x. now specialize (Hfg x x eq_refl). Qed.*) @@ -302,7 +302,7 @@ Qed.*) Definition map_context {term term'} (f : term -> term') (c : list (context_decl term)) := List.map (map_decl f) c. -#[global] Instance map_context_proper {term term'} : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@map_context term term'). +#[global] Instance map_context_proper {term term'} : Proper (`≐1` ==> Logic.eq ==> Logic.eq) (@map_context term term'). Proof. intros f g Hfg x y ->. now rewrite /map_context Hfg. @@ -315,7 +315,7 @@ Proof. now unfold map_context; rewrite length_map. Qed. Definition test_decl {term} (f : term -> bool) (d : context_decl term) : bool := option_default f d.(decl_body) true && f d.(decl_type). -#[global] Instance test_decl_proper {term} : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@test_decl term). +#[global] Instance test_decl_proper {term} : Proper (`≐1` ==> Logic.eq ==> Logic.eq) (@test_decl term). Proof. intros f g Hfg [na [b|] ty] ? <- => /=; rewrite /test_decl /=; now rewrite Hfg. @@ -378,7 +378,7 @@ Section ContextMap. end. End ContextMap. -#[global] Instance mapi_context_proper {term term'} : Proper (`=2` ==> Logic.eq ==> Logic.eq) (@mapi_context term term'). +#[global] Instance mapi_context_proper {term term'} : Proper (`≐2` ==> Logic.eq ==> Logic.eq) (@mapi_context term term'). Proof. intros f g Hfg Γ ? <-. induction Γ as [|[na [b|] ty] Γ]; simpl; auto; f_equal; auto; now rewrite Hfg. @@ -400,7 +400,7 @@ Section ContextTest. end. End ContextTest. -#[global] Instance test_context_proper {term} : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@test_context term). +#[global] Instance test_context_proper {term} : Proper (`≐1` ==> Logic.eq ==> Logic.eq) (@test_context term). Proof. intros f g Hfg Γ ? <-. induction Γ as [|[na [b|] ty] Γ]; simpl; auto; f_equal; auto; now rewrite Hfg. @@ -416,7 +416,7 @@ Section ContextTestK. end. End ContextTestK. -#[global] Instance test_context_k_proper {term} : Proper (`=1` ==> Logic.eq ==> Logic.eq ==> Logic.eq) (@test_context_k term). +#[global] Instance test_context_k_proper {term} : Proper (`≐1` ==> Logic.eq ==> Logic.eq ==> Logic.eq) (@test_context_k term). Proof. intros f g Hfg k ? <- Γ ? <-. induction Γ as [|[na [b|] ty] Γ]; simpl; auto; f_equal; auto; now rewrite Hfg. @@ -466,7 +466,7 @@ Section Contexts. Lemma map_decl_body (f : term -> term') decl : option_map f (decl_body decl) = decl_body (map_decl f decl). Proof using Type. destruct decl; reflexivity. Qed. - Lemma map_decl_id : @map_decl term term id =1 id. + Lemma map_decl_id : @map_decl term term id ≐1 id. Proof using Type. intros d; now destruct d as [? [] ?]. Qed. Lemma option_map_decl_body_map_decl (f : term -> term') x : @@ -575,7 +575,7 @@ Section Contexts. Qed. #[global] - Instance fold_context_Proper : Proper (`=2` ==> `=1`) fold_context. + Instance fold_context_Proper : Proper (`≐2` ==> `≐1`) fold_context. Proof using Type. intros f f' Hff' x. funelim (fold_context f x); simpl; auto. simp fold_context. @@ -616,7 +616,7 @@ Section Contexts. Qed. Lemma fold_context_k_ext (f g : nat -> term' -> term) Γ : - f =2 g -> + f ≐2 g -> fold_context_k f Γ = fold_context_k g Γ. Proof using Type. intros hfg. diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v index 45667a81b..f2864e08f 100644 --- a/common/theories/LoopChecking/Common.v +++ b/common/theories/LoopChecking/Common.v @@ -35,7 +35,7 @@ Proof. - now f_equal. Qed. -#[export] Instance fold_left_ext {A B} : Proper (`=2` ==> eq ==> eq ==> eq) (@fold_left A B). +#[export] Instance fold_left_ext {A B} : Proper (`≐2` ==> eq ==> eq ==> eq) (@fold_left A B). Proof. intros f g hfg ? ? -> ? ? ->. induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 0231c8a51..a96d41e25 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -789,11 +789,11 @@ Module Abstract. Import I.Model.Model.Clauses.ISL. - Definition clause_sem {s : semilattice} (V : Level.t -> s) (cl : clause) : Prop := + Definition clause_sem {S} {SL : Semilattice S Q.t} (V : Level.t -> S) (cl : clause) : Prop := let '(prems, concl) := cl in le (interp_expr V concl) (interp_prems V prems). - Definition clauses_sem {s : semilattice} (V : Leve.t -> s) (cls : Clauses.t) : Prop := + Definition clauses_sem {S} {SL : Semilattice S Q.t} (V : Level.t -> S) (cls : Clauses.t) : Prop := Clauses.For_all (clause_sem V) cls. Lemma enforce_clauses_inconsistent m cls u : @@ -1059,8 +1059,7 @@ Module Abstract. Proof. move/to_entails_all/entails_L_entails_ℋ_equiv. move/entails_L_rels_entails_L_clauses/completeness_all. - move/(_ {| carrier := Z; sl := _ |}). cbn. - move/(_ (Z_valuation_of_model m)). + move/(_ Z _ (Z_valuation_of_model m)). rewrite -!interp_rels_clauses_sem => /fwd. cbn in *. have mok := m.(model).(model_valid).(model_ok). @@ -1102,10 +1101,10 @@ Module Abstract. rewrite -completeness_all. split. - move=> vr s sl v. - move: (vr {| carrier := _; sl := sl |} v). + move: (vr _ sl v). rewrite !interp_rels_clauses_sem //. - - intros ve s v. - move: (ve s (sl s) v). + - intros ve S s v. + move: (ve S s v). now rewrite //= !interp_rels_clauses_sem. Qed. @@ -1199,7 +1198,7 @@ Module LoopChecking (LS : LevelSets). rewrite -entails_L_rels_entails_L_clauses. rewrite -ISL.completeness_all. move=> vr [] V. - specialize (vr {| ISL.carrier := Z; ISL.sl := _ |} V). + specialize (vr Z _ V). move: vr. rewrite !interp_rels_clauses_sem // => vr /vr. rewrite -interp_rels_clauses_sem. @@ -1221,7 +1220,7 @@ Module LoopChecking (LS : LevelSets). Proof. apply enforce_clauses_levels. Qed. Definition valid_entailments cls cls' := - forall s : semilattice, (V : Level.t -> s), clauses_sem V cls -> clauses_sem V cls'. + forall S (SL : Semilattice.Semilattice S Q.t) (V : Level.t -> S), clauses_sem V cls -> clauses_sem V cls'. (* Returns true is the constraint is valid in the model and all its possible consistent extensions. Returns false if the constraint results in an inconsistent set of constraints or it simply diff --git a/common/theories/LoopChecking/InitialSemilattice.v b/common/theories/LoopChecking/InitialSemilattice.v index 3170659df..80fb0e0a0 100644 --- a/common/theories/LoopChecking/InitialSemilattice.v +++ b/common/theories/LoopChecking/InitialSemilattice.v @@ -411,7 +411,7 @@ Module InitialSemilattice (LS : LevelSets). Context {S : Type} {SL : Semilattice S Q.t}. Context (v : Level.t -> S). - Definition interp_expr '(l, k) := (add k (v l))%Z. + Definition interp_expr '(l, k) := (add k (v l)). Definition interp_prems prems := let '(hd, tl) := to_nonempty_list prems in @@ -700,21 +700,21 @@ End ForSemilattice. End OnInterp. Definition valid_relation rels c := - (forall (s : semilattice Q.t) (v : Level.t -> s), interp_rels (SL := semilattice_Semilattice s) v rels -> interp_rel v c). + (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v rels -> interp_rel v c). Definition valid_relations rels rels' := - (forall (s : semilattice) (v : Level.t -> s), interp_rels v rels -> interp_rels v rels'). + (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v rels -> interp_rels v rels'). Lemma entails_L_valid {p r} : p ⊢ℒ r -> valid_relation p r. Proof. rewrite /valid_relation //=. destruct r as [l r] => //=. - intros h; depind h; cbn; move=> s v hv. + intros h; depind h; cbn; move=> S SL v hv. 1:{ red in hv. rewrite Forall_forall in hv; eapply hv in H. exact H. } - all:try specialize (IHh _ _ Logic.eq_refl s _ hv). - all:try specialize (IHh1 _ _ Logic.eq_refl s _ hv). - all:try specialize (IHh2 _ _ Logic.eq_refl s _ hv). + all:try specialize (IHh _ _ Logic.eq_refl S SL _ hv). + all:try specialize (IHh1 _ _ Logic.eq_refl S SL _ hv). + all:try specialize (IHh2 _ _ Logic.eq_refl S SL _ hv). all:try lia; eauto. all:rewrite ?interp_add_prems ?interp_prems_union ?interp_add_prems; try lia. - eapply reflexivity. @@ -727,7 +727,7 @@ End ForSemilattice. - apply join_assoc. - apply join_idem. - apply join_comm. - - apply (join_sub (Semilattice := sl s)). + - apply (join_sub (Semilattice := SL)). - now apply add_join. Qed. @@ -748,7 +748,7 @@ End ForSemilattice. #[export] Existing Instance init_model. - Definition initial_semilattice rs : semilattice := + Definition initial_semilattice rs : semilattice Q.t := {| carrier := NES.t; sl := init_model rs |}. Definition ids (rs : rels) : Level.t -> t := (fun l : Level.t => singleton (l, zero)). @@ -800,7 +800,7 @@ End ForSemilattice. intros ha. apply syntax_model. destruct r as [l r]. cbn. change (eq (Semilattice := init_model p) (interp_prems (SL := init_model p) (ids p) l) (interp_prems (SL := init_model p) (ids p) r)). - specialize (ha (initial_semilattice p) (ids p) (interp_rels_init p)). + specialize (ha _ (init_model p) (ids p) (interp_rels_init p)). now cbn in ha. Qed. @@ -820,9 +820,9 @@ End ForSemilattice. - split. constructor. intros _; red. intros; constructor. - split. cbn. * intros vr. red. constructor. - apply completeness. intros s v hi. - now move: (vr s v hi) => h; depelim h. - apply IHrs. intros s v hi. specialize (vr s v hi). now depelim vr. + apply completeness. intros S s v hi. + now move: (vr _ s v hi) => h; depelim h. + apply IHrs. intros S s v hi. specialize (vr _ s v hi). now depelim vr. * intros ent; depelim ent. apply completeness in H. intros s v hi. constructor. @@ -839,7 +839,7 @@ End ForSemilattice. * constructor. * intros H0. depelim hl. specialize (IHrs' _ hl H0). constructor => //. eapply entails_L_valid in H. - now apply (H {| carrier := S; sl := SL |} V H0). + now apply (H S SL V H0). Qed. Instance interp_rels_proper {S} {SL : Semilattice S Q.t} V : Proper (equiv_L_rels ==> iff) (interp_rels V). diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 957d2a05c..bf02fe588 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -715,7 +715,8 @@ End ZUnivConstraint. - intros le x eq nin. rewrite to_atoms_add interp_prems_add. rewrite val_add. - rewrite interp_prem_to_atom. cbn. lia. + rewrite interp_prem_to_atom. cbn in *. + lia. Qed. Lemma clauses_sem_val m l r : @@ -1107,10 +1108,10 @@ End ZUnivConstraint. End interp. Definition valid_relation rels c := - (forall (s : semilattice) (v : Level.t -> s), interp_rels v rels -> interp_rel v c). + (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v rels -> interp_rel v c). Definition valid_constraint rels c := - (forall (s : semilattice) (v : Level.t -> s), interp_rels v rels -> interp_z_cstr v c). + (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v rels -> interp_z_cstr v c). Definition valid_cstrs p cstrs := ZUnivConstraintSet.For_all (valid_constraint p) cstrs. @@ -1186,7 +1187,7 @@ End ZUnivConstraint. rewrite interp_prems_union //=. Qed. - Lemma interp_cstr_clauses_sem {c} {s : semilattice} {v : Level.t -> s} : + Lemma interp_cstr_clauses_sem {c} {S} {SL : Semilattice S Q.t} {v : Level.t -> S} : interp_univ_cstr v c <-> clauses_sem v (LoopCheck.to_clauses (to_constraint c)). Proof. rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. @@ -1196,7 +1197,7 @@ End ZUnivConstraint. now rewrite interp_prems_union. Qed. - Lemma interp_cstrs_clauses_sem {m} {s : semilattice} {v : Level.t -> s} : + Lemma interp_cstrs_clauses_sem {m} {S} {SL : Semilattice S Q.t} {v : Level.t -> S} : interp_univ_cstrs v (constraints m) <-> clauses_sem v (LoopCheck.clauses (model m)). Proof. rewrite interp_univ_cstrs_relations. @@ -1205,28 +1206,28 @@ End ZUnivConstraint. Qed. Lemma entails_L_completeness {p l r} : - (forall (s : semilattice) (v : Level.t -> s), interp_rels v p -> interp_prems v l ≡ interp_prems v r)%sl -> + (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v p -> interp_prems v l ≡ interp_prems v r)%sl -> p ⊢ℒ l ≡ r. Proof. intros hv. - specialize (hv (initial_semilattice p) (ids p)). + specialize (hv _ (init_model p) (ids p)). forward hv. { apply interp_rels_init. } rewrite !interp_triv in hv. exact hv. Qed. - Lemma check_completeness {m c} : - check m c <-> (forall (s : semilattice) (v : Level.t -> s), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + Theorem check_completeness {m c} : + check m c <-> (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). Proof. rewrite LoopCheck.check_complete /LoopCheck.valid_entailments. setoid_rewrite interp_cstrs_clauses_sem. split. - - intros hv s v hp. - move: (hv s (sl s) v hp). + - intros hv S s v hp. + move: (hv S s v hp). now rewrite interp_cstr_clauses_sem. - intros hs S SL V hsem. - move: (hs {| carrier := S; sl := SL |} V) => /fwd //. + move: (hs S SL V) => /fwd //. now rewrite interp_cstr_clauses_sem. Qed. diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index 4ec8c6dbb..e6cb552ae 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -2752,7 +2752,7 @@ Section AddLevelsCstrs. Lemma fold_left_comm_ext (l l' : list Nbar.t) : (forall x, In x l <-> In x l') -> - fold_left Nbar.max l =1 fold_left Nbar.max l'. + fold_left Nbar.max l ≐1 fold_left Nbar.max l'. Proof. intros eql acc. generalize (fold_left_max_spec l acc _ eq_refl). @@ -2768,9 +2768,9 @@ Section AddLevelsCstrs. intuition auto. now apply eql. now apply H3, eql. Qed. - Lemma fold_left_comm_ext2 f f' (l l' : list (Z × Level.t)) : f =1 f' -> + Lemma fold_left_comm_ext2 f f' (l l' : list (Z × Level.t)) : f ≐1 f' -> (forall x, In x l <-> In x l') -> - fold_left Nbar.max (map f l) =1 fold_left Nbar.max (map f' l'). + fold_left Nbar.max (map f l) ≐1 fold_left Nbar.max (map f' l'). Proof. intros eqf eqg. apply fold_left_comm_ext. @@ -2796,9 +2796,9 @@ Section AddLevelsCstrs. now setoid_rewrite (Equal_graph_edges eq). Qed. - Lemma fold_left_comm_ext3 f f' e e' x : f =1 f' -> + Lemma fold_left_comm_ext3 f f' e e' x : f ≐1 f' -> Equal_graph e e' -> - fold_left Nbar.max (map f (succs e x)) =1 + fold_left Nbar.max (map f (succs e x)) ≐1 fold_left Nbar.max (map f' (succs e' x)). Proof. intros eqf eqg. diff --git a/oldLoopChecking.v b/oldLoopChecking.v index 9770f3e12..fbb6ca386 100644 --- a/oldLoopChecking.v +++ b/oldLoopChecking.v @@ -890,7 +890,7 @@ Proof. now rewrite eqm. Qed. -#[local] Instance fold_left_ext {A B} : Proper (`=2` ==> eq ==> eq ==> eq) (@fold_left A B). +#[local] Instance fold_left_ext {A B} : Proper (`≐2` ==> eq ==> eq ==> eq) (@fold_left A B). Proof. intros f g hfg ? ? -> ? ? ->. induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). diff --git a/pcuic/theories/Bidirectional/BDStrengthening.v b/pcuic/theories/Bidirectional/BDStrengthening.v index c8f4665e4..49648eb09 100644 --- a/pcuic/theories/Bidirectional/BDStrengthening.v +++ b/pcuic/theories/Bidirectional/BDStrengthening.v @@ -21,7 +21,7 @@ Ltac case_inequalities := destruct (Nat.ltb_spec x y) end. -Lemma shiftnP_shiftn P f i : (shiftnP i P) ∘ (shiftn i f) =1 shiftnP i (P ∘ f). +Lemma shiftnP_shiftn P f i : (shiftnP i P) ∘ (shiftn i f) ≐1 shiftnP i (P ∘ f). Proof. intros k. rewrite !/shiftnP /shiftn. @@ -94,7 +94,7 @@ Qed. Lemma addnP_strengthen_lift i k k' : i <= k' -> (addnP (S i) (strengthenP k' k xpredT)) ∘ (lift_renaming k (Nat.pred k' - i)) - =1 xpredT. + ≐1 xpredT. Proof. intros l ?. rewrite /addnP /strengthenP /lift_renaming. @@ -210,7 +210,7 @@ Proof. Qed. Lemma substP_shiftnP k n p : - substP k n p (shiftnP (k+n) p) =1 (shiftnP k p). + substP k n p (shiftnP (k+n) p) ≐1 (shiftnP k p). Proof. intros i; rewrite /shiftnP /substP /= /strengthenP /=. do 2 case_inequalities => //=. @@ -316,7 +316,7 @@ Qed. Definition unlift_renaming n k i := if i /=. rewrite - !up_Up /up. @@ -331,7 +331,7 @@ Proof. Qed. Lemma upn_subst_instance u n σ : - up n (subst_instance u ∘ σ) =1 subst_instance u ∘ up n σ. + up n (subst_instance u ∘ σ) ≐1 subst_instance u ∘ up n σ. Proof. intros i => /=. rewrite /up. @@ -340,7 +340,7 @@ Proof. Qed. Lemma Upn_subst_instance u n σ : - ⇑^n (subst_instance u ∘ σ) =1 subst_instance u ∘ ⇑^n σ. + ⇑^n (subst_instance u ∘ σ) ≐1 subst_instance u ∘ ⇑^n σ. Proof. rewrite - !up_Upn. rewrite upn_subst_instance. intros i. now rewrite up_Upn. @@ -800,7 +800,7 @@ Proof. rewrite inst_closed_constructor_body //. apply (declared_constructor_closed declc). Qed. -Lemma up_0 f : up 0 f =1 f. +Lemma up_0 f : up 0 f ≐1 f. Proof. rewrite /up /=; setoid_rewrite Nat.sub_0_r. intros i. now rewrite rename_ren_id. @@ -895,7 +895,7 @@ Proof. Qed. #[global] -Instance map_def_ext {A B} : Proper (`=1` ==> `=1` ==> `=1`) (@map_def A B). +Instance map_def_ext {A B} : Proper (`≐1` ==> `≐1` ==> `≐1`) (@map_def A B). Proof. intros f g Hfg f' g' Hfg' x. unfold map_def; destruct x; simpl. @@ -1324,7 +1324,7 @@ Context `{cf: checker_flags}. Lemma usubst_ext {Δ σ σ' Γ} : usubst Γ σ Δ -> - σ =1 σ' -> + σ ≐1 σ' -> usubst Γ σ' Δ. Proof using Type. intros Hσ eq n decl hnth. @@ -1338,7 +1338,7 @@ Qed. Lemma closed_subst_ext {Δ σ σ' Γ} : closed_subst Γ σ Δ -> - σ =1 σ' -> + σ ≐1 σ' -> closed_subst Γ σ' Δ. intros [HΔ Hσ] eq. destruct Hσ as [closed_σ Hσ]. repeat split; eauto. - intros n decl hnth. rewrite <- (eq n). eapply closed_σ; eauto. @@ -1347,7 +1347,7 @@ Qed. Lemma well_subst_ext Σ Δ σ σ' Γ : Σ ;;; Δ ⊢ σ : Γ -> - σ =1 σ' -> + σ ≐1 σ' -> Σ ;;; Δ ⊢ σ' : Γ. Proof using Type. intros Hσ eq. destruct Hσ as [typed_σ Hσ]. split. @@ -2046,7 +2046,7 @@ Proof using Type. now rewrite on_free_vars_ctx_on_ctx_free_vars. Qed. -Lemma addnP_xpredT n : addnP n xpredT =1 xpredT. +Lemma addnP_xpredT n : addnP n xpredT ≐1 xpredT. Proof using Type. now rewrite /addnP. Qed. @@ -2066,7 +2066,7 @@ Proof using Type. now rewrite inst_subst. Qed. -Instance inst_telescope_ext : Proper (`=1` ==> `=1`) inst_telescope. +Instance inst_telescope_ext : Proper (`≐1` ==> `≐1`) inst_telescope. Proof using Type. intros f g Hfg Γ. rewrite /inst_telescope. apply mapi_ext => n x. diff --git a/pcuic/theories/Conversion/PCUICNamelessConv.v b/pcuic/theories/Conversion/PCUICNamelessConv.v index 42de28a92..fc87b119d 100644 --- a/pcuic/theories/Conversion/PCUICNamelessConv.v +++ b/pcuic/theories/Conversion/PCUICNamelessConv.v @@ -937,7 +937,7 @@ Proof. Qed. Lemma map_anon_fold_context_k g g' ctx : - (forall i, nl ∘ g i =1 g' i ∘ nl) -> + (forall i, nl ∘ g i ≐1 g' i ∘ nl) -> map (map_decl_anon nl) (fold_context_k g ctx) = fold_context_k g' (map (map_decl_anon nl) ctx). Proof. diff --git a/pcuic/theories/Conversion/PCUICRenameConv.v b/pcuic/theories/Conversion/PCUICRenameConv.v index bef2d4533..e391ea2ff 100644 --- a/pcuic/theories/Conversion/PCUICRenameConv.v +++ b/pcuic/theories/Conversion/PCUICRenameConv.v @@ -417,8 +417,8 @@ Qed. Lemma urenaming_ext : forall P P' Γ Δ f g, - P =1 P' -> - f =1 g -> + P ≐1 P' -> + f ≐1 g -> urenaming P Δ Γ f -> urenaming P' Δ Γ g. Proof using Type. @@ -438,7 +438,7 @@ Proof using Type. Qed. Lemma renaming_extP P P' Σ Γ Δ f : - P =1 P' -> + P ≐1 P' -> renaming P Σ Γ Δ f -> renaming P' Σ Γ Δ f. Proof using Type. intros hP; rewrite /renaming. @@ -646,7 +646,7 @@ Qed. End Renaming. -#[global] Instance rename_context_ext : Proper (`=1` ==> Logic.eq ==> Logic.eq) rename_context. +#[global] Instance rename_context_ext : Proper (`≐1` ==> Logic.eq ==> Logic.eq) rename_context. Proof. intros f g Hfg x y ->. apply fold_context_k_ext => i t. diff --git a/pcuic/theories/PCUICAst.v b/pcuic/theories/PCUICAst.v index 37d32c787..e5c5385bf 100644 --- a/pcuic/theories/PCUICAst.v +++ b/pcuic/theories/PCUICAst.v @@ -616,7 +616,7 @@ Lemma map_predicate_eq_spec {A B} (finst finst' : Instance.t -> Instance.t) (f f' g g' : A -> B) h h' (p : predicate A) : finst (puinst p) = finst' (puinst p) -> map f (pparams p) = map g (pparams p) -> - h =1 h' -> + h ≐1 h' -> f' (preturn p) = g' (preturn p) -> map_predicate finst f f' h p = map_predicate finst' g g' h' p. Proof. @@ -709,7 +709,7 @@ Qed. #[global] Instance map_predicate_proper {term} : - Proper (`=1` ==> `=1` ==> `=1` ==> Logic.eq ==> Logic.eq)%signature (@map_predicate term term id). + Proper (`≐1` ==> `≐1` ==> `≐1` ==> Logic.eq ==> Logic.eq)%signature (@map_predicate term term id). Proof. intros eqf0 eqf1 eqf. intros eqf'0 eqf'1 eqf' h h' eqh'. @@ -719,7 +719,7 @@ Proof. Qed. #[global] -Instance map_predicate_proper' {term} f : Proper (`=1` ==> `=1` ==> Logic.eq ==> Logic.eq) +Instance map_predicate_proper' {term} f : Proper (`≐1` ==> `≐1` ==> Logic.eq ==> Logic.eq) (@map_predicate term term id f). Proof. intros eqf0 eqf1 eqf h h' eqh'. @@ -727,7 +727,7 @@ Proof. apply map_predicate_eq_spec; auto. Qed. -Lemma shiftf0 {A B} (f : nat -> A -> B) : shiftf f 0 =2 f. +Lemma shiftf0 {A B} (f : nat -> A -> B) : shiftf f 0 ≐2 f. Proof. intros x. unfold shiftf. now rewrite Nat.add_0_r. Qed. #[global] @@ -871,7 +871,7 @@ Qed. Lemma map_branch_eq_spec {A B} (f g : A -> B) h h' (x : branch A) : f (bbody x) = g (bbody x) -> - h =1 h' -> + h ≐1 h' -> map_branch f h x = map_branch g h' x. Proof. intros. unfold map_branch; f_equal; auto. @@ -880,7 +880,7 @@ Qed. Lemma map_branch_k_eq_spec {A B} (f g : nat -> A -> B) h h' k k' (x : branch A) : shiftf f k #|x.(bcontext)| (bbody x) = shiftf g k' #|x.(bcontext)| (bbody x) -> - h =1 h' -> + h ≐1 h' -> map_branch_k f h k x = map_branch_k g h' k' x. Proof. intros. unfold map_branch_k; f_equal; auto. @@ -888,7 +888,7 @@ Qed. #[global] Hint Resolve map_branch_eq_spec : all. #[global] -Instance map_branch_proper {term} : Proper (`=1` ==> `=1` ==> Logic.eq ==> Logic.eq) +Instance map_branch_proper {term} : Proper (`≐1` ==> `≐1` ==> Logic.eq ==> Logic.eq) (@map_branch term term). Proof. intros eqf0 eqf1 eqf h h' eqh'. @@ -896,7 +896,7 @@ Proof. apply map_branch_eq_spec; auto. Qed. -Lemma id_id {A} : @id A =1 id. +Lemma id_id {A} : @id A ≐1 id. Proof. now intros x. Qed. #[global] Hint Resolve id_id : core. @@ -932,7 +932,7 @@ Proof. Qed. Lemma mapu_prim_compose {term term' term''} - f (g : term' -> term'') f' (g' : term -> term') : mapu_prim f g ∘ mapu_prim f' g' =1 mapu_prim (f ∘ f') (g ∘ g'). + f (g : term' -> term'') f' (g' : term -> term') : mapu_prim f g ∘ mapu_prim f' g' ≐1 mapu_prim (f ∘ f') (g ∘ g'). Proof. intros [? []]; cbn => //. do 3 f_equal. unfold mapu_array_model; destruct a => //=. now rewrite map_map_compose. @@ -952,14 +952,14 @@ Proof. Qed. Lemma mapu_array_model_proper {term term'} (l l' : Level.t -> Level.t) (f g : term -> term') a : - l =1 l' -> f =1 g -> + l ≐1 l' -> f ≐1 g -> mapu_array_model l f a = mapu_array_model l' g a. Proof. destruct a; cbn ; rewrite /mapu_array_model /=. intros; f_equal; eauto. now eapply map_ext. Qed. Lemma mapu_array_model_proper_cond {term term'} (P : term -> Type) (l l' : Level.t -> Level.t) (f g : term -> term') a : - l =1 l' -> (forall x, P x -> f x = g x) -> + l ≐1 l' -> (forall x, P x -> f x = g x) -> P a.(array_type) × P a.(array_default) × All P a.(array_value) -> mapu_array_model l f a = mapu_array_model l' g a. Proof. @@ -969,7 +969,7 @@ Qed. Lemma primProp_map_eq {term term'} P p l l' (f g : term -> term') : tPrimProp P p -> - l =1 l' -> + l ≐1 l' -> (forall x, P x -> f x = g x) -> mapu_prim l f p = mapu_prim l' g p. Proof. @@ -1100,7 +1100,7 @@ Qed. Lemma case_brs_map_spec {A B} {P : A -> Type} {l} {f g : A -> B} {h h' : list (BasicAst.context_decl A) -> list (BasicAst.context_decl B)} : - tCaseBrsProp P l -> (forall x, P x -> f x = g x) -> h =1 h' -> + tCaseBrsProp P l -> (forall x, P x -> f x = g x) -> h ≐1 h' -> map_branches f h l = map_branches g h' l. Proof. intros. red in X. @@ -1212,7 +1212,7 @@ Proof. Qed. Lemma test_context_k_eq_spec (p q : nat -> term -> bool) k k' {ctx} : - (p =2 q) -> + (p ≐2 q) -> k = k' -> test_context_k p k ctx = test_context_k q k' ctx. Proof. @@ -1229,14 +1229,14 @@ Proof. Qed. #[global] -Instance test_context_k_Proper : Proper (`=2` ==> Logic.eq ==> `=1`) (@test_context_k term). +Instance test_context_k_Proper : Proper (`≐2` ==> Logic.eq ==> `≐1`) (@test_context_k term). Proof. intros f g Hfg k k' <- ctx. now apply test_context_k_eq_spec. Qed. #[global] -Instance test_predicate_k_Proper : Proper (`=1` ==> `=2` ==> Logic.eq ==> `=1`) (@test_predicate_k term). +Instance test_predicate_k_Proper : Proper (`≐1` ==> `≐2` ==> Logic.eq ==> `≐1`) (@test_predicate_k term). Proof. intros hi hi' eqhi f g Hfg k k' <- ctx. unfold test_predicate_k. rewrite eqhi. @@ -1244,7 +1244,7 @@ Proof. Qed. #[global] -Instance test_predicate_ku_Proper : Proper (`=2` ==> `=2` ==> Logic.eq ==> `=1`) (@test_predicate_ku term). +Instance test_predicate_ku_Proper : Proper (`≐2` ==> `≐2` ==> Logic.eq ==> `≐1`) (@test_predicate_ku term). Proof. intros hi hi' eqhi f g Hfg k k' <- ctx. unfold test_predicate_ku. rewrite eqhi. @@ -1252,7 +1252,7 @@ Proof. Qed. #[global] -Instance test_branch_k_Proper p : Proper (`=2` ==> Logic.eq ==> `=1`) (@test_branch_k term p). +Instance test_branch_k_Proper p : Proper (`≐2` ==> Logic.eq ==> `≐1`) (@test_branch_k term p). Proof. intros f g Hfg k k' <- ctx. unfold test_branch_k. @@ -1264,7 +1264,7 @@ Lemma case_brs_map_spec_cond {A B} {P : A -> Type} pctx p {l} {f g : A -> B} {h forallb (test_branch pctx p) l -> (forall x, P x -> p x -> f x = g x) -> (* (forall ctx, onctx P ctx -> test_context pctx ctx -> h ctx = h' ctx) -> *) - h =1 h' -> + h ≐1 h' -> map_branches f h l = map_branches g h' l. Proof. intros. red in X. @@ -1279,7 +1279,7 @@ Qed. Lemma case_brs_map_k_spec {A B} {P : A -> Type} {k l} {f g : nat -> A -> B} {h h'} : tCaseBrsProp P l -> (forall k x, P x -> f k x = g k x) -> - h =1 h' -> + h ≐1 h' -> map_branches_k f h k l = map_branches_k g h' k l. Proof. intros. red in X. @@ -1293,7 +1293,7 @@ Lemma case_brs_forallb_map_spec {A B} {P : A -> Type} {pctx p : A -> bool} tCaseBrsProp P l -> forallb (test_branch pctx p) l -> (forall x, P x -> p x -> f x = g x) -> - h =1 h' -> + h ≐1 h' -> map (map_branch f h) l = map (map_branch g h') l. Proof. intros. diff --git a/pcuic/theories/PCUICContextReduction.v b/pcuic/theories/PCUICContextReduction.v index 98c53be9c..e8d2802f0 100644 --- a/pcuic/theories/PCUICContextReduction.v +++ b/pcuic/theories/PCUICContextReduction.v @@ -280,7 +280,7 @@ Section CtxReduction. let k := Nat.pred #|ctx| - #|Γ| in P k ==> on_free_vars_decl (addnP (S k) P) d) ctx. - Lemma addnP_closedP n P : addnP 1 (closedP (S n) P) =1 closedP n (addnP 1 P). + Lemma addnP_closedP n P : addnP 1 (closedP (S n) P) ≐1 closedP n (addnP 1 P). Proof using Type. intros i. rewrite /addnP /closedP /shiftnP /=. repeat (PCUICSigmaCalculus.nat_compare_specs => //). diff --git a/pcuic/theories/PCUICExpandLetsCorrectness.v b/pcuic/theories/PCUICExpandLetsCorrectness.v index b893ca03d..16f424cde 100644 --- a/pcuic/theories/PCUICExpandLetsCorrectness.v +++ b/pcuic/theories/PCUICExpandLetsCorrectness.v @@ -363,7 +363,7 @@ Proof. Qed. Lemma expand_lets_subst_comm Γ k s : - expand_lets (subst_context s k Γ) ∘ subst s (#|Γ| + k) =1 + expand_lets (subst_context s k Γ) ∘ subst s (#|Γ| + k) ≐1 subst s (context_assumptions Γ + k) ∘ expand_lets Γ. Proof. unfold expand_lets, expand_lets_k; simpl; intros x. len. @@ -3908,7 +3908,7 @@ Proof. Qed. Lemma fold_right_ext {A B} {f g : B -> A -> A} {acc l} : - f =2 g -> + f ≐2 g -> fold_right f acc l = fold_right g acc l. Proof. induction l; cbn; auto => Hfg. now rewrite IHl. diff --git a/pcuic/theories/PCUICInductiveInversion.v b/pcuic/theories/PCUICInductiveInversion.v index 0c66b9369..237cadfdd 100644 --- a/pcuic/theories/PCUICInductiveInversion.v +++ b/pcuic/theories/PCUICInductiveInversion.v @@ -3372,7 +3372,7 @@ Lemma subst_let_expand_app s Γ s' Δ k : #|s| = context_assumptions Γ -> subst0 s ∘ subst0 (map (lift0 #|s|) s') ∘ - (expand_lets (expand_lets_ctx Γ Δ) ∘ expand_lets_k Γ k) =1 + (expand_lets (expand_lets_ctx Γ Δ) ∘ expand_lets_k Γ k) ≐1 subst_let_expand (s' ++ s) (Γ ,,, Δ). Proof. intros hk hs t. diff --git a/pcuic/theories/PCUICInductives.v b/pcuic/theories/PCUICInductives.v index b93d3ca9a..aa9ced724 100644 --- a/pcuic/theories/PCUICInductives.v +++ b/pcuic/theories/PCUICInductives.v @@ -2146,7 +2146,7 @@ Proof. Qed. Lemma subst_let_expand_k_0 s Γ : - subst_let_expand_k s Γ 0 =1 subst_let_expand s Γ. + subst_let_expand_k s Γ 0 ≐1 subst_let_expand s Γ. Proof. reflexivity. Qed. diff --git a/pcuic/theories/PCUICParallelReduction.v b/pcuic/theories/PCUICParallelReduction.v index bd3c1037f..372997b37 100644 --- a/pcuic/theories/PCUICParallelReduction.v +++ b/pcuic/theories/PCUICParallelReduction.v @@ -978,7 +978,7 @@ Section ParallelWeakening. simpl. rewrite - IHn. f_equal. apply H. Qed. - Lemma lift_rename' n k : lift n k =1 rename (lift_renaming n k). + Lemma lift_rename' n k : lift n k ≐1 rename (lift_renaming n k). Proof. intros t; apply lift_rename. Qed. Lemma lift_iota_red n k pars p args br : @@ -1722,10 +1722,10 @@ Section ParallelSubstitution. Proof. now intros -> ->. Qed. Lemma pred1_subst_ext (P P' Q Q' : nat -> bool) Γ Γ' Δ Δ' σ σ' τ τ' : - P =1 P' -> - Q =1 Q' -> - σ =1 σ' -> - τ =1 τ' -> + P ≐1 P' -> + Q ≐1 Q' -> + σ ≐1 σ' -> + τ ≐1 τ' -> pred1_subst P Q Γ Γ' Δ Δ' σ τ <~> pred1_subst P' Q' Γ Γ' Δ Δ' σ' τ'. Proof. intros HP HQ Hσ Hτ. @@ -1747,7 +1747,7 @@ Section ParallelSubstitution. eapply simpl_pred. 2:rewrite Hτ; trea. rewrite Hσ. reflexivity. assumption. Qed. - Lemma shiftk_shift : ↑ =1 ↑^1. + Lemma shiftk_shift : ↑ ≐1 ↑^1. Proof. reflexivity. Qed. Lemma pred1_subst_Up {wfΣ : wf Σ} (P Q : nat -> bool) (Γ Γ' : context) (na : aname) (t0 t1 : term) (Δ Δ' : context) (σ τ : nat -> term) : diff --git a/pcuic/theories/PCUICParallelReductionConfluence.v b/pcuic/theories/PCUICParallelReductionConfluence.v index 5eaecd145..711fab2ad 100644 --- a/pcuic/theories/PCUICParallelReductionConfluence.v +++ b/pcuic/theories/PCUICParallelReductionConfluence.v @@ -1141,7 +1141,7 @@ Section Rho. | None => nth_error Δ (r x) = None end. - Instance renaming_ext Γ Δ : Morphisms.Proper (`=1` ==> iff)%signature (renaming Γ Δ). + Instance renaming_ext Γ Δ : Morphisms.Proper (`≐1` ==> iff)%signature (renaming Γ Δ). Proof using Type. red. red. intros. split; intros. diff --git a/pcuic/theories/PCUICSR.v b/pcuic/theories/PCUICSR.v index 68081baa7..754bc9dc9 100644 --- a/pcuic/theories/PCUICSR.v +++ b/pcuic/theories/PCUICSR.v @@ -300,7 +300,7 @@ Qed. Lemma to_extended_list_set_binder_name brctx Γ : All2 (fun (x : binder_annot name) (y : context_decl) => eq_binder_annot x (decl_name y)) brctx Γ -> - to_extended_list_k (map2 set_binder_name brctx Γ) =1 to_extended_list_k Γ. + to_extended_list_k (map2 set_binder_name brctx Γ) ≐1 to_extended_list_k Γ. Proof. now intros hl x; eapply reln_set_binder_name. Qed. @@ -1207,7 +1207,7 @@ Proof. now apply onParams in onmind. Qed. -Lemma closedP_shiftnP_eq k : closedP k xpredT =1 shiftnP k xpred0. +Lemma closedP_shiftnP_eq k : closedP k xpredT ≐1 shiftnP k xpred0. Proof. rewrite /closedP /shiftnP. intros i; nat_compare_specs => //. Qed. diff --git a/pcuic/theories/PCUICSigmaCalculus.v b/pcuic/theories/PCUICSigmaCalculus.v index 166b38f62..3d172ace4 100644 --- a/pcuic/theories/PCUICSigmaCalculus.v +++ b/pcuic/theories/PCUICSigmaCalculus.v @@ -135,12 +135,12 @@ Proof. Qed. #[global] -Instance shiftn_proper : Proper (Logic.eq ==> `=1` ==> `=1`) shiftn. +Instance shiftn_proper : Proper (Logic.eq ==> `≐1` ==> `≐1`) shiftn. Proof. intros x y -> f g Hfg ?. now apply shiftn_ext. Qed. -Lemma shiftn_id i : shiftn i id =1 id. +Lemma shiftn_id i : shiftn i id ≐1 id. Proof. intros k; rewrite /shiftn. nat_compare_specs => /= //. rewrite /id. lia. @@ -185,7 +185,7 @@ Proof. Qed. #[global] Hint Resolve map_branch_shift_id_spec : all. -Lemma rename_ext f f' : (f =1 f') -> (rename f =1 rename f'). +Lemma rename_ext f f' : (f ≐1 f') -> (rename f ≐1 rename f'). Proof. unfold pointwise_relation. intros H t. revert f f' H. @@ -200,17 +200,17 @@ Qed. Notation rename_branch := (map_branch_shift rename shiftn). #[global] -Instance rename_proper : Proper (`=1` ==> Logic.eq ==> Logic.eq) rename. +Instance rename_proper : Proper (`≐1` ==> Logic.eq ==> Logic.eq) rename. Proof. intros f f' Hff' t t' ->. now apply rename_ext. Qed. #[global] -Instance rename_proper_pointwise : Proper (`=1` ==> pointwise_relation _ Logic.eq) rename. +Instance rename_proper_pointwise : Proper (`≐1` ==> pointwise_relation _ Logic.eq) rename. Proof. intros f f' Hff' t. now apply rename_ext. Qed. Lemma map_predicate_shift_proper {T} (fn : (nat -> T) -> term -> term) shift : - Proper (`=1` ==> `=1`) fn -> - Proper (Logic.eq ==> `=1` ==> `=1`) shift -> - Proper (`=1` ==> `=1` ==> `=1`) (map_predicate_shift fn shift). + Proper (`≐1` ==> `≐1`) fn -> + Proper (Logic.eq ==> `≐1` ==> `≐1`) shift -> + Proper (`≐1` ==> `≐1` ==> `≐1`) (map_predicate_shift fn shift). Proof. intros Hfn Hshift finst finst' Hfinst f g Hfg p. apply map_predicate_shift_eq_spec. @@ -220,16 +220,16 @@ Proof. Qed. #[global] -Instance rename_predicate_proper : Proper (`=1` ==> `=1`) rename_predicate. +Instance rename_predicate_proper : Proper (`≐1` ==> `≐1`) rename_predicate. Proof. apply map_predicate_shift_proper; try tc. now intros x. Qed. Lemma map_branch_shift_proper {T} (fn : (nat -> T) -> term -> term) shift : - Proper (`=1` ==> `=1`) fn -> - Proper (Logic.eq ==> `=1` ==> `=1`) shift -> - Proper (`=1` ==> `=1`) (map_branch_shift fn shift). + Proper (`≐1` ==> `≐1`) fn -> + Proper (Logic.eq ==> `≐1` ==> `≐1`) shift -> + Proper (`≐1` ==> `≐1`) (map_branch_shift fn shift). Proof. intros Hfn Hshift f g Hfg x. apply map_branch_shift_eq_spec. @@ -237,19 +237,19 @@ Proof. Qed. #[global] -Instance rename_branch_proper : Proper (`=1` ==> `=1`) rename_branch. +Instance rename_branch_proper : Proper (`≐1` ==> `≐1`) rename_branch. Proof. apply map_branch_shift_proper; tc. Qed. -Lemma shiftn0 r : shiftn 0 r =1 r. +Lemma shiftn0 r : shiftn 0 r ≐1 r. Proof. intros x. unfold shiftn. destruct (Nat.ltb_spec x 0); try lia. rewrite Nat.sub_0_r. lia. Qed. -Lemma shiftnS n r : shiftn (S n) r =1 shiftn 1 (shiftn n r). +Lemma shiftnS n r : shiftn (S n) r ≐1 shiftn 1 (shiftn n r). Proof. intros x. unfold shiftn. destruct x. @@ -259,7 +259,7 @@ Proof. destruct (Nat.ltb_spec (S x) (S n)); auto; lia. Qed. -Lemma shiftn_add n m f : shiftn n (shiftn m f) =1 shiftn (n + m) f. +Lemma shiftn_add n m f : shiftn n (shiftn m f) ≐1 shiftn (n + m) f. Proof. intros i. unfold shiftn. @@ -281,7 +281,7 @@ Proof. now intros x y ->. Qed. -Lemma shiftn_rshiftk n f : shiftn n f ∘ rshiftk n =1 rshiftk n ∘ f. +Lemma shiftn_rshiftk n f : shiftn n f ∘ rshiftk n ≐1 rshiftk n ∘ f. Proof. intros i. rewrite /shiftn /rshiftk /=. nat_compare_specs. now replace (n + i - n) with i by lia. @@ -299,17 +299,17 @@ Definition lift_renaming n k := if Nat.leb k i then (* Lifted *) n + i else i. -Lemma lift_renaming_spec n k : lift_renaming n k =1 (shiftn k (rshiftk n)). +Lemma lift_renaming_spec n k : lift_renaming n k ≐1 (shiftn k (rshiftk n)). Proof. rewrite /lift_renaming /shiftn /rshiftk. intros i. repeat nat_compare_specs. Qed. -Lemma lift_renaming_0_rshift k : lift_renaming k 0 =1 rshiftk k. +Lemma lift_renaming_0_rshift k : lift_renaming k 0 ≐1 rshiftk k. Proof. reflexivity. Qed. Lemma shiftn_lift_renaming n m k : - shiftn m (lift_renaming n k) =1 lift_renaming n (m + k). + shiftn m (lift_renaming n k) ≐1 lift_renaming n (m + k). Proof. now rewrite !lift_renaming_spec shiftn_add. Qed. @@ -343,7 +343,7 @@ Qed. #[global] Hint Rewrite @lift_rename : sigma. -Lemma lift0_rename k : lift0 k =1 rename (rshiftk k). +Lemma lift0_rename k : lift0 k ≐1 rename (rshiftk k). Proof. now intros t; rewrite lift_rename lift_renaming_0_rshift. Qed. @@ -355,7 +355,7 @@ Definition up k (s : substitutionT) := if k <=? i then rename (Nat.add k) (s (i - k)) else tRel i. -Lemma shiftn_compose n f f' : shiftn n f ∘ shiftn n f' =1 shiftn n (f ∘ f'). +Lemma shiftn_compose n f f' : shiftn n f ∘ shiftn n f' ≐1 shiftn n (f ∘ f'). Proof. unfold shiftn. intros x. elim (Nat.ltb_spec x n) => H. @@ -375,7 +375,7 @@ Proof. Qed. *) Lemma mapi_context_compose f f' : - mapi_context f ∘ mapi_context f' =1 + mapi_context f ∘ mapi_context f' ≐1 mapi_context (f ∘i f'). Proof. intros x. @@ -384,7 +384,7 @@ Qed. #[global] Hint Rewrite mapi_context_compose : map. -Lemma rename_compose f f' : rename f ∘ rename f' =1 rename (f ∘ f'). +Lemma rename_compose f f' : rename f ∘ rename f' ≐1 rename (f ∘ f'). Proof. intros x. induction x in f, f' |- * using term_forall_list_ind; simpl; @@ -409,9 +409,9 @@ Lemma map_predicate_shift_map_predicate_shift {f f' : nat -> T} {p : predicate term} (compose : (nat -> T) -> (nat -> T) -> nat -> T) : - forall (shiftn0 : forall f, shift 0 f =1 f), - Proper (`=1` ==> eq ==> eq) fn -> - (forall i, fn (shift i f) ∘ fn (shift i f') =1 fn (shift i (compose f f'))) -> + forall (shiftn0 : forall f, shift 0 f ≐1 f), + Proper (`≐1` ==> eq ==> eq) fn -> + (forall i, fn (shift i f) ∘ fn (shift i f') ≐1 fn (shift i (compose f f'))) -> map_predicate_shift fn shift finst f (map_predicate_shift fn shift finst' f' p) = map_predicate_shift fn shift (finst ∘ finst') (compose f f') p. Proof. @@ -434,7 +434,7 @@ Lemma map_predicate_shift_map_predicate {p : predicate term} (compose : (nat -> T) -> (term -> term) -> (nat -> T)) : - Proper (`=1` ==> `=1`) fn -> + Proper (`≐1` ==> `≐1`) fn -> (map (fn f ∘ f') p.(pparams) = map (fn (compose f f')) p.(pparams)) -> mapi_context (fun (k : nat) (x : term) => fn (shift k f) (f' x)) p.(pcontext) = mapi_context (fun k : nat => fn (shift k (compose f f'))) p.(pcontext) -> @@ -459,7 +459,7 @@ Lemma map_predicate_shift_map_predicate_gen {p : predicate term} (compose : (nat -> T) -> (term -> term) -> (nat -> T')) : - Proper (`=1` ==> `=1`) fn -> + Proper (`≐1` ==> `≐1`) fn -> (map (fn f ∘ f') p.(pparams) = map (fn' (compose f f')) p.(pparams)) -> mapi_context (fun (k : nat) (x : term) => fn (shift k f) (f' x)) p.(pcontext) = mapi_context (fun k : nat => fn' (shift' k (compose f f'))) p.(pcontext) -> @@ -482,9 +482,9 @@ Lemma map_predicate_map_predicate_shift {p : predicate term} (compose : (term -> term) -> (nat -> T) -> (nat -> T)) : - Proper (`=1` ==> `=1`) fn -> - (forall f, f' ∘ fn f =1 fn (compose f' f)) -> - (forall k, compose f' (shift k f) =1 shift k (compose f' f)) -> + Proper (`≐1` ==> `≐1`) fn -> + (forall f, f' ∘ fn f ≐1 fn (compose f' f)) -> + (forall k, compose f' (shift k f) ≐1 shift k (compose f' f)) -> map_predicate finst' f' f' id (map_predicate_shift fn shift finst f p) = map_predicate_shift fn shift (finst' ∘ finst) (compose f' f) p. Proof. @@ -512,7 +512,7 @@ Lemma map_branch_shift_map_branch_shift {T} {shift : nat -> (nat -> T) -> nat -> T} {f f' : nat -> T} {b : branch term} (compose : (nat -> T) -> (nat -> T) -> nat -> T) : - (forall i, fn (shift i f) ∘ fn (shift i f') =1 fn (shift i (compose f f'))) -> + (forall i, fn (shift i f) ∘ fn (shift i f') ≐1 fn (shift i (compose f f'))) -> map_branch_shift fn shift f (map_branch_shift fn shift f' b) = map_branch_shift fn shift (compose f f') b. Proof. @@ -523,7 +523,7 @@ Proof. Qed. Lemma rename_branch_rename_branch f f' : - rename_branch f ∘ rename_branch f' =1 + rename_branch f ∘ rename_branch f' ≐1 rename_branch (f ∘ f'). Proof. intros br. @@ -534,7 +534,7 @@ Qed. Hint Rewrite rename_branch_rename_branch : map. Lemma rename_branches_rename_branches f f' : - rename_branches f ∘ rename_branches f' =1 + rename_branches f ∘ rename_branches f' ≐1 rename_branches (f ∘ f'). Proof. intros br. @@ -552,7 +552,7 @@ Proof. now sigma. Qed. -Lemma up_up k k' s : up k (up k' s) =1 up (k + k') s. +Lemma up_up k k' s : up k (up k' s) ≐1 up (k + k') s. Proof. red. intros x. unfold up. elim (Nat.leb_spec k x) => H. @@ -606,19 +606,19 @@ Definition subst_fn (l : list term) := | Some t => t end. -Lemma up_ext k s s' : s =1 s' -> up k s =1 up k s'. +Lemma up_ext k s s' : s ≐1 s' -> up k s ≐1 up k s'. Proof. unfold up. intros Hs t. elim (Nat.leb_spec k t) => H; auto. f_equal. apply Hs. Qed. #[global] -Instance up_proper : Proper (Logic.eq ==> `=1` ==> `=1`) up. +Instance up_proper : Proper (Logic.eq ==> `≐1` ==> `≐1`) up. Proof. intros k y <- f g. apply up_ext. Qed. -Lemma inst_ext s s' : s =1 s' -> inst s =1 inst s'. +Lemma inst_ext s s' : s ≐1 s' -> inst s ≐1 inst s'. Proof. intros Hs t. revert s s' Hs. elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; @@ -630,30 +630,30 @@ Proof. Qed. #[global] -Instance proper_inst : Proper (`=1` ==> Logic.eq ==> Logic.eq) inst. +Instance proper_inst : Proper (`≐1` ==> Logic.eq ==> Logic.eq) inst. Proof. intros f f' Hff' t t' ->. now apply inst_ext. Qed. #[global] -Instance proper_inst' : Proper (`=1` ==> `=1`) inst. +Instance proper_inst' : Proper (`≐1` ==> `≐1`) inst. Proof. intros f f' Hff' t. now apply inst_ext. Qed. #[global] -Instance up_proper' k : Proper (`=1` ==> `=1`) (up k). +Instance up_proper' k : Proper (`≐1` ==> `≐1`) (up k). Proof. reduce_goal. now apply up_ext. Qed. #[global] -Instance inst_predicate_proper : Proper (`=1` ==> `=1`) inst_predicate. +Instance inst_predicate_proper : Proper (`≐1` ==> `≐1`) inst_predicate. Proof. apply map_predicate_shift_proper; try tc. now intros x. Qed. #[global] -Instance inst_branch_proper : Proper (`=1` ==> `=1`) inst_branch. +Instance inst_branch_proper : Proper (`≐1` ==> `≐1`) inst_branch. Proof. apply map_branch_shift_proper; try tc. Qed. @@ -662,19 +662,19 @@ Definition ren (f : renamingT) : substitutionT := fun i => tRel (f i). #[global] -Instance ren_ext : Morphisms.Proper (`=1` ==> `=1`)%signature ren. +Instance ren_ext : Morphisms.Proper (`≐1` ==> `≐1`)%signature ren. Proof. reduce_goal. unfold ren. now rewrite H. Qed. -Lemma ren_shiftn n f : up n (ren f) =1 ren (shiftn n f). +Lemma ren_shiftn n f : up n (ren f) ≐1 ren (shiftn n f). Proof. unfold ren, up, shiftn. intros i. elim (Nat.ltb_spec i n) => H; elim (Nat.leb_spec n i) => H'; try lia; trivial. Qed. -Lemma rename_inst f : rename f =1 inst (ren f). +Lemma rename_inst f : rename f ≐1 inst (ren f). Proof. intros t. revert f. elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; @@ -715,7 +715,7 @@ Definition subst_cons (t : term) (f : substitutionT) := Notation " t ⋅ s " := (subst_cons t s) (at level 70) : sigma_scope. #[global] -Instance subst_cons_proper : Proper (Logic.eq ==> `=1` ==> `=1`) subst_cons. +Instance subst_cons_proper : Proper (Logic.eq ==> `≐1` ==> `≐1`) subst_cons. Proof. intros x y -> f f' Hff'. intros i. destruct i; simpl; trivial. Qed. Definition shift : substitutionT := tRel ∘ S. @@ -727,7 +727,7 @@ Definition subst_compose (σ τ : substitutionT) := Infix "∘s" := subst_compose (at level 40) : sigma_scope. #[global] -Instance subst_compose_proper : Proper (`=1` ==> `=1` ==> `=1`) subst_compose. +Instance subst_compose_proper : Proper (`≐1` ==> `≐1` ==> `≐1`) subst_compose. Proof. intros f f' Hff' g g' Hgg'. intros x. unfold subst_compose. now rewrite Hgg' Hff'. @@ -737,13 +737,13 @@ Definition Up σ : substitutionT := tRel 0 ⋅ (σ ∘s ↑). Notation "⇑ s" := (Up s) (at level 20). #[global] -Instance Up_ext : Proper (`=1` ==> `=1`) Up. +Instance Up_ext : Proper (`≐1` ==> `≐1`) Up. Proof. unfold Up. reduce_goal. unfold subst_compose, subst_cons. destruct a => //. now rewrite H. Qed. -Lemma up_Up σ : up 1 σ =1 ⇑ σ. +Lemma up_Up σ : up 1 σ ≐1 ⇑ σ. Proof. unfold up. intros i. @@ -764,13 +764,13 @@ Definition ids (x : nat) := tRel x. Definition ren_id (x : nat) := x. -Lemma ren_id_ids : ren ren_id =1 ids. +Lemma ren_id_ids : ren ren_id ≐1 ids. Proof. reflexivity. Qed. -Lemma shiftn_ren_id n : shiftn n ren_id =1 ren_id. +Lemma shiftn_ren_id n : shiftn n ren_id ≐1 ren_id. Proof. apply shiftn_id. Qed. -Lemma rename_ren_id : rename ren_id =1 id. +Lemma rename_ren_id : rename ren_id ≐1 id. Proof. intros t. unfold id. elim t using term_forall_list_ind; simpl in |- *; intros; try easy ; @@ -797,12 +797,12 @@ Qed. #[global] Hint Rewrite subst_ids : sigma. -Lemma compose_ids_r σ : σ ∘s ids =1 σ. +Lemma compose_ids_r σ : σ ∘s ids ≐1 σ. Proof. unfold subst_compose. intros i; apply subst_ids. Qed. -Lemma compose_ids_l σ : ids ∘s σ =1 σ. +Lemma compose_ids_l σ : ids ∘s σ ≐1 σ. Proof. reflexivity. Qed. #[global] @@ -811,7 +811,7 @@ Hint Rewrite compose_ids_r compose_ids_l : sigma. Definition shiftk (k : nat) (x : nat) := tRel (k + x). Notation "↑^ k" := (shiftk k) (at level 30, k at level 2, format "↑^ k") : sigma_scope. -Lemma shiftk_0 : shiftk 0 =1 ids. +Lemma shiftk_0 : shiftk 0 ≐1 ids. Proof. intros i. reflexivity. Qed. @@ -825,7 +825,7 @@ Definition subst_consn {A} (l : list A) (σ : nat -> A) := Notation " t ⋅n s " := (subst_consn t s) (at level 40) : sigma_scope. -Lemma subst_consn_nil {A} (σ : nat -> A) : nil ⋅n σ =1 σ. +Lemma subst_consn_nil {A} (σ : nat -> A) : nil ⋅n σ ≐1 σ. Proof. intros i. unfold subst_consn. rewrite nth_error_nil. now rewrite Nat.sub_0_r. @@ -833,25 +833,25 @@ Qed. #[global] Hint Rewrite @subst_consn_nil : sigma. -Lemma subst_consn_subst_cons t l σ : (t :: l) ⋅n σ =1 (t ⋅ subst_consn l σ). +Lemma subst_consn_subst_cons t l σ : (t :: l) ⋅n σ ≐1 (t ⋅ subst_consn l σ). Proof. intros i. unfold subst_consn. induction i; simpl; trivial. Qed. -Lemma subst_consn_tip t σ : [t] ⋅n σ =1 (t ⋅ σ). +Lemma subst_consn_tip t σ : [t] ⋅n σ ≐1 (t ⋅ σ). Proof. now rewrite subst_consn_subst_cons subst_consn_nil. Qed. #[global] Hint Rewrite @subst_consn_tip : sigma. #[global] -Instance subst_consn_proper {A} : Proper (Logic.eq ==> `=1` ==> `=1`) (@subst_consn A). +Instance subst_consn_proper {A} : Proper (Logic.eq ==> `≐1` ==> `≐1`) (@subst_consn A). Proof. intros ? l -> f f' Hff' i. unfold subst_consn. destruct nth_error eqn:Heq; auto. Qed. #[global] -Instance subst_consn_proper_ext {A} : Proper (Logic.eq ==> `=1` ==> Logic.eq ==> Logic.eq) (@subst_consn A). +Instance subst_consn_proper_ext {A} : Proper (Logic.eq ==> `≐1` ==> Logic.eq ==> Logic.eq) (@subst_consn A). Proof. intros ? l -> f f' Hff' i i' <-. unfold subst_consn. destruct nth_error eqn:Heq; auto. @@ -871,15 +871,15 @@ Definition subst_cons_gen {A} (t : A) (f : nat -> A) := end. #[global] -Instance subst_cons_gen_proper {A} : Proper (Logic.eq ==> `=1` ==> `=1`) (@subst_cons_gen A). +Instance subst_cons_gen_proper {A} : Proper (Logic.eq ==> `≐1` ==> `≐1`) (@subst_cons_gen A). Proof. intros x y <- f g Hfg i. destruct i; simpl; auto. Qed. -Lemma subst_consn_subst_cons_gen {A} (t : A) l σ : subst_consn (t :: l) σ =1 (subst_cons_gen t (l ⋅n σ)). +Lemma subst_consn_subst_cons_gen {A} (t : A) l σ : subst_consn (t :: l) σ ≐1 (subst_cons_gen t (l ⋅n σ)). Proof. intros i. unfold subst_consn. induction i; simpl; trivial. Qed. -Lemma subst_consn_app {A} {l l' : list A} {σ} : (l ++ l') ⋅n σ =1 l ⋅n (l' ⋅n σ). +Lemma subst_consn_app {A} {l l' : list A} {σ} : (l ++ l') ⋅n σ ≐1 l ⋅n (l' ⋅n σ). Proof. induction l; simpl; auto. - now rewrite subst_consn_nil. @@ -1026,16 +1026,16 @@ Lemma subst_cons_shift t σ : ↑ ∘s (t ⋅ σ) = σ. Proof. reflexivity. Qed. #[global] Hint Rewrite subst_cons_0 subst_cons_shift : sigma. -Lemma shiftk_shift n : ↑^(S n) =1 ↑^n ∘s ↑. Proof. reflexivity. Qed. +Lemma shiftk_shift n : ↑^(S n) ≐1 ↑^n ∘s ↑. Proof. reflexivity. Qed. -Lemma shiftk_shift_l n : ↑^(S n) =1 ↑ ∘s ↑^n. +Lemma shiftk_shift_l n : ↑^(S n) ≐1 ↑ ∘s ↑^n. Proof. intros i. unfold shiftk. unfold subst_compose, shift. simpl. f_equal. lia. Qed. -Lemma subst_subst_consn s σ τ : (s ⋅ σ) ∘s τ =1 (s.[τ] ⋅ σ ∘s τ). +Lemma subst_subst_consn s σ τ : (s ⋅ σ) ∘s τ ≐1 (s.[τ] ⋅ σ ∘s τ). Proof. intros i. destruct i; simpl; reflexivity. @@ -1048,18 +1048,18 @@ Definition Upn n σ := idsn n ⋅n (σ ∘s ↑^n). Notation "⇑^ n σ" := (Upn n σ) (at level 30, n at level 2, format "⇑^ n σ") : sigma_scope. #[global] -Instance Upn_ext n : Proper (`=1` ==> `=1`) (Upn n). +Instance Upn_ext n : Proper (`≐1` ==> `≐1`) (Upn n). Proof. unfold Upn. reduce_goal. now rewrite H. Qed. -Lemma Upn_0 σ : ⇑^0 σ =1 σ. +Lemma Upn_0 σ : ⇑^0 σ ≐1 σ. Proof. unfold Upn. simpl. now rewrite subst_consn_nil shiftk_0 compose_ids_r. Qed. -Lemma Upn_1_Up σ : ⇑^1 σ =1 ⇑ σ. +Lemma Upn_1_Up σ : ⇑^1 σ ≐1 ⇑ σ. Proof. unfold Upn. intros i. destruct i; auto. @@ -1071,7 +1071,7 @@ Hint Rewrite Upn_1_Up : sigma. Lemma Upn_eq n σ : Upn n σ = idsn n ⋅n (σ ∘s ↑^n). Proof. reflexivity. Qed. -Lemma Upn_proper : Proper (Logic.eq ==> `=1` ==> `=1`) Upn. +Lemma Upn_proper : Proper (Logic.eq ==> `≐1` ==> `≐1`) Upn. Proof. intros ? ? -> f g Hfg. unfold Upn. now rewrite Hfg. Qed. (** The σ-calculus equations for Rocq *) @@ -1094,7 +1094,7 @@ Proof. simpl. now rewrite up_Up. Qed. -Lemma up_Upn {n σ} : up n σ =1 ⇑^n σ. +Lemma up_Upn {n σ} : up n σ ≐1 ⇑^n σ. Proof. unfold up, Upn. intros i. @@ -1105,7 +1105,7 @@ Proof. rewrite (subst_consn_lt Hle) /subst_fn idsn_lt //. Qed. -Lemma Upn_ren k f : ⇑^k ren f =1 ren (shiftn k f). +Lemma Upn_ren k f : ⇑^k ren f ≐1 ren (shiftn k f). Proof. now rewrite -up_Upn ren_shiftn. Qed. @@ -1139,10 +1139,10 @@ Hint Rewrite @inst_app @inst_lam @inst_prod @inst_letin @inst_fix @inst_cofix @inst_mkApps : sigma. -Lemma ren_shift : ↑ =1 ren S. +Lemma ren_shift : ↑ ≐1 ren S. Proof. reflexivity. Qed. -Lemma compose_ren f g : ren f ∘s ren g =1 ren (g ∘ f). +Lemma compose_ren f g : ren f ∘s ren g ≐1 ren (g ∘ f). Proof. intros i. destruct i; simpl; reflexivity. @@ -1150,19 +1150,19 @@ Qed. #[global] Hint Rewrite compose_ren : sigma. -Lemma subst_cons_ren i f : (tRel i ⋅ ren f) =1 ren (subst_cons_gen i f). +Lemma subst_cons_ren i f : (tRel i ⋅ ren f) ≐1 ren (subst_cons_gen i f). Proof. intros x; destruct x; auto. Qed. -Infix "=2" := (Logic.eq ==> (pointwise_relation _ Logic.eq))%signature (at level 70) : signature_scope. +Infix "≐2" := (Logic.eq ==> (pointwise_relation _ Logic.eq))%signature (at level 70) : signature_scope. -Lemma subst_consn_subst_cons' {A} (t : A) l : (subst_consn (t :: l) =2 ((subst_cons_gen t) ∘ (subst_consn l)))%signature. +Lemma subst_consn_subst_cons' {A} (t : A) l : (subst_consn (t :: l) ≐2 ((subst_cons_gen t) ∘ (subst_consn l)))%signature. Proof. red. intros x y <-. apply subst_consn_subst_cons_gen. Qed. -Lemma subst_consn_compose l σ' σ : l ⋅n σ' ∘s σ =1 (map (inst σ) l ⋅n (σ' ∘s σ)). +Lemma subst_consn_compose l σ' σ : l ⋅n σ' ∘s σ ≐1 (map (inst σ) l ⋅n (σ' ∘s σ)). Proof. induction l; simpl. - now sigma. @@ -1170,7 +1170,7 @@ Proof. rewrite IHl. now rewrite subst_consn_subst_cons. Qed. -Lemma subst_consn_ids_ren n f : (idsn n ⋅n ren f) =1 ren (ren_ids n ⋅n f). +Lemma subst_consn_ids_ren n f : (idsn n ⋅n ren f) ≐1 ren (ren_ids n ⋅n f). Proof. intros i. destruct (Nat.leb_spec n i). @@ -1181,12 +1181,12 @@ Proof. now rewrite (subst_consn_lt Hi) subst_ids_lt // (ren_idsn_consn_lt H). Qed. -Lemma ren_shiftk n : ren (Nat.add n) =1 ↑^n. +Lemma ren_shiftk n : ren (Nat.add n) ≐1 ↑^n. Proof. reflexivity. Qed. #[global] Hint Rewrite ren_shiftk : sigma. -Lemma ren_rshiftk k : ren (rshiftk k) =1 ↑^k. +Lemma ren_rshiftk k : ren (rshiftk k) ≐1 ↑^k. Proof. reflexivity. Qed. #[global] Hint Rewrite ren_rshiftk : sigma. @@ -1204,7 +1204,7 @@ Qed. of the substitution. *) Lemma ren_subst_consn_comm: forall (f : renamingT) (σ : substitutionT) (n : nat), - ren (subst_consn (ren_ids n) (rshiftk n ∘ f)) ∘s subst_consn (idsn n) (σ ∘s ↑^n) =1 + ren (subst_consn (ren_ids n) (rshiftk n ∘ f)) ∘s subst_consn (idsn n) (σ ∘s ↑^n) ≐1 subst_consn (idsn n) (ren f ∘s σ ∘s ↑^n). Proof. intros f σ m. @@ -1222,7 +1222,7 @@ Qed. #[global] Hint Rewrite @up_Upn : sigma. -Lemma Upn_ren_l k f σ : ⇑^k ren f ∘s ⇑^k σ =1 ⇑^k (ren f ∘s σ). +Lemma Upn_ren_l k f σ : ⇑^k ren f ∘s ⇑^k σ ≐1 ⇑^k (ren f ∘s σ). Proof. rewrite Upn_eq. rewrite -(ren_shiftk k) !compose_ren !subst_consn_ids_ren. @@ -1300,7 +1300,7 @@ Qed. Lemma inst_rename_assoc_n: forall (f : renamingT) (σ : substitutionT) (n : nat), - subst_consn (idsn n) (σ ∘s ↑^n) ∘s ren (subst_consn (ren_ids n) (Init.Nat.add n ∘ f)) =1 + subst_consn (idsn n) (σ ∘s ↑^n) ∘s ren (subst_consn (ren_ids n) (Init.Nat.add n ∘ f)) ≐1 subst_consn (idsn n) (σ ∘s ren f ∘s ↑^n). Proof. intros f σ m. rewrite -ren_shiftk. @@ -1321,7 +1321,7 @@ Proof. rewrite -rename_inst rename_idsn_idsn subst_ids_lt //. Qed. -Lemma Upn_ren_r k f σ : ⇑^k σ ∘s ⇑^k ren f =1 ⇑^k (σ ∘s ren f). +Lemma Upn_ren_r k f σ : ⇑^k σ ∘s ⇑^k ren f ≐1 ⇑^k (σ ∘s ren f). Proof. rewrite !Upn_eq. rewrite -(ren_shiftk k) !compose_ren !subst_consn_ids_ren. @@ -1364,23 +1364,23 @@ Proof. sigma. now rewrite Upn_ren b -Upn_ren Upn_ren_r. Qed. -Lemma rename_subst_compose1 r s s' : ren r ∘s (s ∘s s') =1 ren r ∘s s ∘s s'. +Lemma rename_subst_compose1 r s s' : ren r ∘s (s ∘s s') ≐1 ren r ∘s s ∘s s'. Proof. unfold subst_compose. simpl. intros i. reflexivity. Qed. -Lemma rename_subst_compose2 r s s' : s ∘s (ren r ∘s s') =1 s ∘s ren r ∘s s'. +Lemma rename_subst_compose2 r s s' : s ∘s (ren r ∘s s') ≐1 s ∘s ren r ∘s s'. Proof. unfold subst_compose. simpl. intros i. rewrite rename_inst_assoc. reflexivity. Qed. -Lemma rename_subst_compose3 r s s' : s ∘s (s' ∘s ren r) =1 s ∘s s' ∘s ren r. +Lemma rename_subst_compose3 r s s' : s ∘s (s' ∘s ren r) ≐1 s ∘s s' ∘s ren r. Proof. unfold subst_compose. simpl. intros i. rewrite inst_rename_assoc. reflexivity. Qed. Lemma Up_Up_assoc: - forall s s' : substitutionT, (⇑ s) ∘s (⇑ s') =1 ⇑ (s ∘s s'). + forall s s' : substitutionT, (⇑ s) ∘s (⇑ s') ≐1 ⇑ (s ∘s s'). Proof. intros s s'. unfold Up. @@ -1396,7 +1396,7 @@ Qed. Hint Rewrite Up_Up_assoc : sigma. Lemma up_up_assoc: - forall (s s' : substitutionT) (n : nat), up n s ∘s up n s' =1 up n (s ∘s s'). + forall (s s' : substitutionT) (n : nat), up n s ∘s up n s' ≐1 up n (s ∘s s'). Proof. intros s s' n i. unfold up, subst_compose. simpl. @@ -1446,7 +1446,7 @@ Qed. #[global] Hint Rewrite inst_assoc : sigma. -Lemma subst_compose_assoc s s' s'' : (s ∘s s') ∘s s'' =1 s ∘s (s' ∘s s''). +Lemma subst_compose_assoc s s' s'' : (s ∘s s') ∘s s'' ≐1 s ∘s (s' ∘s s''). Proof. intros i; unfold subst_compose at 1 3 4. now rewrite inst_assoc. @@ -1455,13 +1455,13 @@ Qed. #[global] Hint Rewrite subst_compose_assoc : sigma. -Lemma subst_cons_0_shift : (tRel 0 ⋅ ↑) =1 ids. +Lemma subst_cons_0_shift : (tRel 0 ⋅ ↑) ≐1 ids. Proof. intros i. destruct i; reflexivity. Qed. #[global] Hint Rewrite subst_cons_0_shift : sigma. -Lemma subst_cons_0s_shifts σ : ((σ 0) ⋅ (↑ ∘s σ)) =1 σ. +Lemma subst_cons_0s_shifts σ : ((σ 0) ⋅ (↑ ∘s σ)) ≐1 σ. Proof. intros i. destruct i; auto. Qed. @@ -1469,7 +1469,7 @@ Qed. #[global] Hint Rewrite subst_cons_0s_shifts : sigma. -Lemma Upn_Up σ n : ⇑^(S n) σ =1 ⇑^n ⇑ σ. +Lemma Upn_Up σ n : ⇑^(S n) σ ≐1 ⇑^n ⇑ σ. Proof. intros i. unfold Upn. simpl. rewrite subst_consn_app. @@ -1481,10 +1481,10 @@ Proof. - simpl. now rewrite inst_assoc. Qed. -Lemma Upn_1 σ : ⇑^1 σ =1 ⇑ σ. +Lemma Upn_1 σ : ⇑^1 σ ≐1 ⇑ σ. Proof. now rewrite Upn_Up Upn_0. Qed. -Lemma Upn_S σ n : ⇑^(S n) σ =1 ⇑ ⇑^n σ. +Lemma Upn_S σ n : ⇑^(S n) σ ≐1 ⇑ ⇑^n σ. Proof. rewrite Upn_Up. induction n in σ |- *. * rewrite !Upn_0. now eapply Up_ext. @@ -1527,7 +1527,7 @@ Proof. rewrite b. apply inst_ext. intros t'; now rewrite (up_up #|m| k). Qed. -Lemma subst_fn_subst_consn s : subst_fn s =1 subst_consn s ids. +Lemma subst_fn_subst_consn s : subst_fn s ≐1 subst_consn s ids. Proof. reflexivity. Qed. (** substitutionT is faithfully modelled by instantiation *) @@ -1542,7 +1542,7 @@ Lemma subst0_inst (s : list term) (t : term) : Proof. rewrite subst_inst. now sigma. Qed. (** Useful for point-free rewriting *) -Corollary subst_inst' s k : subst s k =1 inst (⇑^k (subst_consn s ids)). +Corollary subst_inst' s k : subst s k ≐1 inst (⇑^k (subst_consn s ids)). Proof. intros t; apply subst_inst. Qed. @@ -1570,7 +1570,7 @@ Fixpoint subst_app (t : term) (us : list term) : term := | _, _ => mkApps t us end. -Lemma subst_consn_shiftn n (l : list term) σ : #|l| = n -> ↑^n ∘s (l ⋅n σ) =1 σ. +Lemma subst_consn_shiftn n (l : list term) σ : #|l| = n -> ↑^n ∘s (l ⋅n σ) ≐1 σ. Proof. induction n in l |- *; simpl; intros; sigma. - destruct l; try discriminate. now sigma. @@ -1579,7 +1579,7 @@ Proof. simpl; sigma. apply IHn. lia. Qed. -Lemma shiftn_Upn n σ : ↑^n ∘s ⇑^n σ =1 σ ∘s ↑^n. +Lemma shiftn_Upn n σ : ↑^n ∘s ⇑^n σ ≐1 σ ∘s ↑^n. Proof. unfold Upn. rewrite subst_consn_shiftn //. now rewrite idsn_length. @@ -1601,7 +1601,7 @@ Proof. now rewrite nth_error_app_lt. Qed. -Lemma Upn_comp n l σ : n = #|l| -> ⇑^n σ ∘s (l ⋅n ids) =1 l ⋅n σ. +Lemma Upn_comp n l σ : n = #|l| -> ⇑^n σ ∘s (l ⋅n ids) ≐1 l ⋅n σ. Proof. intros ->. rewrite Upn_eq; simpl. rewrite !subst_consn_compose. sigma. @@ -1615,10 +1615,10 @@ Proof. - lia. Qed. -Lemma shift_Up_comm σ : ↑ ∘s ⇑ σ =1 σ ∘s ↑. +Lemma shift_Up_comm σ : ↑ ∘s ⇑ σ ≐1 σ ∘s ↑. Proof. reflexivity. Qed. -Lemma shiftk_compose n m : ↑^n ∘s ↑^m =1 ↑^(n + m). +Lemma shiftk_compose n m : ↑^n ∘s ↑^m ≐1 ↑^(n + m). Proof. induction n; simpl; sigma; auto. - reflexivity. @@ -1627,7 +1627,7 @@ Proof. now rewrite subst_compose_assoc IHn -shiftk_shift shiftk_shift_l. Qed. -Lemma Upn_Upn k k' σ : ⇑^(k + k') σ =1 ⇑^k (⇑^k' σ). +Lemma Upn_Upn k k' σ : ⇑^(k + k') σ ≐1 ⇑^k (⇑^k' σ). Proof. setoid_rewrite <- up_Upn. rewrite -(@up_Upn k'). symmetry; apply up_up. @@ -1635,7 +1635,7 @@ Qed. #[global] Hint Rewrite Upn_Upn : sigma. -Lemma Upn_compose n σ σ' : ⇑^n σ ∘s ⇑^n σ' =1 ⇑^n (σ ∘s σ'). +Lemma Upn_compose n σ σ' : ⇑^n σ ∘s ⇑^n σ' ≐1 ⇑^n (σ ∘s σ'). Proof. induction n. - unfold Upn. simpl. @@ -1729,7 +1729,7 @@ Proof. now rewrite hnth => [= ->]. Qed. -Lemma subst_consn_ids_rel_ren n k f : (idsn n ⋅n (tRel k ⋅ ren f) =1 ren (ren_ids n ⋅n (subst_cons_gen k f)))%sigma. +Lemma subst_consn_ids_rel_ren n k f : (idsn n ⋅n (tRel k ⋅ ren f) ≐1 ren (ren_ids n ⋅n (subst_cons_gen k f)))%sigma. Proof. intros i. destruct (Nat.leb_spec n i). @@ -1746,7 +1746,7 @@ Qed. Lemma lift_renaming_0 k : ren (lift_renaming k 0) = ren (rshiftk k). Proof. reflexivity. Qed. -Lemma ren_lift_renaming n k : ren (lift_renaming n k) =1 (⇑^k ↑^n). +Lemma ren_lift_renaming n k : ren (lift_renaming n k) ≐1 (⇑^k ↑^n). Proof. unfold subst_compose. intros i. simpl. rewrite -{1}(Nat.add_0_r k). unfold ren. rewrite - (shiftn_lift_renaming n k 0). @@ -1762,17 +1762,17 @@ Proof. now rewrite Upn_eq. Qed. -Lemma Up_comp (t : term) σ : ⇑ σ ∘s (t ⋅ ids) =1 subst_cons t σ. +Lemma Up_comp (t : term) σ : ⇑ σ ∘s (t ⋅ ids) ≐1 subst_cons t σ. Proof. rewrite /Up; simpl. now sigma. Qed. -Lemma shiftk_unfold i : (tRel i ⋅ ↑^(S i)) =1 ↑^i. +Lemma shiftk_unfold i : (tRel i ⋅ ↑^(S i)) ≐1 ↑^i. Proof. intros x; unfold subst_cons, shiftk. destruct x; lia_f_equal. Qed. -Lemma subst_cons_compose_r t σ' σ : σ ∘s (t ⋅ σ') =1 ((σ 0).[t ⋅ σ'] ⋅ (↑ ∘s σ) ∘s (t ⋅ σ')). +Lemma subst_cons_compose_r t σ' σ : σ ∘s (t ⋅ σ') ≐1 ((σ 0).[t ⋅ σ'] ⋅ (↑ ∘s σ) ∘s (t ⋅ σ')). Proof. intros [|i]. - now sigma. @@ -1781,7 +1781,7 @@ Proof. unfold shift. simpl. now rewrite /subst_compose /=. Qed. (* -Lemma subst_consn_compose_r l σ' σ : σ ∘s (l ⋅n σ') =1 map (inst (σ ∘s (subst_fn l))) l ⋅n (σ ∘s σ'). +Lemma subst_consn_compose_r l σ' σ : σ ∘s (l ⋅n σ') ≐1 map (inst (σ ∘s (subst_fn l))) l ⋅n (σ ∘s σ'). Proof. induction l; simpl. - now sigma. @@ -2001,7 +2001,7 @@ Proof. Qed. Lemma expand_lets_subst_comm Γ s : - expand_lets (subst_context s 0 Γ) ∘ subst s #|Γ| =1 subst s (context_assumptions Γ) ∘ expand_lets Γ. + expand_lets (subst_context s 0 Γ) ∘ subst s #|Γ| ≐1 subst s (context_assumptions Γ) ∘ expand_lets Γ. Proof. unfold expand_lets, expand_lets_k; simpl; intros x. len. rewrite !subst_extended_subst. @@ -2010,7 +2010,7 @@ Proof. Qed. Lemma map_expand_lets_subst_comm Γ s : - map (expand_lets (subst_context s 0 Γ)) ∘ (map (subst s #|Γ|)) =1 + map (expand_lets (subst_context s 0 Γ)) ∘ (map (subst s #|Γ|)) ≐1 map (subst s (context_assumptions Γ)) ∘ (map (expand_lets Γ)). Proof. intros l. rewrite !map_map_compose. @@ -2019,7 +2019,7 @@ Qed. Lemma map_subst_expand_lets s Γ : context_assumptions Γ = #|s| -> - subst0 (map (subst0 s) (extended_subst Γ 0)) =1 subst0 s ∘ expand_lets Γ. + subst0 (map (subst0 s) (extended_subst Γ 0)) ≐1 subst0 s ∘ expand_lets Γ. Proof. intros Hs x; unfold expand_lets, expand_lets_k. rewrite distr_subst. f_equal. @@ -2181,7 +2181,7 @@ Proof. Qed. Lemma shift_subst_consn_ge (n : nat) (l : list term) (σ : substitutionT) : - #|l| <= n -> ↑^n ∘s (l ⋅n σ) =1 ↑^(n - #|l|) ∘s σ. + #|l| <= n -> ↑^n ∘s (l ⋅n σ) ≐1 ↑^(n - #|l|) ∘s σ. Proof. intros Hlt i. rewrite /subst_compose /shiftk /=. @@ -2190,7 +2190,7 @@ Qed. Lemma skipn_subst n s σ : n <= #|s| -> - skipn n s ⋅n σ =1 ↑^(n) ∘s (s ⋅n σ). + skipn n s ⋅n σ ≐1 ↑^(n) ∘s (s ⋅n σ). Proof. intros hn i. rewrite /subst_consn /shiftk /subst_compose /=. @@ -2199,7 +2199,7 @@ Proof. rewrite List.length_skipn. lia_f_equal. Qed. -Lemma subst_shift_comm k n s : ⇑^k s ∘s ↑^n =1 ↑^n ∘s ⇑^(k+n) s. +Lemma subst_shift_comm k n s : ⇑^k s ∘s ↑^n ≐1 ↑^n ∘s ⇑^(k+n) s. Proof. now rewrite Nat.add_comm Upn_Upn shiftn_Upn. Qed. diff --git a/pcuic/theories/PCUICSpine.v b/pcuic/theories/PCUICSpine.v index 40e1758c5..9c0d28285 100644 --- a/pcuic/theories/PCUICSpine.v +++ b/pcuic/theories/PCUICSpine.v @@ -2206,7 +2206,7 @@ Section WfEnv. assumption. Qed. - Lemma shift_subst_consn_tip t : ↑ ∘s ([t] ⋅n ids) =1 ids. + Lemma shift_subst_consn_tip t : ↑ ∘s ([t] ⋅n ids) ≐1 ids. Proof using Type. rewrite /subst_consn; intros [|i] => /= //. Qed. @@ -2519,7 +2519,7 @@ Section WfEnv. Local Set SimplIsCbn. - Lemma subst_lift1 x s : (subst0 (x :: s) ∘ lift0 1) =1 subst0 s. + Lemma subst_lift1 x s : (subst0 (x :: s) ∘ lift0 1) ≐1 subst0 s. Proof using Type. intros t. erewrite <- PCUICParallelReduction.subst_skipn'. rewrite lift0_id. simpl. now rewrite skipn_S skipn_0. diff --git a/pcuic/theories/PCUICSubstitution.v b/pcuic/theories/PCUICSubstitution.v index 9d0c87243..994a52e10 100644 --- a/pcuic/theories/PCUICSubstitution.v +++ b/pcuic/theories/PCUICSubstitution.v @@ -1309,7 +1309,7 @@ Proof. now eapply typing_wf_local. Qed. -Lemma shiftnPF_closedPT (Γ : context) : shiftnP #|Γ| xpred0 =1 closedP #|Γ| xpredT. +Lemma shiftnPF_closedPT (Γ : context) : shiftnP #|Γ| xpred0 ≐1 closedP #|Γ| xpredT. Proof. intros i; rewrite /shiftnP /closedP orb_false_r. now destruct Nat.ltb. @@ -1455,7 +1455,7 @@ Section SubstitutionLemmas. now rewrite (on_ctx_free_vars_concat _ _ [_]) on_ctx_free_vars_tip /= addnP_shiftnP. Qed. - Lemma addnP_shiftnP_k k n p : addnP (k + n) (shiftnP k p) =1 addnP n p. + Lemma addnP_shiftnP_k k n p : addnP (k + n) (shiftnP k p) ≐1 addnP n p. Proof using Type. now rewrite Nat.add_comm -addnP_add addnP_shiftnP. Qed. diff --git a/pcuic/theories/PCUICUnivLevels.v b/pcuic/theories/PCUICUnivLevels.v index 0fb5d14e2..1fca95dea 100644 --- a/pcuic/theories/PCUICUnivLevels.v +++ b/pcuic/theories/PCUICUnivLevels.v @@ -98,7 +98,7 @@ Definition fresh_levels global_levels levels := now rewrite mapi_unfold. Qed. - #[global] Instance unfold_proper {A} : Proper (eq ==> `=1` ==> eq) (@unfold A). + #[global] Instance unfold_proper {A} : Proper (eq ==> `≐1` ==> eq) (@unfold A). Proof. intros x y -> f g eqfg. induction y; cbn; auto. f_equal; auto. f_equal. apply eqfg. diff --git a/pcuic/theories/Syntax/PCUICInstDef.v b/pcuic/theories/Syntax/PCUICInstDef.v index f8239ff6b..9dbbda74d 100644 --- a/pcuic/theories/Syntax/PCUICInstDef.v +++ b/pcuic/theories/Syntax/PCUICInstDef.v @@ -22,7 +22,7 @@ Open Scope sigma_scope. Definition inst_context σ (Γ : context) : context := fold_context_k (fun i => inst (⇑^i σ)) Γ. -#[global] Instance inst_context_ext : Proper (`=1` ==> Logic.eq ==> Logic.eq) inst_context. +#[global] Instance inst_context_ext : Proper (`≐1` ==> Logic.eq ==> Logic.eq) inst_context. Proof. intros f g Hfg x y ->. apply fold_context_k_ext => i t. diff --git a/pcuic/theories/Syntax/PCUICLiftSubst.v b/pcuic/theories/Syntax/PCUICLiftSubst.v index 121a91c1c..2ab1dca63 100644 --- a/pcuic/theories/Syntax/PCUICLiftSubst.v +++ b/pcuic/theories/Syntax/PCUICLiftSubst.v @@ -144,7 +144,7 @@ Proof. intros; now rewrite simpl_lift. Qed. Lemma simpl_lift_ext n k p i : i <= k + n -> k <= i -> - lift p i ∘ lift n k =1 lift (p + n) k. + lift p i ∘ lift n k ≐1 lift (p + n) k. Proof. intros ? ? ?; now apply simpl_lift. Qed. #[global] @@ -341,7 +341,7 @@ Proof. destruct H2. rewrite H2. simpl. now rewrite Nat.sub_0_r. Qed. -Lemma subst_empty_eq k : subst [] k =1 id. +Lemma subst_empty_eq k : subst [] k ≐1 id. Proof. intros x; now rewrite subst_empty. Qed. Lemma lift_to_extended_list_k Γ k : forall k', diff --git a/pcuic/theories/Syntax/PCUICOnFreeVars.v b/pcuic/theories/Syntax/PCUICOnFreeVars.v index d62e9677e..828ee2cd1 100644 --- a/pcuic/theories/Syntax/PCUICOnFreeVars.v +++ b/pcuic/theories/Syntax/PCUICOnFreeVars.v @@ -28,16 +28,16 @@ Definition shiftnP k p i := (i `=1`) (shiftnP k). +Instance shiftnP_ext k : Proper (`≐1` ==> `≐1`) (shiftnP k). Proof. intros f g Hfg i. now rewrite /shiftnP Hfg. Qed. -Lemma shiftnP0 P : shiftnP 0 P =1 P. +Lemma shiftnP0 P : shiftnP 0 P ≐1 P. Proof. rewrite /shiftnP. intros i; rewrite Nat.sub_0_r //. Qed. -Lemma shiftnP_add n k P : shiftnP n (shiftnP k P) =1 shiftnP (n + k) P. +Lemma shiftnP_add n k P : shiftnP n (shiftnP k P) ≐1 shiftnP (n + k) P. Proof. rewrite /shiftnP. intros i; repeat nat_compare_specs => // /=. lia_f_equal. Qed. -Lemma shiftnP_shiftn P f i : (shiftnP i P) ∘ (shiftn i f) =1 shiftnP i (P ∘ f). +Lemma shiftnP_shiftn P f i : (shiftnP i P) ∘ (shiftn i f) ≐1 shiftnP i (P ∘ f). Proof. intros k. rewrite !/shiftnP /shiftn. @@ -53,17 +53,17 @@ Proof. nat_compare_specs => //. apply Hi. Qed. -Lemma shiftnP_S P n : shiftnP (S n) P =1 shiftnP 1 (shiftnP n P). +Lemma shiftnP_S P n : shiftnP (S n) P ≐1 shiftnP 1 (shiftnP n P). Proof. now rewrite (shiftnP_add 1). Qed. Definition closedP (n : nat) (P : nat -> bool) := fun i => if i `=1`) (closedP n). +Instance closedP_proper n : Proper (`≐1` ==> `≐1`) (closedP n). Proof. intros f g Hfg. intros i; rewrite /closedP. now rewrite Hfg. Qed. -Lemma shiftnP_closedP k n P : shiftnP k (closedP n P) =1 closedP (k + n) (shiftnP k P). +Lemma shiftnP_closedP k n P : shiftnP k (closedP n P) ≐1 closedP (k + n) (shiftnP k P). Proof. intros i; rewrite /shiftnP /closedP. repeat nat_compare_specs => //. @@ -92,7 +92,7 @@ Fixpoint on_free_vars (p : nat -> bool) (t : term) : bool := end. Lemma on_free_vars_ext (p q : nat -> bool) t : - p =1 q -> + p ≐1 q -> on_free_vars p t = on_free_vars q t. Proof. revert p q. @@ -119,14 +119,14 @@ Proof. Qed. #[global] -Instance on_free_vars_proper : Proper (`=1` ==> Logic.eq ==> Logic.eq) on_free_vars. +Instance on_free_vars_proper : Proper (`≐1` ==> Logic.eq ==> Logic.eq) on_free_vars. Proof. intros f g Hfg ? ? ->. now apply on_free_vars_ext. Qed. #[global] -Instance on_free_vars_proper_pointwise : Proper (`=1` ==> `=1`) on_free_vars. +Instance on_free_vars_proper_pointwise : Proper (`≐1` ==> `≐1`) on_free_vars. Proof. intros f g Hfg x. now apply on_free_vars_ext. Qed. -Lemma shiftnP_xpredT n : shiftnP n xpredT =1 xpredT. +Lemma shiftnP_xpredT n : shiftnP n xpredT ≐1 xpredT. Proof. intros i; rewrite /shiftnP. nat_compare_specs => //. Qed. Lemma test_context_k_ctx p k (ctx : context) : test_context_k (fun=> p) k ctx = test_context p ctx. @@ -152,7 +152,7 @@ Proof. - unfold test_def in *. apply /andP. now rewrite shiftnP_xpredT. Qed. *) -Lemma on_free_vars_xpredT : on_free_vars xpredT =1 xpredT. +Lemma on_free_vars_xpredT : on_free_vars xpredT ≐1 xpredT. Proof. intros t; apply on_free_vars_true. Qed. *) @@ -237,18 +237,18 @@ Definition on_free_vars_decl P d := test_decl (on_free_vars P) d. #[global] -Instance on_free_vars_decl_proper : Proper (`=1` ==> Logic.eq ==> Logic.eq) on_free_vars_decl. +Instance on_free_vars_decl_proper : Proper (`≐1` ==> Logic.eq ==> Logic.eq) on_free_vars_decl. Proof. rewrite /on_free_vars_decl => f g Hfg x y <-. now rewrite Hfg. Qed. #[global] -Instance on_free_vars_decl_proper_pointwise : Proper (`=1` ==> `=1`) on_free_vars_decl. +Instance on_free_vars_decl_proper_pointwise : Proper (`≐1` ==> `≐1`) on_free_vars_decl. Proof. rewrite /on_free_vars_decl => f g Hfg x. now rewrite Hfg. Qed. Definition on_free_vars_ctx P ctx := alli (fun k => (on_free_vars_decl (shiftnP k P))) 0 (List.rev ctx). #[global] -Instance on_free_vars_ctx_proper : Proper (`=1` ==> `=1`) on_free_vars_ctx. +Instance on_free_vars_ctx_proper : Proper (`≐1` ==> `≐1`) on_free_vars_ctx. Proof. rewrite /on_free_vars_ctx => f g Hfg x. now setoid_rewrite Hfg. @@ -295,7 +295,7 @@ Proof. apply closed_decl_on_free_vars. Qed. -Lemma closedP_shiftnP (n : nat) : closedP n xpredT =1 shiftnP n xpred0. +Lemma closedP_shiftnP (n : nat) : closedP n xpredT ≐1 shiftnP n xpred0. Proof. rewrite /closedP /shiftnP => i. destruct Nat.ltb => //. @@ -344,13 +344,13 @@ Definition strengthenP k n (p : nat -> bool) := else p (i - n). #[global] -Instance strengthenP_proper n k : Proper (`=1` ==> `=1`) (strengthenP n k). +Instance strengthenP_proper n k : Proper (`≐1` ==> `≐1`) (strengthenP n k). Proof. intros f g Hfg i. rewrite /strengthenP. now rewrite (Hfg i) (Hfg (i - k)). Qed. Lemma shiftnP_strengthenP k' k n p : - shiftnP k' (strengthenP k n p) =1 strengthenP (k' + k) n (shiftnP k' p). + shiftnP k' (strengthenP k n p) ≐1 strengthenP (k' + k) n (shiftnP k' p). Proof. intros i. rewrite /shiftnP /strengthenP. repeat nat_compare_specs => /= //. @@ -388,7 +388,7 @@ Definition substP (k : nat) n (q p : nat -> bool) : nat -> bool := else p (i + n) || strengthenP 0 k q i. Lemma shiftnP_substP k' k n q p : - shiftnP k' (substP k n q p) =1 substP (k' + k) n q (shiftnP k' p). + shiftnP k' (substP k n q p) ≐1 substP (k' + k) n q (shiftnP k' p). Proof. intros i; rewrite /shiftnP /substP. repeat nat_compare_specs => /= //. @@ -440,7 +440,7 @@ Lemma rshiftk_S x f : S (rshiftk x f) = rshiftk (S x) f. Proof. reflexivity. Qed. Lemma substP_shiftnP n p : - substP 0 n p (shiftnP n p) =1 p. + substP 0 n p (shiftnP n p) ≐1 p. Proof. intros i; rewrite /shiftnP /substP /= /strengthenP /=. nat_compare_specs. @@ -479,39 +479,39 @@ Definition addnP n (p : nat -> bool) := fun i => p (n + i). #[global] -Instance addnP_proper n : Proper (`=1` ==> Logic.eq ==> Logic.eq) (addnP n). +Instance addnP_proper n : Proper (`≐1` ==> Logic.eq ==> Logic.eq) (addnP n). Proof. intros i f g Hfg; now rewrite /addnP. Qed. #[global] -Instance addnP_proper_pointwise : Proper (Logic.eq ==> `=1` ==> `=1`) addnP. +Instance addnP_proper_pointwise : Proper (Logic.eq ==> `≐1` ==> `≐1`) addnP. Proof. intros i f g Hfg; now rewrite /addnP. Qed. -Lemma addnP_add n k p : addnP n (addnP k p) =1 addnP (n + k) p. +Lemma addnP_add n k p : addnP n (addnP k p) ≐1 addnP (n + k) p. Proof. rewrite /addnP => i. lia_f_equal. Qed. -Lemma addnP0 p : addnP 0 p =1 p. +Lemma addnP0 p : addnP 0 p ≐1 p. Proof. reflexivity. Qed. -Lemma addnP_shiftnP n P : addnP n (shiftnP n P) =1 P. +Lemma addnP_shiftnP n P : addnP n (shiftnP n P) ≐1 P. Proof. intros i; rewrite /addnP /shiftnP /=. nat_compare_specs => /=. lia_f_equal. Qed. -Lemma addnP_orP n p q : addnP n (predU p q) =1 predU (addnP n p) (addnP n q). +Lemma addnP_orP n p q : addnP n (predU p q) ≐1 predU (addnP n p) (addnP n q). Proof. reflexivity. Qed. Definition on_ctx_free_vars P ctx := alli (fun k d => P k ==> (on_free_vars_decl (addnP (S k) P) d)) 0 ctx. #[global] -Instance on_ctx_free_vars_proper : Proper (`=1` ==> eq ==> eq) on_ctx_free_vars. +Instance on_ctx_free_vars_proper : Proper (`≐1` ==> eq ==> eq) on_ctx_free_vars. Proof. rewrite /on_ctx_free_vars => f g Hfg x y <-. apply alli_ext => k. @@ -519,7 +519,7 @@ Proof. Qed. #[global] -Instance on_ctx_free_vars_proper_pointwise : Proper (`=1` ==> `=1`) on_ctx_free_vars. +Instance on_ctx_free_vars_proper_pointwise : Proper (`≐1` ==> `≐1`) on_ctx_free_vars. Proof. rewrite /on_ctx_free_vars => f g Hfg x. apply alli_ext => k. @@ -542,7 +542,7 @@ Qed. Definition aboveP k (p : nat -> bool) := fun i => if i q i]. Definition eq_simpl_pred {A} (x y : simpl_pred A) := - `=1` x y. + `≐1` x y. #[global] -Instance implP_Proper {A} : Proper (`=1` ==> `=1` ==> eq_simpl_pred) (@predA A). +Instance implP_Proper {A} : Proper (`≐1` ==> `≐1` ==> eq_simpl_pred) (@predA A). Proof. intros f g Hfg f' g' Hfg' i; rewrite /predA /=. now rewrite Hfg Hfg'. Qed. Lemma on_free_vars_implP p q t : - predA p q =1 xpredT -> + predA p q ≐1 xpredT -> on_free_vars p t -> on_free_vars q t. Proof. rewrite /predA /=. intros Hp. @@ -672,7 +672,7 @@ Proof. Qed. Definition shiftnP_predU n p q : - shiftnP n (predU p q) =1 predU (shiftnP n p) (shiftnP n q). + shiftnP n (predU p q) ≐1 predU (shiftnP n p) (shiftnP n q). Proof. intros i. rewrite /shiftnP /predU /=. @@ -680,26 +680,26 @@ Proof. Qed. #[global] -Instance orP_Proper {A} : Proper (`=1` ==> `=1` ==> eq_simpl_pred) (@predU A). +Instance orP_Proper {A} : Proper (`≐1` ==> `≐1` ==> eq_simpl_pred) (@predU A). Proof. intros f g Hfg f' g' Hfg' i; rewrite /predU /=. now rewrite Hfg Hfg'. Qed. #[global] -Instance andP_Proper A : Proper (`=1` ==> `=1` ==> eq_simpl_pred) (@predI A). +Instance andP_Proper A : Proper (`≐1` ==> `≐1` ==> eq_simpl_pred) (@predI A). Proof. intros f g Hfg f' g' Hfg' i; rewrite /predI /=. now rewrite Hfg Hfg'. Qed. #[global] -Instance pred_of_simpl_proper {A} : Proper (eq_simpl_pred ==> `=1`) (@PredOfSimpl.coerce A). +Instance pred_of_simpl_proper {A} : Proper (eq_simpl_pred ==> `≐1`) (@PredOfSimpl.coerce A). Proof. now move=> f g; rewrite /eq_simpl_pred => Hfg. Qed. -Lemma orPL (p q : pred nat) : (predA p (predU p q)) =1 predT. +Lemma orPL (p q : pred nat) : (predA p (predU p q)) ≐1 predT. Proof. intros i. rewrite /predA /predU /=. rewrite (ssrbool.implybE (p i)). @@ -926,7 +926,7 @@ Qed. Lemma lenm_eq {n m} : n <= m -> n - m = 0. Proof. lia. Qed. -Lemma addnP_shiftnP_comm n (P : nat -> bool) : P 0 -> addnP 1 (shiftnP n P) =1 shiftnP n (addnP 1 P). +Lemma addnP_shiftnP_comm n (P : nat -> bool) : P 0 -> addnP 1 (shiftnP n P) ≐1 shiftnP n (addnP 1 P). Proof. intros p0 i; rewrite /addnP /shiftnP /=. repeat nat_compare_specs => /= //. @@ -1219,7 +1219,7 @@ Proof. Qed. Lemma substP_shiftnP_gen k n p : - substP k n p (shiftnP (k + n) p) =1 shiftnP k p. + substP k n p (shiftnP (k + n) p) ≐1 shiftnP k p. Proof. intros i; rewrite /shiftnP /substP /= /strengthenP /=. repeat nat_compare_specs. diff --git a/pcuic/theories/Typing/PCUICRenameTyp.v b/pcuic/theories/Typing/PCUICRenameTyp.v index 6bd8729f9..08488f07e 100644 --- a/pcuic/theories/Typing/PCUICRenameTyp.v +++ b/pcuic/theories/Typing/PCUICRenameTyp.v @@ -761,7 +761,7 @@ Proof. now rewrite Nat.add_0_r rename_subst. Qed. -Instance rename_telescope_ext : Proper (`=1` ==> `=1`) rename_telescope. +Instance rename_telescope_ext : Proper (`≐1` ==> `≐1`) rename_telescope. Proof. intros f g Hfg Γ. rewrite /rename_telescope. apply mapi_ext => n x. diff --git a/pcuic/theories/utils/PCUICAstUtils.v b/pcuic/theories/utils/PCUICAstUtils.v index f25860018..c2bab7c67 100644 --- a/pcuic/theories/utils/PCUICAstUtils.v +++ b/pcuic/theories/utils/PCUICAstUtils.v @@ -113,7 +113,7 @@ Ltac solve_all_one := Ltac solve_all := repeat (progress solve_all_one). -#[global] Hint Extern 4 (_ =1 _) => intro : all. +#[global] Hint Extern 4 (_ ≐1 _) => intro : all. #[global] Hint Extern 10 => rewrite !map_branch_map_branch : all. #[global] Hint Extern 10 => rewrite !map_predicate_map_predicate : all. diff --git a/template-rocq/theories/Ast.v b/template-rocq/theories/Ast.v index 85b94d06e..cfdd95534 100644 --- a/template-rocq/theories/Ast.v +++ b/template-rocq/theories/Ast.v @@ -143,7 +143,7 @@ Proof. Qed. #[global] Hint Resolve map_predicate_id_spec : all. -#[global] Instance map_predicate_proper {term} : Proper (`=1` ==> `=1` ==> Logic.eq ==> Logic.eq)%signature (@map_predicate term term id). +#[global] Instance map_predicate_proper {term} : Proper (`≐1` ==> `≐1` ==> Logic.eq ==> Logic.eq)%signature (@map_predicate term term id). Proof. intros eqf0 eqf1 eqf. intros eqf'0 eqf'1 eqf'. @@ -152,7 +152,7 @@ Proof. now apply map_ext => x. Qed. -#[global] Instance map_predicate_proper' {term} f : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@map_predicate term term id f). +#[global] Instance map_predicate_proper' {term} f : Proper (`≐1` ==> Logic.eq ==> Logic.eq) (@map_predicate term term id f). Proof. intros eqf0 eqf1 eqf. intros x y ->. @@ -261,7 +261,7 @@ Proof. Qed. #[global] Hint Resolve map_branch_eq_spec : all. -#[global] Instance map_branch_proper {term} : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@map_branch term term). +#[global] Instance map_branch_proper {term} : Proper (`≐1` ==> Logic.eq ==> Logic.eq) (@map_branch term term). Proof. intros eqf0 eqf1 eqf. intros x y ->. diff --git a/template-rocq/theories/LoopChecking.v b/template-rocq/theories/LoopChecking.v index 41cc163fb..77c8db9a8 100644 --- a/template-rocq/theories/LoopChecking.v +++ b/template-rocq/theories/LoopChecking.v @@ -2163,7 +2163,7 @@ Proof. now rewrite eqm. Qed. -#[local] Instance fold_left_ext {A B} : Proper (`=2` ==> eq ==> eq ==> eq) (@fold_left A B). +#[local] Instance fold_left_ext {A B} : Proper (`≐2` ==> eq ==> eq ==> eq) (@fold_left A B). Proof. intros f g hfg ? ? -> ? ? ->. induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). diff --git a/template-rocq/theories/LoopCheckingNat.v b/template-rocq/theories/LoopCheckingNat.v index 2dc573540..b1e755af1 100644 --- a/template-rocq/theories/LoopCheckingNat.v +++ b/template-rocq/theories/LoopCheckingNat.v @@ -1925,7 +1925,7 @@ Proof. now rewrite eqm. Qed. -#[local] Instance fold_left_ext {A B} : Proper (`=2` ==> eq ==> eq ==> eq) (@fold_left A B). +#[local] Instance fold_left_ext {A B} : Proper (`≐2` ==> eq ==> eq ==> eq) (@fold_left A B). Proof. intros f g hfg ? ? -> ? ? ->. induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). diff --git a/utils/theories/All_Forall.v b/utils/theories/All_Forall.v index 8216465ad..61837d4fb 100644 --- a/utils/theories/All_Forall.v +++ b/utils/theories/All_Forall.v @@ -176,7 +176,7 @@ Section alli. End alli. Lemma alli_ext {A} (p q : nat -> A -> bool) n (l : list A) : - (forall i, p i =1 q i) -> + (forall i, p i ≐1 q i) -> alli p n l = alli q n l. Proof. intros hfg. @@ -352,14 +352,14 @@ Proof. constructor; auto. now destruct (Hp a). Qed. -Lemma forallb_ext {A} (p q : A -> bool) : p =1 q -> forallb p =1 forallb q. +Lemma forallb_ext {A} (p q : A -> bool) : p ≐1 q -> forallb p ≐1 forallb q. Proof. intros hpq l. induction l; simpl; auto. now rewrite (hpq a) IHl. Qed. -#[global] Instance forallb_proper {A} : Proper (`=1` ==> eq ==> eq) (@forallb A). +#[global] Instance forallb_proper {A} : Proper (`≐1` ==> eq ==> eq) (@forallb A). Proof. intros f g Hfg ? ? ->. now apply forallb_ext. Qed. diff --git a/utils/theories/MROption.v b/utils/theories/MROption.v index e94d30491..f9f691fad 100644 --- a/utils/theories/MROption.v +++ b/utils/theories/MROption.v @@ -94,12 +94,12 @@ Proof. intros []; cbn; congruence. Qed. -#[global] Instance option_map_proper {A B} : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@option_map A B). +#[global] Instance option_map_proper {A B} : Proper (`≐1` ==> Logic.eq ==> Logic.eq) (@option_map A B). Proof. intros f g Hfg x y <-. now apply option_map_ext. Qed. -Lemma option_map_id {A} : option_map (@id A) =1 id. +Lemma option_map_id {A} : option_map (@id A) ≐1 id. Proof. by intros []. Qed. Lemma nth_map_option_out {A B} (f : nat -> A -> option B) l l' i t : map_option_out (mapi f l) = Some l' -> @@ -177,13 +177,13 @@ Definition foroptb2 {A : Type} (p : A -> A -> bool) (o o': option A) : bool := | _, _ => false end. -#[global] Instance foroptb_proper A : Proper (`=1` ==> Logic.eq ==> Logic.eq) (@foroptb A). +#[global] Instance foroptb_proper A : Proper (`≐1` ==> Logic.eq ==> Logic.eq) (@foroptb A). Proof. intros f g Hfg x y ->; rewrite /foroptb. destruct y; simpl; rewrite // ?Hfg. Qed. -#[global] Instance foroptb_proper_pointwise A : Proper (`=1` ==> `=1`) (@foroptb A). +#[global] Instance foroptb_proper_pointwise A : Proper (`≐1` ==> `≐1`) (@foroptb A). Proof. intros f g Hfg y; rewrite /foroptb. destruct y; simpl; rewrite // ?Hfg. diff --git a/utils/theories/MRPred.v b/utils/theories/MRPred.v index 585edfc2f..2d7e3e62d 100644 --- a/utils/theories/MRPred.v +++ b/utils/theories/MRPred.v @@ -14,25 +14,25 @@ Definition conjP (p q : nat -> bool) (n : nat) : bool := Definition implP (p q : nat -> bool) (n : nat) : bool := p n ==> q n. *) -#[global] Instance orP_Proper {A} : Proper (`=1` ==> `=1` ==> `=1`) (@predU A). +#[global] Instance orP_Proper {A} : Proper (`≐1` ==> `≐1` ==> `≐1`) (@predU A). Proof. intros f g Hfg f' g' Hfg' i; rewrite /predU /=. now rewrite Hfg Hfg'. Qed. -#[global] Instance andP_Proper A : Proper (`=1` ==> `=1` ==> `=1`) (@predI A). +#[global] Instance andP_Proper A : Proper (`≐1` ==> `≐1` ==> `≐1`) (@predI A). Proof. intros f g Hfg f' g' Hfg' i; rewrite /predI /=. now rewrite Hfg Hfg'. Qed. -#[global] Instance implP_Proper {A} : Proper (`=1` ==> `=1` ==> `=1`) (@predA A). +#[global] Instance implP_Proper {A} : Proper (`≐1` ==> `≐1` ==> `≐1`) (@predA A). Proof. intros f g Hfg f' g' Hfg' i; rewrite /predA /=. now rewrite Hfg Hfg'. Qed. -Lemma orPL (p q : nat -> bool) : predA p (predU p q) =1 xpredT. +Lemma orPL (p q : nat -> bool) : predA p (predU p q) ≐1 xpredT. Proof. intros i. rewrite /predA /predU /=. rewrite (ssrbool.implybE (p i)). diff --git a/utils/theories/MRPrelude.v b/utils/theories/MRPrelude.v index 0fb52ffd4..cc16151a2 100644 --- a/utils/theories/MRPrelude.v +++ b/utils/theories/MRPrelude.v @@ -37,32 +37,32 @@ Notation "x .π1" := (@projT1 _ _ x) (at level 3, format "x '.π1'"). Notation "x .π2" := (@projT2 _ _ x) (at level 3, format "x '.π2'"). (** Shorthand for pointwise equality relation in Proper signatures *) -Notation "`=1`" := (pointwise_relation _ Logic.eq) (at level 80). +Notation "`≐1`" := (pointwise_relation _ Logic.eq) (at level 80). (* \doteq *) #[warnings="-notation-overridden"] Infix "≐1" := (pointwise_relation _ Logic.eq) (at level 70) : type_scope. -Notation "`=2`" := (pointwise_relation _ (pointwise_relation _ Logic.eq)) (at level 80). +Notation "`≐2`" := (pointwise_relation _ (pointwise_relation _ Logic.eq)) (at level 80). #[warnings="-notation-overridden"] -Infix "=2" := (pointwise_relation _ (pointwise_relation _ Logic.eq)) (at level 70) : type_scope. +Infix "≐2" := (pointwise_relation _ (pointwise_relation _ Logic.eq)) (at level 70) : type_scope. (** Higher-order lemma to simplify Proper proofs. *) -#[global] Instance proper_ext_eq {A B} : Proper (`=1` ==> `=1` ==> iff) (@pointwise_relation A _ (@Logic.eq B)). +#[global] Instance proper_ext_eq {A B} : Proper (`≐1` ==> `≐1` ==> iff) (@pointwise_relation A _ (@Logic.eq B)). Proof. intros f f' Hff' g g' Hgg'. split; intros. - intros x. now rewrite <- Hff', <- Hgg'. - intros x. now rewrite Hff' Hgg'. Qed. -#[global] Instance id_proper_proxy {A} : ProperProxy (`=1`) (@id A). +#[global] Instance id_proper_proxy {A} : ProperProxy (`≐1`) (@id A). Proof. intros x; reflexivity. Qed. -#[global] Instance pointwise_subrelation {A B} : subrelation (`=1`) (@Logic.eq A ==> @Logic.eq B)%signature. +#[global] Instance pointwise_subrelation {A B} : subrelation (`≐1`) (@Logic.eq A ==> @Logic.eq B)%signature. Proof. intros f g Hfg x y ->. now rewrite Hfg. Qed. -#[global] Instance pointwise_subrelation2 {A B C} : subrelation (`=2`) (@Logic.eq A ==> @Logic.eq B ==> @Logic.eq C)%signature. +#[global] Instance pointwise_subrelation2 {A B C} : subrelation (`≐2`) (@Logic.eq A ==> @Logic.eq B ==> @Logic.eq C)%signature. Proof. intros f g Hfg x y -> ? ? ->. now rewrite Hfg. Qed. diff --git a/utils/theories/MR_ExtrOCamlZPosInt.v b/utils/theories/MR_ExtrOCamlZPosInt.v index 6e74c80e4..be41db80e 100644 --- a/utils/theories/MR_ExtrOCamlZPosInt.v +++ b/utils/theories/MR_ExtrOCamlZPosInt.v @@ -11,7 +11,7 @@ From Stdlib Require Import Extraction NArith ZArith. Extract Inductive positive => int [ "(fun p->1+2*p)" "(fun p->2*p)" "1" ] "(fun f2p1 f2p f1 p -> - if p<=1 then f1 () else if p mod 2 = 0 then f2p (p/2) else f2p1 (p/2))". + if p<≐1 then f1 () else if p mod 2 = 0 then f2p (p/2) else f2p1 (p/2))". Extract Inductive Z => int [ "0" "" "(~-)" ] "(fun f0 fp fn z -> if z=0 then f0 () else if z>0 then fp z else fn (-z))". diff --git a/utils/theories/wGraph.v b/utils/theories/wGraph.v index ac85a52ab..046f027cc 100644 --- a/utils/theories/wGraph.v +++ b/utils/theories/wGraph.v @@ -992,7 +992,7 @@ Module WeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module destruct (g a) => //=. Qed. - #[global] Instance fold_left_proper {A B} : Proper (`=2` ==> `=2`) (@fold_left A B). + #[global] Instance fold_left_proper {A B} : Proper (`≐2` ==> `≐2`) (@fold_left A B). Proof using Type. intros f g hfg x acc. induction x in acc |- * => //. From d6fa7af9d2a567004ba0ec3e2ee695166d817377 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 25 Sep 2025 14:44:41 +0200 Subject: [PATCH 072/164] Finished cleanup --- common/theories/LoopChecking/Deciders.v | 2 +- .../LoopChecking/HornSemilatticeEquiv.v | 2 +- .../LoopChecking/InitialSemilattice.v | 285 +----------------- .../theories/LoopChecking/UnivLoopChecking.v | 77 ++++- template-rocq/theories/Junk.v | 11 + utils/theories/MRInstances.v | 12 +- utils/theories/NonEmptyLevelExprSet.v | 176 ++++++++++- utils/theories/SemiLattice.v | 100 +++++- 8 files changed, 363 insertions(+), 302 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index a96d41e25..0a73c8d49 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -1203,7 +1203,7 @@ Module LoopChecking (LS : LevelSets). rewrite !interp_rels_clauses_sem // => vr /vr. rewrite -interp_rels_clauses_sem. rewrite clauses_sem_eq. - setoid_rewrite ISL.interp_add_prems; cbn -[Z.add]. + setoid_rewrite interp_add_prems; cbn -[Z.add]. lia. Qed. diff --git a/common/theories/LoopChecking/HornSemilatticeEquiv.v b/common/theories/LoopChecking/HornSemilatticeEquiv.v index d40925c88..0f6459907 100644 --- a/common/theories/LoopChecking/HornSemilatticeEquiv.v +++ b/common/theories/LoopChecking/HornSemilatticeEquiv.v @@ -641,7 +641,7 @@ Module HornSemilattice (LS : LevelSets). Qed. Lemma entails_L_relations_of_clauses_le l r : - relations_of_clauses (l ⋞ r) ⊫ℒ [l ≤ r]. + relations_of_clauses (l ⋞ r) ⊫ℒ [l ≤ r]%rel. Proof. split. - constructor. apply entails_L_relations_of_clauses_le_impl. constructor. diff --git a/common/theories/LoopChecking/InitialSemilattice.v b/common/theories/LoopChecking/InitialSemilattice.v index 80fb0e0a0..0b0eb6a8c 100644 --- a/common/theories/LoopChecking/InitialSemilattice.v +++ b/common/theories/LoopChecking/InitialSemilattice.v @@ -21,7 +21,6 @@ Module InitialSemilattice (LS : LevelSets). Import Semilattice. Import CommutativeMonoid. - Existing Instance semilattice_Semilattice. Existing Instance OfQ.add_inj_le. Definition rel := t × t. @@ -411,294 +410,15 @@ Module InitialSemilattice (LS : LevelSets). Context {S : Type} {SL : Semilattice S Q.t}. Context (v : Level.t -> S). - Definition interp_expr '(l, k) := (add k (v l)). - - Definition interp_prems prems := - let '(hd, tl) := to_nonempty_list prems in - fold_right (fun lk acc => join (interp_expr lk) acc) (interp_expr hd) tl. - Definition interp_rel r := let '(l, r) := r in - interp_prems l ≡ interp_prems r. + interp_prems v l ≡ interp_prems v r. Definition interp_rels c := List.Forall interp_rel c. - Declare Scope sl_scope. - Infix "≤" := le : sl_scope. - Infix "≡" := eq : sl_scope. - Local Open Scope sl_scope. - End interp. -Section ForSemilattice. - Import Semilattice. - Import CommutativeMonoid. - Context {A : Type} {V : Type} {CM : IsCommMonoid V} {SL : Semilattice A V}. - Open Scope sl_scope. - - Lemma fold_right_max_in {a : A} {l : list A} n : In a l -> a ≤ (fold_right join n l). - Proof. - induction l. - - now cbn. - - intros [eq|inl]. subst a0. cbn. apply join_le_left. - cbn. specialize (IHl inl). etransitivity; tea. apply join_le_right. - Qed. - - Lemma fold_right_max_acc {n l} : n ≤ fold_right join n l. - Proof. - induction l. - - now cbn. - - cbn. etransitivity; tea. eapply join_le_right. - Qed. - - Lemma fold_right_impl n l l' : - (forall x, In x l -> In x l') -> fold_right join n l ≤ fold_right join n l'. - Proof. - induction l in l' |- *. - - cbn. destruct l'; cbn. reflexivity. - intros. have := @fold_right_max_acc n l'. - etransitivity; tea; eapply join_le_right. - - cbn; intros h. - have inal' := (h a (or_introl Logic.eq_refl)). - have := fold_right_max_in n inal'. - specialize (IHl l'). - forward IHl. - intros. apply h. now right. - intros hle; rewrite join_le_left_eq. now split. - Qed. - - Lemma fold_right_max_spec n l : - let fn := fold_right join in - (forall x, In x (n :: l) -> x ≤ fn n l). - Proof. - induction l; cbn. - - intros x [] => //. now subst. - (* exists n. firstorder. reflexivity. *) - - cbn in IHl. - intros x [|[]]; subst. - * specialize (IHl x). forward IHl by auto. - now apply join_le_right_trans. - * apply join_le_left. - * specialize (IHl x). forward IHl by auto. - now apply join_le_right_trans. - Qed. - - Lemma fold_right_equivlist_all_le n n' l l' : - equivlistA Logic.eq (n :: l) (n' :: l') -> fold_right join n l ≤ fold_right join n' l'. - Proof. - intros eq. - have hla := fold_right_max_spec n l. - have hra := fold_right_max_spec n' l'. - red in eq. - setoid_rewrite InA_In_eq in eq. - cbn in hra. setoid_rewrite <- eq in hra. clear -hra. - move: hra; generalize (fold_right join n' l'). - clear. - induction l. - - cbn. intros a heq. apply heq. now left. - - cbn. intros a' ih. - specialize (IHl a'). forward IHl. - { cbn; intros x []. subst. eapply ih. now left. - apply ih. auto. } - specialize (ih a). forward ih. { now right; left. } - eapply join_le_left_eq; now split. - Qed. - - Lemma fold_right_equivlist_all n n' l l' : - equivlistA Logic.eq (n :: l) (n' :: l') -> fold_right join n l ≡ fold_right join n' l'. - Proof. - intros eq. - apply eq_antisym; split; eapply fold_right_equivlist_all_le; auto. - now symmetry. - Qed. - - Lemma fold_right_comm acc l : l <> [] -> fold_right join acc l ≡ join acc (fold_right join (List.hd acc l) (List.tl l)). - Proof. - induction l in acc |- *. - - intros; congruence. - - intros _. cbn. destruct l; cbn. apply join_comm. - cbn in IHl. rewrite (IHl acc). congruence. - rewrite (IHl a). congruence. - now rewrite -!join_assoc (join_comm a). - Qed. - -End ForSemilattice. - - Section OnInterp. - Context {S : Type} {SL : Semilattice S Q.t}. - - (* There exists a valuation making all clauses true in the natural numbers *) - Definition satisfiable (cls : rels) := - exists V, interp_rels V cls. - - (* Any valuation making all clauses valid in the given semilattice also satisfies the clause cl *) - Definition entails_sem (cls : rels) (r : rel) := - forall V, interp_rels V cls -> interp_rel V r. - - Lemma interp_add_expr V n e : - interp_expr V (add_expr n e) ≡ add n (interp_expr V e). - Proof. - destruct e as [l k]; cbn. now rewrite add_distr. - Qed. - - Lemma interp_prems_singleton V e : - interp_prems V (NES.singleton e) = interp_expr V e. - Proof. - rewrite /interp_prems. - now rewrite singleton_to_nonempty_list /=. - Qed. - - Lemma interp_prems_ge v (prems : t) : - forall prem, LevelExprSet.In prem prems -> - interp_expr v prem ≤ interp_prems v prems. - Proof. - intros. - unfold interp_prems. - have he := to_nonempty_list_spec prems. - destruct to_nonempty_list. - pose proof to_nonempty_list_spec'. - rewrite In_elements in H. rewrite -he in H. clear H0 he. clear -H. - destruct H. subst p. - - induction l. cbn. auto. - cbn. red. eapply join_idem. cbn. - etransitivity; tea. - apply join_le_right. - - induction l in H |- *. - now cbn in H. - cbn in H. destruct H; subst; cbn. - * cbn. apply join_le_left. - * specialize (IHl H). etransitivity; tea. apply join_le_right. - Qed. - - Lemma interp_prems_elements V u : - interp_prems V u = fold_right join (interp_expr V (to_nonempty_list u).1) (List.map (interp_expr V) (to_nonempty_list u).2). - Proof. - rewrite /interp_prems. - have he := to_nonempty_list_spec u. - destruct to_nonempty_list. - now rewrite fold_right_map. - Qed. - - Lemma fold_right_interp {V : Level.t -> S} {x l x' l'} : - equivlistA Logic.eq (x :: l) (x' :: l') -> - fold_right join (interp_expr V x) (List.map (interp_expr V) l) ≡ fold_right join (interp_expr V x') (List.map (interp_expr V) l'). - Proof. - intros eq. apply fold_right_equivlist_all. - intros a. rewrite !InA_In_eq. - rewrite !(in_map_iff (interp_expr V) (_ :: _)). - setoid_rewrite <-InA_In_eq. - split. - - move=> [b [<- ]]. - eexists; split; trea. now apply eq in b0. - - move=> [b [<- ]]. - eexists; split; trea. now apply eq in b0. - Qed. - - Lemma equivlistA_add le u : let l := to_nonempty_list (NES.add le u) in - equivlistA Logic.eq (l.1 :: l.2) (le :: LevelExprSet.elements u). - Proof. - have he := to_nonempty_list_spec (NES.add le u). - destruct to_nonempty_list. cbn. - intros x. rewrite he. - rewrite !LevelExprSet.elements_spec1. - split. - - move/LevelExprSet.add_spec => [->|hin]. - now constructor. constructor 2. now apply LevelExprSet.elements_spec1. - - intros h; depelim h; subst. now apply LevelExprSet.add_spec; left. - apply LevelExprSet.add_spec. now apply LevelExprSet.elements_spec1 in h. - Qed. - - Lemma interp_prems_add V le (u : t) : - interp_prems V (NES.add le u) ≡ join (interp_expr V le) (interp_prems V u). - Proof. - rewrite 2!interp_prems_elements. - erewrite fold_right_interp. 2:apply equivlistA_add. - rewrite fold_right_comm. - { apply map_nil, elements_not_empty. } - apply join_congr_r. eapply fold_right_equivlist_all. - have he := to_nonempty_list_spec u. - destruct to_nonempty_list. rewrite -he //=. - Qed. - - Lemma interp_prems_elim (P : t -> S -> Prop) V : - Proper (Logic.eq ==> eq ==> iff) P -> - (forall le, P (singleton le) (interp_expr V le)) -> - (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (NES.add le u) (join (interp_expr V le) k)) -> - forall u, P u (interp_prems V u). - Proof. - intros prop hs hadd. - eapply elim. - - intros le. rewrite interp_prems_singleton. apply hs. - - intros le prems ih hnin. - rewrite interp_prems_add. now apply hadd. - Qed. - - Lemma interp_add_prems V n e : interp_prems V (add_prems n e) ≡ add n (interp_prems V e). - Proof. - revert e. - refine (interp_prems_elim (fun u z => interp_prems V (add_prems n u) ≡ add n z) _ _ _ _). - - intros p p' eq a a' eq'. - subst p'. now rewrite eq'. - - intros le. - rewrite add_prems_singleton interp_prems_singleton //=. - destruct le; cbn. now rewrite add_distr. - - intros le u k heq hnin. - rewrite add_prems_add. - rewrite interp_prems_add heq interp_add_expr. - now rewrite add_join. - Qed. - - Lemma interp_prems_in {V le} {u : t} : - LevelExprSet.In le u -> interp_expr V le ≤ interp_prems V u. - Proof. - revert u. - refine (interp_prems_elim (fun u z => LevelExprSet.In le u -> interp_expr V le ≤ z) V _ _ _). - - intros ? ? <- x y eq. now rewrite eq. - - intros le' u'. - apply LevelExprSet.singleton_spec in u'. red in u'; subst. - reflexivity. - - move=> le' u z hz hnin /LevelExprSet.add_spec [->|hin]. - * apply join_le_left. - * specialize (hz hin). - now apply join_le_right_trans. - Qed. - - Lemma interp_prems_union {v : Level.t -> S} {x y : t} : - interp_prems v (x ∪ y) ≡ - join (interp_prems v x) (interp_prems v y). - Proof. - move: x; apply NES.elim. - - intros []. rewrite union_comm union_add_singleton. - now rewrite interp_prems_add interp_prems_singleton. - - intros le' x ih hnin. - rewrite union_add_distr !interp_prems_add ih. cbn. - now rewrite join_assoc. - Qed. - - Lemma clauses_sem_subset {u u' : t} : u ⊂_leset u' -> - forall V, interp_prems V u ≤ interp_prems V u'. - Proof. - intros hsub V. - revert u u' hsub. - refine (interp_prems_elim (fun u z => forall u' : t, u ⊂_leset u' -> - z ≤ interp_prems V u') V _ _ _). - - intros ?? <- ?? eq. - now setoid_rewrite eq. - - intros le u' hsing. - specialize (hsing le). forward hsing by now apply LevelExprSet.singleton_spec. - now apply interp_prems_in. - - intros le u k ih hin u' sub. - have hle := sub le. - specialize (ih u'). - forward ih. intros x hin'. apply sub. now apply LevelExprSet.add_spec; right. - forward hle by now apply LevelExprSet.add_spec; left. - have hi := interp_prems_in (V := V) hle. - apply join_le_left_eq. split => //. - Qed. - - End OnInterp. - Definition valid_relation rels c := (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v rels -> interp_rel v c). @@ -748,9 +468,6 @@ End ForSemilattice. #[export] Existing Instance init_model. - Definition initial_semilattice rs : semilattice Q.t := - {| carrier := NES.t; sl := init_model rs |}. - Definition ids (rs : rels) : Level.t -> t := (fun l : Level.t => singleton (l, zero)). Lemma interp_triv rs l : eq (Semilattice := init_model rs) (interp_prems (SL := init_model rs) (ids rs) l) l. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index bf02fe588..369e9cb5b 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -632,8 +632,6 @@ End ZUnivConstraint. LevelSet.fold add_val V (LevelMap.empty _). Import LoopCheck.Impl.Abstract (clause_sem, clauses_sem, clauses_sem_union, to_val, to_Z_val). - Import ISL (interp_prems, interp_add_prems, interp_prems_union, - interp_prems_singleton, interp_prems_add, interp_expr). Lemma clauses_sem_subset {S} {SL : Semilattice.Semilattice S Q.t} {v cls cls'} : clauses_sem v cls -> cls' ⊂_clset cls -> clauses_sem v cls'. Proof. @@ -1107,6 +1105,23 @@ End ZUnivConstraint. End interp. + Section interp_nat. + Import Semilattice. + Import -(notations) Universe. + Context {S : Type} {SL : Semilattice S nat}. + Context (v : Level.t -> S). + + Definition interp_nat_cstr c := + let '(l, d, r) := c in + match d with + | ConstraintType.Le => interp_prems v l ≤ interp_prems v r + | ConstraintType.Eq => interp_prems v l ≡ interp_prems v r + end%Z. + + Definition interp_cstrs c := UnivConstraintSet.For_all interp_nat_cstr c. + + End interp_nat. + Definition valid_relation rels c := (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v rels -> interp_rel v c). @@ -1119,6 +1134,8 @@ End ZUnivConstraint. Import Semilattice. Import ISL. + Definition model_val m := (LoopCheck.valuation (model m)). + Definition model_Z_val m := (to_Z_val (LoopCheck.valuation (model m))). Lemma interp_rels_of_m m : interp_rels (model_Z_val m) (relations_of_constraints (to_z_cstrs (constraints m))). @@ -1205,6 +1222,43 @@ End ZUnivConstraint. now rewrite -[Clauses.relations_of_clauses _]equiv_constraints_clauses. Qed. + Lemma to_valuation_val (v : Level.t -> nat) (l : Universes.Level.t) : v l = val (to_valuation v) l. + Proof. + destruct l => //=. + - todo "zero". + - todo "mono". + Qed. + + (** Interpretation in the semilattice of natural numbers *) + Lemma interp_prems_val (v : Level.t -> nat) u : + Universe.interp_prems v u = Universes.val (to_valuation v) u. + Proof. + move: u. refine (Universe.interp_prems_elim v (fun u i => i = val (to_valuation v) u) _ _ _). + - now intros [l k]; rewrite val_singleton //= /val /Universe.interp_expr to_valuation_val; cbn. + - move=>[l k] u k' -> hnin. + rewrite val_add; cbn. now rewrite to_valuation_val; cbn. + Qed. + + Lemma interp_univ_cstr_nat v cl : + interp_univ_cstr (to_Z_val v) cl <-> interp_nat_cstr v cl. + Proof. + destruct cl as [[l []] r] => //=; + cbn; rewrite !interp_prems_to_atoms !(interp_prems_val v) /model_val. split. all:lia. + Qed. + + Lemma interp_univ_cstrs_nat v cl : + interp_univ_cstrs (to_Z_val v) cl <-> interp_cstrs v cl. + Proof. + split; move=> hin cl' /hin; now rewrite interp_univ_cstr_nat. + Qed. + + Lemma interp_cstrs_of_m m : + interp_cstrs (model_val m) (constraints m). + Proof. + have ha := interp_univ_cstrs_of_m m. + now apply interp_univ_cstrs_nat. + Qed. + Lemma entails_L_completeness {p l r} : (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v p -> interp_prems v l ≡ interp_prems v r)%sl -> p ⊢ℒ l ≡ r. @@ -1217,10 +1271,15 @@ End ZUnivConstraint. exact hv. Qed. + Definition valid_model m c := + (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + + Infix "⊩" := valid_model (at level 70, no associativity). + Theorem check_completeness {m c} : - check m c <-> (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + check m c <-> m ⊩ c. Proof. - rewrite LoopCheck.check_complete /LoopCheck.valid_entailments. + rewrite LoopCheck.check_complete /LoopCheck.valid_entailments /valid_model. setoid_rewrite interp_cstrs_clauses_sem. split. - intros hv S s v hp. @@ -1231,4 +1290,14 @@ End ZUnivConstraint. now rewrite interp_cstr_clauses_sem. Qed. + Theorem check_valid_nat {m c} : + check m c -> (forall (v : Level.t -> nat), interp_cstrs v (constraints m) -> interp_nat_cstr v c). + Proof. + rewrite check_completeness. + intros hv v hp. + move: (hv Z Zsemilattice (to_Z_val v)). + rewrite interp_univ_cstr_nat; apply. + now apply interp_univ_cstrs_nat. + Qed. + End UnivLoopChecking. diff --git a/template-rocq/theories/Junk.v b/template-rocq/theories/Junk.v index 5a05fa9db..693c4305f 100644 --- a/template-rocq/theories/Junk.v +++ b/template-rocq/theories/Junk.v @@ -903,3 +903,14 @@ Qed. *) Definition satisfiable (s : semilattice) (r : rels) := exists v, interp_rels (SL := sl s) v r. *) + + + Structure semilattice {Q} := + { carrier :> Type; + comm_monoid : IsCommMonoid Q ; + sl : Semilattice carrier Q }. + Arguments semilattice : clear implicits. + + Instance semilattice_CommMonoid {Q} (s : semilattice Q) : IsCommMonoid Q := comm_monoid s. + + Instance semilattice_Semilattice {Q} (s : semilattice Q) : @Semilattice (carrier s) Q (comm_monoid s) := sl s. diff --git a/utils/theories/MRInstances.v b/utils/theories/MRInstances.v index 389965541..676b90790 100644 --- a/utils/theories/MRInstances.v +++ b/utils/theories/MRInstances.v @@ -60,6 +60,14 @@ End ZSemiLattice. #[export] Existing Instance Zsemilattice. -Import Semilattice. +Section NatSemiLattice. + Import Semilattice. + + Program Definition Natsemilattice : Semilattice nat nat := + {| add := Nat.add; + join := Nat.max; |}. + Solve Obligations with program_simpl; try lia. + +End NatSemiLattice. -Canonical Structure Z_semilattice : Semilattice.semilattice Z := {| carrier := Z; comm_monoid := _; sl := _ |}. +#[export] Existing Instance Natsemilattice. diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v index c76c9c46e..ac20b5cbc 100644 --- a/utils/theories/NonEmptyLevelExprSet.v +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -3,7 +3,7 @@ From Equations Require Import Equations. Set Equations Transparent. From Corelib Require Import ssreflect ssrfun ssrbool. From Stdlib Require Import SetoidList Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import MRPrelude ReflectEq MRString MRList MRClasses. +From MetaRocq.Utils Require Import MRPrelude ReflectEq MRString MRList MRClasses SemiLattice. Module Type OrderedTypeWithLeibniz. Include UsualOrderedType. @@ -658,4 +658,178 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) now constructor. Qed. + Section SemilatticeInterp. + Import Semilattice. + Context {S: Type} {SL : Semilattice S Q.t}. + Context (v : Level.t -> S). + + Definition interp_expr '(l, k) := (add k (v l)). + + Definition interp_prems prems := + let '(hd, tl) := to_nonempty_list prems in + fold_right (fun lk acc => join (interp_expr lk) acc) (interp_expr hd) tl. + + Lemma interp_add_expr n e : + interp_expr (add_expr n e) ≡ add n (interp_expr e). + Proof. + destruct e as [l k]; cbn. now rewrite add_distr. + Qed. + + Lemma interp_prems_singleton e : + interp_prems (singleton e) = interp_expr e. + Proof. + rewrite /interp_prems. + now rewrite singleton_to_nonempty_list /=. + Qed. + + Lemma interp_prems_ge (prems : t) : + forall prem, LevelExprSet.In prem prems -> + interp_expr prem ≤ interp_prems prems. + Proof. + intros. + unfold interp_prems. + have he := to_nonempty_list_spec prems. + destruct to_nonempty_list. + pose proof to_nonempty_list_spec'. + rewrite In_elements in H. rewrite -he in H. clear H0 he. clear -H. + destruct H. subst t0. + - induction l. cbn. auto. + cbn. red. eapply join_idem. cbn. + etransitivity; tea. + apply join_le_right. + - induction l in H |- *. + now cbn in H. + cbn in H. destruct H; subst; cbn. + * cbn. apply join_le_left. + * specialize (IHl H). etransitivity; tea. apply join_le_right. + Qed. + + Lemma interp_prems_elements u : + interp_prems u = fold_right join (interp_expr (to_nonempty_list u).1) (List.map (interp_expr) (to_nonempty_list u).2). + Proof. + rewrite /interp_prems. + have he := to_nonempty_list_spec u. + destruct to_nonempty_list. + now rewrite fold_right_map. + Qed. + + Lemma fold_right_interp {x l x' l'} : + equivlistA Logic.eq (x :: l) (x' :: l') -> + fold_right join (interp_expr x) (List.map (interp_expr) l) ≡ fold_right join (interp_expr x') (List.map (interp_expr) l'). + Proof. + intros eq. apply fold_right_equivlist_all. + intros a. rewrite !InA_In_eq. + rewrite !(in_map_iff (interp_expr) (_ :: _)). + setoid_rewrite <-InA_In_eq. + split. + - move=> [b [<- ]]. + eexists; split; trea. now apply eq in b0. + - move=> [b [<- ]]. + eexists; split; trea. now apply eq in b0. + Qed. + + Lemma equivlistA_add le u : let l := to_nonempty_list (NonEmptyLevelExprSet.add le u) in + equivlistA Logic.eq (l.1 :: l.2) (le :: LevelExprSet.elements u). + Proof. + have he := to_nonempty_list_spec (NonEmptyLevelExprSet.add le u). + destruct to_nonempty_list. cbn. + intros x. rewrite he. + rewrite !LevelExprSet.elements_spec1. + split. + - move/LevelExprSet.add_spec => [->|hin]. + now constructor. constructor 2. now apply LevelExprSet.elements_spec1. + - intros h; depelim h; subst. now apply LevelExprSet.add_spec; left. + apply LevelExprSet.add_spec. now apply LevelExprSet.elements_spec1 in h. + Qed. + + Lemma interp_prems_add le (u : t) : + interp_prems (NonEmptyLevelExprSet.add le u) ≡ join (interp_expr le) (interp_prems u). + Proof. + rewrite 2!interp_prems_elements. + erewrite fold_right_interp. 2:apply equivlistA_add. + rewrite fold_right_comm. + { apply map_nil, elements_not_empty. } + apply join_congr_r. eapply fold_right_equivlist_all. + have he := to_nonempty_list_spec u. + destruct to_nonempty_list. rewrite -he //=. + Qed. + + Lemma interp_prems_elim (P : t -> S -> Prop) : + Proper (Logic.eq ==> eq ==> iff) P -> + (forall le, P (singleton le) (interp_expr le)) -> + (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (NonEmptyLevelExprSet.add le u) (join (interp_expr le) k)) -> + forall u, P u (interp_prems u). + Proof. + intros prop hs hadd. + eapply elim. + - intros le. rewrite interp_prems_singleton. apply hs. + - intros le prems ih hnin. + rewrite interp_prems_add. now apply hadd. + Qed. + + Lemma interp_add_prems n e : interp_prems (add_prems n e) ≡ add n (interp_prems e). + Proof. + revert e. + refine (interp_prems_elim (fun u z => interp_prems (add_prems n u) ≡ add n z) _ _ _). + - intros p p' eq a a' eq'. + subst p'. now rewrite eq'. + - intros le. + rewrite add_prems_singleton interp_prems_singleton //=. + destruct le; cbn. now rewrite add_distr. + - intros le u k heq hnin. + rewrite add_prems_add. + rewrite interp_prems_add heq interp_add_expr. + now rewrite add_join. + Qed. + + Lemma interp_prems_in {le} {u : t} : + LevelExprSet.In le u -> interp_expr le ≤ interp_prems u. + Proof. + revert u. + refine (interp_prems_elim (fun u z => LevelExprSet.In le u -> interp_expr le ≤ z) _ _ _). + - intros ? ? <- x y eq. now rewrite eq. + - intros le' u'. + apply LevelExprSet.singleton_spec in u'. red in u'; subst. + reflexivity. + - move=> le' u z hz hnin /LevelExprSet.add_spec [->|hin]. + * apply join_le_left. + * specialize (hz hin). + now apply join_le_right_trans. + Qed. + + Lemma interp_prems_union {x y : t} : + interp_prems (x ∪ y) ≡ + join (interp_prems x) (interp_prems y). + Proof. + move: x; apply elim. + - intros []. rewrite union_comm union_add_singleton. + now rewrite interp_prems_add interp_prems_singleton. + - intros le' x ih hnin. + rewrite union_add_distr !interp_prems_add ih. cbn. + now rewrite join_assoc. + Qed. + + Lemma clauses_sem_subset {u u' : t} : u ⊂_leset u' -> + interp_prems u ≤ interp_prems u'. + Proof. + intros hsub. + revert u u' hsub. + refine (interp_prems_elim (fun u z => forall u' : t, u ⊂_leset u' -> + z ≤ interp_prems u') _ _ _). + - intros ?? <- ?? eq. + now setoid_rewrite eq. + - intros le u' hsing. + specialize (hsing le). forward hsing by now apply LevelExprSet.singleton_spec. + now apply interp_prems_in. + - intros le u k ih hin u' sub. + have hle := sub le. + specialize (ih u'). + forward ih. intros x hin'. apply sub. now apply LevelExprSet.add_spec; right. + forward hle by now apply LevelExprSet.add_spec; left. + have hi := interp_prems_in hle. + apply join_le_left_eq. split => //. + Qed. + + End SemilatticeInterp. + End NonEmptyLevelExprSet. diff --git a/utils/theories/SemiLattice.v b/utils/theories/SemiLattice.v index 8fa4eda6f..11d18dae1 100644 --- a/utils/theories/SemiLattice.v +++ b/utils/theories/SemiLattice.v @@ -1,8 +1,8 @@ (* Distributed under the terms of the MIT license. *) From Stdlib Require Import ssreflect ssrbool ssrfun ZArith. -From Stdlib Require Import Program RelationClasses Morphisms. +From Stdlib Require Import Program RelationClasses Morphisms SetoidList. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import MRClasses NonEmptyLevelExprSet. +From MetaRocq.Utils Require Import MRPrelude MRClasses MRList. Set Equations Transparent. @@ -159,14 +159,96 @@ Module Semilattice. End Derived. - Structure semilattice {Q} := - { carrier :> Type; - comm_monoid : IsCommMonoid Q ; - sl : Semilattice carrier Q }. - Arguments semilattice : clear implicits. + Section FoldSemilattice. + Import CommutativeMonoid. + Context {A : Type} {V : Type} {CM : IsCommMonoid V} {SL : Semilattice A V}. + Open Scope sl_scope. - Instance semilattice_CommMonoid {Q} (s : semilattice Q) : IsCommMonoid Q := comm_monoid s. + Lemma fold_right_max_in {a : A} {l : list A} n : In a l -> a ≤ (fold_right join n l). + Proof. + induction l. + - now cbn. + - intros [eq|inl]. subst a0. cbn. apply join_le_left. + cbn. specialize (IHl inl). etransitivity; tea. apply join_le_right. + Qed. + + Lemma fold_right_max_acc {n l} : n ≤ fold_right join n l. + Proof. + induction l. + - now cbn. + - cbn. etransitivity; tea. eapply join_le_right. + Qed. + + Lemma fold_right_impl n l l' : + (forall x, In x l -> In x l') -> fold_right join n l ≤ fold_right join n l'. + Proof. + induction l in l' |- *. + - cbn. destruct l'; cbn. reflexivity. + intros. have := @fold_right_max_acc n l'. + etransitivity; tea; eapply join_le_right. + - cbn; intros h. + have inal' := (h a (or_introl Logic.eq_refl)). + have := fold_right_max_in n inal'. + move: (IHl l') => /fwd. + intros. apply h. now right. + intros hle; rewrite join_le_left_eq. now split. + Qed. + + Lemma fold_right_max_spec n l : + let fn := fold_right join in + (forall x, In x (n :: l) -> x ≤ fn n l). + Proof. + induction l; cbn. + - intros x [] => //. now subst. + (* exists n. firstorder. reflexivity. *) + - cbn in IHl. + intros x [|[]]; subst. + * move: (IHl x) => /fwd; auto. + now apply join_le_right_trans. + * apply join_le_left. + * move: (IHl x) => /fwd; auto. + now apply join_le_right_trans. + Qed. + + Lemma fold_right_equivlist_all_le n n' l l' : + equivlistA Logic.eq (n :: l) (n' :: l') -> fold_right join n l ≤ fold_right join n' l'. + Proof. + intros eq. + have hla := fold_right_max_spec n l. + have hra := fold_right_max_spec n' l'. + red in eq. + setoid_rewrite InA_In_eq in eq. + cbn in hra. setoid_rewrite <- eq in hra. clear -hra. + move: hra; generalize (fold_right join n' l'). + clear. + induction l. + - cbn. intros a heq. apply heq. now left. + - cbn. intros a' ih. + move: (IHl a') => /fwd. + { cbn; intros x []. subst. eapply ih. now left. + apply ih. auto. } + move: (ih a) => /fwd. { now right; left. } + intros ? ?; eapply join_le_left_eq; now split. + Qed. + + Lemma fold_right_equivlist_all n n' l l' : + equivlistA Logic.eq (n :: l) (n' :: l') -> fold_right join n l ≡ fold_right join n' l'. + Proof. + intros eq. + apply eq_antisym; split; eapply fold_right_equivlist_all_le; auto. + now symmetry. + Qed. + + Lemma fold_right_comm acc l : l <> [] -> fold_right join acc l ≡ join acc (fold_right join (List.hd acc l) (List.tl l)). + Proof. + induction l in acc |- *. + - intros; congruence. + - intros _. cbn. destruct l; cbn. apply join_comm. + cbn in IHl. rewrite (IHl acc). congruence. + rewrite (IHl a). congruence. + now rewrite -!join_assoc (join_comm a). + Qed. - Instance semilattice_Semilattice {Q} (s : semilattice Q) : @Semilattice (carrier s) Q (comm_monoid s) := sl s. + End FoldSemilattice. End Semilattice. From e79b6d0c4745cf99e082977ad0a02a60cd321e3c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 25 Sep 2025 14:57:10 +0200 Subject: [PATCH 073/164] Finished univ loop checking cleanup --- common/theories/LoopChecking/UnivLoopChecking.v | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 369e9cb5b..015ac3f09 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -1,6 +1,13 @@ (* Distributed under the terms of the MIT license. *) (* This module provides an instantiation of the deciders for universe checking, - i.e. for constraints on non-empty level expressions (l, k) where k ∈ 𝐍 *) + i.e. for constraints on non-empty level expressions (l, k) where k ∈ 𝐍, by embedding + into constraints on expressions where k ∈ 𝐙. + The checking algorithm is sound and complete for entailment in the Horn Clauses system, which + is equivalent to the equational theory of the free semilattice (InitialSemilattice) which itself + is equivalent to validity of le/eq constraints over universes in Z. + For the nat case, we simply get that checking implies validity for any valuation in natural numbers, + losing the converse, simply because we didn't generalize the initial semilattice dev to support a restricted + interface. *) From Stdlib Require Import ssreflect ssrfun ssrbool. From Stdlib Require Import Program RelationClasses Morphisms. From 8e0996e6a307a889aea8b938f0bcec3cf331b2c0 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 26 Sep 2025 15:09:46 +0200 Subject: [PATCH 074/164] Add support for a zero level --- common/theories/LoopChecking/Deciders.v | 450 +++++++++++++++--- common/theories/LoopChecking/HornClauses.v | 9 + common/theories/LoopChecking/Model.v | 2 +- .../theories/LoopChecking/UnivLoopChecking.v | 240 +++++++--- utils/theories/NonEmptyLevelExprSet.v | 8 + 5 files changed, 569 insertions(+), 140 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 0a73c8d49..3b9b2639d 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -1,4 +1,5 @@ (* Distributed under the terms of the MIT license. *) +From Ltac2 Require Ltac2. From Stdlib Require Import ssreflect ssrfun ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. @@ -9,6 +10,12 @@ From Equations Require Import Equations. From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model Models PartialLoopChecking InitialSemilattice HornSemilatticeEquiv. +Module Autorew. + Import Ltac2. + #[global] Ltac2 autorewrite0 ids cl := + Std.autorewrite true None ids (default_on_concl cl). +End Autorew. + Set Equations Transparent. Module Type LoopCheckingItf (LS : LevelSets). @@ -62,7 +69,7 @@ Lemma init_model_levels cls k : LevelMap.In k (init_model cls) <-> LevelSet.In k (clauses_levels cls). Proof. split. - - now move => [] k' /max_clause_premises_spec. + - now move=> [] k' /max_clause_premises_spec. - move/max_clause_premises_spec_inv. now eexists. Qed. @@ -496,9 +503,97 @@ Proof. exists (y - z). now rewrite /min_atom_value (level_value_MapsTo hmap). Qed. +Ltac lset := + match goal with + | [ H : LevelSet.In _ (LevelSet.singleton _) |- _ ] => + apply LevelSet.singleton_spec in H; red in H; try subst + | [ H : LevelSet.In _ (LevelSet.add _ _) |- _ ] => + apply LevelSet.add_spec in H as [] + | [ H : LevelSet.mem _ _ = false |- _ ] => + apply LevelSetProp.FM.not_mem_iff in H + | [ H : LevelSet.mem _ _ = true |- _ ] => + apply LevelSetProp.FM.mem_iff in H + | [ H : LevelExprSet.In _ (LevelExprSet.singleton _) |- _ ] => + apply LevelExprSet.singleton_spec in H; red in H; try subst + | [ H : LevelExprSet.In _ (LevelExprSet.add _ _) |- _ ] => + apply LevelExprSet.add_spec in H as [] + | [ H : LevelMap.MapsTo _ _ (LevelMap.add _ _ _) |- _ ] => + rewrite LevelMapFact.F.add_mapsto_iff in H; unfold Level.eq in H + | [ H : LevelMap.MapsTo _ _ (LevelMap.empty _) |- _ ] => + rewrite LevelMapFact.F.empty_mapsto_iff in H; unfold Level.eq in H + | [ H : LevelSet.In _ (LevelSet.union _ _) |- _ ] => + apply LevelSet.union_spec in H as [] + | [ |- LevelSet.In _ (LevelSet.singleton _) ] => + apply LevelSet.singleton_spec; rewrite ?/LevelSet.E.eq + | [ |- LevelSet.In _ (LevelSet.add _) ] => + apply LevelSet.add_spec + | [ |- LevelSet.In _ (LevelSet.union _) ] => + apply LevelSet.union_spec + | [ |- LevelSet.In _ (LevelSet.singleton _) -> _ ] => + move/LevelSet.singleton_spec; rewrite ?/LevelSet.E.eq + | [ |- LevelSet.In _ (LevelSet.add _) -> _ ] => + move/LevelSet.add_spec + | [ |- LevelSet.In _ (LevelSet.union _) -> _ ] => + move/LevelSet.union_spec + end; try lsets. + +Hint Rewrite clauses_of_le_spec clauses_levels_spec + LevelSet.singleton_spec LevelSet.add_spec LevelSet.union_spec + LevelSetFact.is_empty_1 LevelSetFact.empty_iff + LevelExprSet.singleton_spec LevelExprSet.add_spec LevelExprSet.union_spec LevelExprSetFact.empty_iff + @NES.singleton_spec @NES.add_spec_les + Clauses.singleton_spec Clauses.add_spec Clauses.union_spec ClausesFact.empty_iff + LevelMapFact.F.add_mapsto_iff LevelMapFact.F.empty_mapsto_iff + : set_specs. + +Hint Rewrite <- LevelSetProp.FM.not_mem_iff LevelSetProp.FM.mem_iff : set_specs. + +Ltac rsets := repeat (progress (autorewrite with set_specs || lset || intro + || unfold Level.eq, LevelSet.E.eq in * )). + +Ltac2 Notation "rsets" cl(opt(clause)) := + let id := Option.get (Ident.of_string "set_specs") in + Autorew.autorewrite0 [id] cl. + +Definition init_clause_of_level l := + (singleton (l, if Level.is_global l then 1 else 0), (Level.zero, 0)). + +Definition declared_init_clause_of_level l cls := + if eqb l Level.zero then True + else Clauses.In (init_clause_of_level l) cls. + Module CorrectModel. + + Definition zero_declared m := + exists k, LevelMap.MapsTo Level.zero (Some (Z.of_nat k)) m. + + Lemma zero_declared_ext {m m'} : + zero_declared m -> + m ⩽ m' -> + zero_declared m'. + Proof. rewrite /zero_declared. + move=> [] k hm ext. red in ext. + move/ext: hm => -[] k' [hm' hle]; depelim hle. + exists (Z.to_nat y). rewrite Z2Nat.id //; by lia. + Qed. + + Definition above_zero_declared V cls := + forall l, LevelSet.In l V -> declared_init_clause_of_level l cls. + + Lemma above_zero_declared_ext {V cls cls'} : + above_zero_declared V cls -> + cls ⊂_clset cls' -> + above_zero_declared V cls'. + Proof. rewrite /above_zero_declared. rsets. + move: (H _ H1); unfold declared_init_clause_of_level. + case: (eqb_spec l Level.zero) => //. + intros nzero. clsets. + Qed. + Record t {V cls} := { initial_model : model; + declared_zero : zero_declared initial_model; + declared_above_zero : above_zero_declared V cls; enabled_model : enabled_clauses initial_model cls; only_model_of_V : only_model_of V initial_model; model_updates : LevelSet.t; @@ -506,6 +601,38 @@ Module CorrectModel. model_valid : valid_model V model_updates initial_model cls }. Arguments t : clear implicits. + Definition model_of {V cls} (x : t V cls) := x.(model_valid).(model_model). + + Lemma declared_zero_model_of {V cls} (x :t V cls) : zero_declared (model_of x). + Proof. + have h := declared_zero x. + have hupd := I.model_updates x.(model_valid). + eapply is_update_of_ext in hupd. + eapply zero_declared_ext; tea. + Qed. + + Equations? init_model : t (LevelSet.singleton Level.zero) Clauses.empty := + init_model := {| + initial_model := LevelMap.add Level.zero (Some 0) (LevelMap.empty _); + only_model_of_V := _; + model_updates := LevelSet.empty; |}. + Proof. + - exists 0%nat. rsets. left; auto. + - rsets. red. now rewrite eqb_refl. + - clsets. + - rsets. split. + * intros ->. exists (Some 0). rsets. now left. + * move=> [] k'. rsets. destruct p; intuition auto. + - lsets. + - refine {| model_model := LevelMap.add Level.zero (Some 0) (LevelMap.empty _) |}. + * red. rsets. exists (Some 0). rsets; firstorder. + * red. now rsets. + * now rsets. + * rewrite /is_model. eapply Clauses.for_all_spec. tc. now rsets. + Qed. + + + Record loop {cls} := { loop_univ : premises; loop_on_univ : cls ⊢a loop_univ → succ_prems loop_univ; @@ -520,8 +647,11 @@ Module CorrectModel. (hincl : only_model_of V init) (hs : clauses_levels cls ⊂_lset V) (cls' : clauses) - (hs' : clauses_levels cls' ⊂_lset V) : result V (Clauses.union cls cls') := - infer_extension_correct m enabled hincl hs cls' hs' with infer_extension m hincl hs cls' := + (hs' : clauses_levels cls' ⊂_lset V) + (hdeclz : zero_declared init) + (hdecla : above_zero_declared V (Clauses.union cls cls')) + : result V (Clauses.union cls cls') := + infer_extension_correct m enabled hincl hs cls' hs' hdeclz hdecla with infer_extension m hincl hs cls' := | Loop u isl => inr {| loop_univ := u; loop_on_univ := isl |} | Model w m' _ => inl {| @@ -530,6 +660,10 @@ Module CorrectModel. model_updates := w; clauses_declared := _; model_valid := {| model_model := m'.(model_model) |} |}. Proof. + - have [_ [_ hm]] := min_model_map_spec cls' (model_model m). + have mupd := I.model_updates m. eapply is_update_of_ext in mupd. + assert (hr := transitivity mupd hm). + eapply zero_declared_ext; tea. - eapply min_model_map_enabled. eapply enabled_clauses_ext. have mupd := I.model_updates m. eapply is_update_of_ext in mupd. exact mupd. @@ -551,12 +685,15 @@ Module CorrectModel. Equations? infer_extension_valid {V cls} (m : t V cls) cls' : option (result V (Clauses.union cls cls')) := infer_extension_valid m cls' with inspect (LevelSet.subset (clauses_levels cls') V) := | exist false heq => None - | exist true heq => Some (infer_extension_correct (model_valid m) _ _ _ cls' _). + | exist true heq => Some (infer_extension_correct (model_valid m) _ _ _ cls' _ _ _). Proof. - apply enabled_model. - apply only_model_of_V. - now apply m. - now apply LevelSet.subset_spec in heq. + - now apply m. + - apply LevelSet.subset_spec in heq. + eapply above_zero_declared_ext. now apply m. clsets. Qed. Lemma infer_extension_valid_None {V cls} (m : t V cls) cls' : @@ -576,38 +713,55 @@ Module Abstract. Record t := { levels : LevelSet.t; clauses : Clauses.t; - model : CorrectModel.t levels clauses }. + correct_model :> CorrectModel.t levels clauses }. Program Definition init_model : t := - {| levels := LevelSet.empty; + {| levels := LevelSet.singleton Level.zero; clauses := Clauses.empty; - model := _ |}. - Next Obligation. - refine {| initial_model := LevelMap.empty _; - only_model_of_V := _; - model_updates := LevelSet.empty; |}. - - red. intros cl hin; clsets. - - intros l. split. lsets. - intros [x hm]. now eapply LevelMapFact.F.empty_mapsto_iff in hm. - - now intros l; rewrite clauses_levels_spec. - - refine {| model_model := LevelMap.empty _ |}. - * red. lsets. - * red. rewrite (proj2 (LevelSet.is_empty_spec _)). lsets. - reflexivity. - * now intros l; rewrite clauses_conclusions_spec. - * rewrite /is_model. eapply Clauses.for_all_spec. tc. - intros x hin. now apply Clauses.empty_spec in hin. - Qed. + correct_model := CorrectModel.init_model |}. Lemma clauses_levels_declared m : clauses_levels (clauses m) ⊂_lset levels m. Proof. - exact m.(model).(CorrectModel.clauses_declared). + exact m.(correct_model).(CorrectModel.clauses_declared). Qed. Lemma init_model_levels : - levels init_model = LevelSet.empty. + levels init_model = LevelSet.singleton Level.zero. Proof. reflexivity. Qed. + Lemma zero_declared_in (m : model) : zero_declared m -> LevelMap.In Level.zero m. + Proof. intros [k hm]. now eexists. Qed. + + Definition model (x : t) := model_of x.(correct_model). + + Lemma zero_declared m : zero_declared (model m). + Proof. eapply declared_zero_model_of. Qed. + + Lemma above_zero_declared m : above_zero_declared (levels m) (clauses m). + Proof. eapply (declared_above_zero m). Qed. + + Lemma model_levels (m : t) : forall l, (exists k, LevelMap.MapsTo l (Some k) (initial_model m)) <-> LevelSet.In l (levels m). + Proof. + intros l. split. + - move=> [] k hm. + have hv := (only_model_of_V m.(correct_model)). + apply hv. now exists (Some k). + - intros hin. + have := above_zero_declared m _ hin. + rewrite /declared_init_clause_of_level. + case: (eqb_spec l Level.zero). + * move=> -> _. + have := CorrectModel.declared_zero m. + unfold CorrectModel.zero_declared. + now move=> [] k hm; exists (Z.of_nat k). + * intros nzero. + have he := enabled_model m. + move/he. rewrite /enabled_clause /init_clause_of_level. + move=> [] k hm. cbn in hm. rewrite min_premise_singleton /min_atom_value in hm. + destruct level_value eqn:hl => //. + exists z. apply (level_value_MapsTo' hl). + Qed. + Lemma init_model_clause : clauses init_model = Clauses.empty. Proof. reflexivity. Qed. @@ -624,13 +778,13 @@ Module Abstract. right; firstorder. Qed. - Lemma strictly_updates_add clauses W m m' l : + Lemma strictly_updates_add clauses W m m' l k : ~ LevelSet.In l (clauses_levels clauses) -> strictly_updates clauses W m m' -> - strictly_updates clauses W (LevelMap.add l None m) (LevelMap.add l None m'). + strictly_updates clauses W (LevelMap.add l k m) (LevelMap.add l k m'). Proof. move=> hnin su; move: W m m' su; - apply: strictly_updates_elim; [|move=>m [prems [concl k]] m' incl su|move=>ls ls' m m' m'' su ihsu su' ihsu']. + apply: strictly_updates_elim; [|move=>m [prems [concl k']] m' incl su|move=>ls ls' m m' m'' su ihsu su' ihsu']. { solve_proper. } - move: su => [] v [] hmin habov hm'. cbn. eapply update_one; tea => //. @@ -638,88 +792,221 @@ Module Abstract. * erewrite min_premise_preserved; tea. intros. have neq : x <> l. - { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (concl, k)). + { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (concl, k')). split => //. apply clause_levels_spec. now left. } rewrite /level_value. rewrite LevelMapFact.F.add_neq_o; auto. * have neq : concl <> l. - { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (l, k)). + { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (l, k')). split => //. apply clause_levels_spec. now right. } rewrite /level_value_above /level_value LevelMapFact.F.add_neq_o; auto. * have neq : concl <> l. - { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (l, k)). + { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (l, k')). split => //. apply clause_levels_spec. now right. } now rewrite levelmap_add_comm // hm'. - eapply trans_update; tea. Qed. - Lemma is_model_add clauses l m : + Lemma is_model_add clauses l k m : ~ LevelSet.In l (clauses_levels clauses) -> is_model clauses m -> - is_model clauses (LevelMap.add l None m). + is_model clauses (LevelMap.add l k m). Proof. move=> hnin ism. eapply Clauses.for_all_spec; tc => cl hin'. move/Clauses.for_all_spec: ism => /(_ _ hin'). - destruct cl as [prems [concl k]]. + destruct cl as [prems [concl k']]. move/valid_clause_elim => he. apply valid_clause_intro => z. erewrite (@min_premise_preserved _ m); tea. - move/he. have neq : concl <> l. - { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (l, k)). + { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (l, k')). split => //. apply clause_levels_spec. now right. } rewrite /level_value LevelMapFact.F.add_neq_o; auto. - intros x hin. have neq : x <> l. - { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (concl, k)). + { intros ->. apply hnin. apply clauses_levels_spec. exists (prems, (concl, k')). split => //. apply clause_levels_spec. now left. } rewrite /level_value. rewrite LevelMapFact.F.add_neq_o; auto. Qed. + Lemma clauses_For_all_add {cl cls} {P} : Clauses.For_all P (Clauses.add cl cls) <-> + P cl /\ Clauses.For_all P cls. + Proof. + rewrite /Clauses.For_all; split; rsets. + * split; intros; apply H; now rsets. + * destruct H0; subst; now rsets. + Qed. + Hint Rewrite @clauses_For_all_add : set_specs. + + Lemma enabled_clauses_add {m cl cls} : + enabled_clauses m (Clauses.add cl cls) <-> + enabled_clause m cl /\ enabled_clauses m cls. + Proof. + rewrite /enabled_clauses. now rsets. + Qed. + Hint Rewrite @enabled_clauses_add : set_specs. + + Lemma enabled_clause_init {l m k} : + enabled_clause (LevelMap.add l (Some k) (initial_model (correct_model m))) (init_clause_of_level l). + Proof. + red. + rewrite /init_clause_of_level //=. + setoid_rewrite min_premise_singleton. + rewrite /min_atom_value. setoid_rewrite level_value_add. + now eexists. + (* have [k ld] := declared_zero m.(model). + eexists. rewrite (level_value_MapsTo ld). reflexivity. *) + Qed. + + Lemma level_value_None (l : Level.t) {m : LevelMap.t _} : ~ LevelMap.In l m -> level_value m l = None. + Proof. + rewrite /level_value. destruct (find_spec l m) => //. + elim. now exists k. + Qed. + + Lemma level_value_add_other (l l' : Level.t) {k} {m : LevelMap.t _} : l <> l' -> level_value (LevelMap.add l k m) l' = level_value m l'. + Proof. + rewrite /level_value => hl. + destruct (find_spec l' m) => //. + Search LevelMap.find. + rewrite LevelMapFact.F.add_neq_o => //. + erewrite LevelMap.find_1; tea. reflexivity. + rewrite LevelMapFact.F.add_neq_o => //. + rewrite LevelMapFact.F.not_find_in_iff in H. + now rewrite H. + Qed. + + Instance lsets_po : PartialOrder LevelSet.Equal LevelSet.Subset. + Proof. + red. split. + - intros eq; split; try red; lsets. + - intros []. unfold flip in *; lsets. + Qed. + + Instance clsets_po : PartialOrder Clauses.Equal Clauses.Subset. + Proof. + red. split. + - intros eq; split; try red; clsets. + - intros []. unfold flip in *; clsets. + Qed. + + Instance levels_subset : Proper (Logic.eq ==> LevelSet.Subset ==> impl) LevelSet.In. + Proof. + intros ??-> ?? s hin. firstorder. + Qed. + + Lemma clauses_levels_add {cl cls} : clauses_levels (Clauses.add cl cls) =_lset LevelSet.union (clause_levels cl) (clauses_levels cls). + Proof. + intros ?; rewrite !clauses_levels_spec; rsets. + split. + - move=> [] cl'. rsets; subst. firstorder. now subst. + - intros []; firstorder. exists cl; firstorder; now rsets. + exists x. firstorder. now rsets. + Qed. + Hint Rewrite @clauses_levels_add : set_specs. + + Lemma levelexprset_singleton {l le} : (exists k : Z, LevelExprSet.In (l, k) (singleton le)) <-> (l, le.2) = le. + Proof. + split. + - move=> [] k. rsets. now subst le. + - intros <-. exists le.2; now rsets. + Qed. + Hint Rewrite @levelexprset_singleton : set_specs. + + Lemma levels_singleton le : NES.levels (LevelExprSet.singleton le) =_lset LevelSet.singleton le.1. + Proof. intros l; rewrite NES.levels_spec. rsets. split; intros h; subst. destruct h. rsets. exists le.2. + rsets. now destruct le. Qed. + Hint Rewrite levels_singleton : set_specs. + + Lemma clause_levels_init_constraint l : clause_levels (init_clause_of_level l) + =_lset (LevelSet.singleton Level.zero ∪ LevelSet.singleton l). + Proof. + rewrite /init_clause_of_level //=. + intros ?; rewrite clause_levels_spec; rsets; cbn; rsets; cbn. firstorder. + Qed. + Equations? declare_level (m : t) (l : Level.t) : option t := declare_level m l with inspect (LevelSet.mem l m.(levels)) := | exist true _ => None - | exist false hneq => Some {| levels := LevelSet.add l m.(levels); clauses := m.(clauses) |}. + | exist false hneq => Some {| levels := LevelSet.add l m.(levels); clauses := Clauses.add (init_clause_of_level l) m.(clauses) |}. Proof. - refine {| initial_model := LevelMap.add l None m.(model).(initial_model); + refine {| initial_model := LevelMap.add l (Some (if Level.is_global l then -1 else 0)) m.(initial_model); only_model_of_V := _; - model_updates := m.(model).(model_updates); |}. - - eapply enabled_clauses_ext. 2:apply m.(model).(enabled_model). - intros l' k hm. exists k. split => //. 2:reflexivity. - rewrite LevelMapFact.F.add_mapsto_iff. right. split => //. - intros ->. apply LevelSetProp.FM.not_mem_iff in hneq. apply hneq. - have hv := only_model_of_V m.(model). apply hv. - now exists k. + model_updates := m.(model_updates); |}. + - have hv := only_model_of_V m. + eapply zero_declared_ext. apply m.(correct_model). eapply update_model_monotone. + rsets; rewrite level_value_None. + { move=> hin'. apply hneq. + apply hv, hin'. } + constructor. + - intros l'. rsets. destruct H; subst. + * red. destruct eqb => //. clsets. + * have hv := declared_above_zero m.(correct_model). + eapply above_zero_declared_ext in H; tea. clsets. + - have hv := only_model_of_V m.(correct_model). + rewrite enabled_clauses_add. split; revgoals. + { eapply enabled_clauses_ext. + eapply update_model_not_above. rsets. + rewrite /level_value_above. + now rewrite level_value_None // => /hv. + apply m.(correct_model). } + apply enabled_clause_init. - intros k. rewrite LevelSet.add_spec /LevelSet.E.eq. rw LevelMapFact.F.add_mapsto_iff. - have hyp := m.(model).(only_model_of_V) k. + have hyp := m.(correct_model).(only_model_of_V) k. firstorder; subst. all:rewrite /Level.eq. - * now exists None. + * now eexists. * exists x. right; split => //. intros ->. apply LevelSetFact.not_mem_iff in hneq. contradiction. - - have hyp := m.(model).(clauses_declared). lsets. + - have hyp := m.(correct_model).(clauses_declared). + rsets. rewrite clause_levels_init_constraint in H. + move: H => []; rsets. destruct a0; subst. + * right. + have hd := declared_zero m.(correct_model). apply m.(only_model_of_V). + now apply zero_declared_in. + * now left. + * move: b => [] cl [] hin. right. + apply (clauses_levels_declared m a). rsets. firstorder. - destruct m as [levels clauses vm]; cbn in *. - destruct vm as [init en omofV W incl vm]. + destruct vm as [init zerod azerod en omofV W incl vm]. destruct vm as [M mofV mupd mcls mok]. cbn in *. - refine {| model_model := LevelMap.add l None M |}. + refine {| model_model := LevelMap.add l (Some (if Level.is_global l then -1 else 0)) M |}. * intros k. rewrite LevelSet.add_spec LevelMapFact.F.add_in_iff. firstorder. now left. * move: mupd; rewrite /is_update_of. destruct (LevelSet.is_empty) eqn:hw. now intros ->. { eapply levelset_not_Empty_is_empty in hw. apply LevelSetFact.not_mem_iff in hneq. - apply strictly_updates_add. - now move/incl. } - * lsets. + intros s. eapply strictly_updates_weaken; revgoals. + now eapply strictly_updates_add. now clsets. } + * rewrite clauses_conclusions_add. cbn. rsets. destruct H; subst. + + right. apply omofV. now apply zero_declared_in. + + right; lsets. * apply LevelSetFact.not_mem_iff in hneq. - apply is_model_add; tea. - now move/incl. + rewrite ClausesProp.add_union_singleton is_model_union //. + rewrite is_model_valid. + intros cl; rsets. subst cl. + rewrite /init_clause_of_level. + rewrite /valid_clause. cbn. rewrite min_premise_singleton //=. + rewrite level_value_add /level_value_above. + set value := Some _. + have hl : (value ≤ level_value (LevelMap.add l value M) Level.zero)%opt. + { rewrite level_value_add_other. intros ->. apply hneq. + { now apply omofV, zero_declared_in. } + eapply is_update_of_ext in mupd. + eapply zero_declared_ext in zerod; tea. + destruct zerod as [k hzero]. rewrite (level_value_MapsTo hzero). + subst value. constructor. destruct Level.is_global; lia. } + depelim hl. rewrite H0. + apply Z.leb_le. destruct Level.is_global; lia. + apply is_model_add => //. lsets => //. Qed. Lemma declare_level_clauses {m l m'} : - declare_level m l = Some m' -> clauses m = clauses m'. + declare_level m l = Some m' -> clauses m' = (Clauses.add (init_clause_of_level l) (clauses m)). Proof. funelim (declare_level m l) => //=. intros [= <-]. now cbn. @@ -743,9 +1030,9 @@ Module Abstract. Qed. Equations enforce_clauses (m : t) (cls : Clauses.t) : option (t + loop (Clauses.union (clauses m) cls)) := - enforce_clauses m cls with infer_extension_valid m.(model) cls := + enforce_clauses m cls with infer_extension_valid m.(correct_model) cls := | None => None - | Some (inl m') => Some (inl {| model := m' |}) + | Some (inl m') => Some (inl {| correct_model := m' |}) | Some (inr u) => Some (inr u). Lemma enforce_clauses_None m cls : @@ -753,7 +1040,7 @@ Module Abstract. ~ LevelSet.Subset (clauses_levels cls) (levels m). Proof. simp enforce_clauses. - have:= @infer_extension_valid_None _ _ (model m) cls. + have:= @infer_extension_valid_None _ _ (correct_model m) cls. destruct infer_extension_valid as [[]|]; simp enforce_clauses; split => //. 1-2:move/H => //. intuition. Qed. @@ -1053,7 +1340,7 @@ Module Abstract. Qed. Definition Z_valuation_of_model m := - to_Z_val (to_val (valuation_of_model m.(model).(model_valid).(model_model))). + to_Z_val (to_val (valuation_of_model (model m))). Lemma model_entails_succ m v : clauses m ⊢a v → succ v -> False. Proof. @@ -1062,10 +1349,10 @@ Module Abstract. move/(_ Z _ (Z_valuation_of_model m)). rewrite -!interp_rels_clauses_sem => /fwd. cbn in *. - have mok := m.(model).(model_valid).(model_ok). + have mok := m.(correct_model).(model_valid).(model_ok). eapply valid_clauses_model. - eapply enabled_clauses_ext, m.(model).(enabled_model). - now eapply (is_update_of_ext m.(model).(model_valid).(I.model_updates)). + eapply enabled_clauses_ext, m.(correct_model).(enabled_model). + now eapply (is_update_of_ext m.(correct_model).(model_valid).(I.model_updates)). exact mok. move/clauses_sem_leq. rewrite interp_add_prems. cbn. lia. @@ -1116,10 +1403,12 @@ Module LoopChecking (LS : LevelSets). Import Impl.I. Import Impl.Abstract. - Definition model := t. + Definition t := t. + + Definition model (x : t) : Model.model := model x. - Definition levels := levels. - Definition clauses := clauses. + Definition levels (x : t) := levels x. + Definition clauses (x : t) := clauses x. Lemma clauses_levels_declared m : clauses_levels (clauses m) ⊂_lset levels m. Proof. @@ -1128,7 +1417,7 @@ Module LoopChecking (LS : LevelSets). Notation univ := NES.t. - Import UnivConstraintType.ConstraintType (t, Le, Eq). + Import UnivConstraintType.ConstraintType (Le, Eq). Definition constraint := (univ * UnivConstraintType.ConstraintType.t * univ). @@ -1167,14 +1456,15 @@ Module LoopChecking (LS : LevelSets). declare_level m l = None <-> LevelSet.In l (levels m). Proof. apply declare_level_None. Qed. - Lemma declare_level_clauses l m m' : declare_level m l = Some m' -> Impl.Abstract.clauses m = Impl.Abstract.clauses m'. + Lemma declare_level_clauses l m m' : declare_level m l = Some m' -> + Impl.Abstract.clauses m' = Clauses.add (Impl.init_clause_of_level l) (Impl.Abstract.clauses m). Proof. apply declare_level_clauses. Qed. - Definition loop m c := Impl.CorrectModel.loop (Clauses.union (clauses m) (to_clauses c)). + Definition loop (m : t) c := Impl.CorrectModel.loop (Clauses.union (clauses m) (to_clauses c)). (* Returns either a model or a looping universe, i.e. such that u >= u + 1 is implied by the constraint *) - Definition enforce (m : model) c : option (model + loop m c) := + Definition enforce (m : t) c : option (t + loop m c) := enforce_clauses m (to_clauses c). Lemma enforce_None {m cls} : @@ -1189,22 +1479,24 @@ Module LoopChecking (LS : LevelSets). apply enforce_clauses_not_None. Qed. + Import Semilattice. Lemma enforce_inconsistent {m cls u} : enforce m cls = Some (inr u) -> - ~ exists V, clauses_sem V (Clauses.union (clauses m) (to_clauses cls)). + forall S (SL : Semilattice.Semilattice S Q.t) V, clauses_sem V (Clauses.union (clauses m) (to_clauses cls)) -> + clauses_sem V (Impl.CorrectModel.loop_univ u ≡ succ (Impl.CorrectModel.loop_univ u)). Proof. rewrite /enforce. move/enforce_clauses_inconsistent. rewrite -entails_L_rels_entails_L_clauses. rewrite -ISL.completeness_all. - move=> vr [] V. - specialize (vr Z _ V). + move=> vr S SL V. + specialize (vr S SL V). move: vr. rewrite !interp_rels_clauses_sem // => vr /vr. - rewrite -interp_rels_clauses_sem. + (* rewrite -interp_rels_clauses_sem. rewrite clauses_sem_eq. setoid_rewrite interp_add_prems; cbn -[Z.add]. - lia. + lia. *) Qed. Lemma enforce_clauses {m cls m'} : @@ -1238,7 +1530,7 @@ Module LoopChecking (LS : LevelSets). (* Returns the valuation of the model: a minimal assignement from levels to constraints that make the enforced clauses valid. *) - Definition valuation m := to_val (Model.valuation_of_model m.(Impl.Abstract.model).(Impl.CorrectModel.model_valid).(model_model)). + Definition valuation m := to_val (Model.valuation_of_model (model m)). Definition model_valuation m : clauses_sem (to_Z_val (valuation m)) (clauses m). Proof. @@ -1249,4 +1541,10 @@ Module LoopChecking (LS : LevelSets). - apply model_valid. Qed. + Lemma zero_declared m : Impl.CorrectModel.zero_declared (model m). + Proof. eapply zero_declared. Qed. + + Lemma above_zero_declared m : Impl.CorrectModel.above_zero_declared (levels m) (clauses m). + Proof. eapply above_zero_declared. Qed. + End LoopChecking. diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 625f1b7ba..895561d84 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -271,6 +271,15 @@ Module Clauses (LS : LevelSets). now rewrite LevelSet.union_spec LevelSet.singleton_spec. Qed. + Lemma clauses_levels_union cls cls' : clauses_levels (Clauses.union cls cls') =_lset + LevelSet.union (clauses_levels cls) (clauses_levels cls'). + Proof. + intros l. + rewrite clauses_levels_spec LevelSet.union_spec. + rw Clauses.union_spec; rewrite !clauses_levels_spec. + rw clause_levels_spec. firstorder. + Qed. + Definition clause_conclusion cl := level (concl cl). Definition clauses_conclusions (cls : clauses) : LevelSet.t := Clauses.fold (fun cl acc => LevelSet.add (level (concl cl)) acc) cls LevelSet.empty. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 019ce69c6..111f8b728 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -1434,7 +1434,7 @@ Module Model (LS : LevelSets). now apply Z.leb_le. intros h; depelim h. Qed. - Lemma level_value_add m l k : level_value (LevelMap.add l (Some k) m) l = Some k. + Lemma level_value_add m l k : level_value (LevelMap.add l k m) l = k. Proof. rewrite /level_value LevelMapFact.F.add_eq_o //. Qed. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 015ac3f09..f48b986e0 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -24,6 +24,13 @@ Module MoreLevel. Import Universes. Include Level. Definition to_string := string_of_level. + + Definition zero := Level.lzero. + Definition is_global l := + match l with + | Level.lvar _ | Level.lzero => false + | Level.level _ => true + end. End MoreLevel. Module LevelMap. @@ -373,8 +380,23 @@ End ZUnivConstraint. Module Clauses := LoopCheck.Impl.I.Model.Model.Clauses.Clauses. + Definition U0 : Universe.t := Universe.make (Level.lzero, 0%nat). + Definition U1 : Universe.t := Universe.singleton LevelExpr.type1. + + Definition init_constraint_of_level l := + match l with + | Level.lzero => None + | Level.level s => Some (U1, ConstraintType.Le, Universe.singleton (l, 0%nat)) + | Level.lvar n => Some (U0, ConstraintType.Le, Universe.singleton (l, 0%nat)) + end. + + Definition declared_init_constraint_of_level l cstrs := + match init_constraint_of_level l with + | None => True + | Some c => UnivConstraintSet.In c cstrs + end. Record univ_model := { - model : LoopCheck.model; + model :> LoopCheck.t; constraints : UnivConstraintSet.t; repr_constraints : forall c, UnivConstraintSet.In c constraints -> Clauses.Subset (LoopCheck.to_clauses (to_constraint c)) (LoopCheck.Impl.Abstract.clauses model); @@ -382,6 +404,18 @@ End ZUnivConstraint. exists c, UnivConstraintSet.In c constraints /\ Clauses.In cl (LoopCheck.to_clauses (to_constraint c)) }. + Import LoopCheck.Impl.CorrectModel. + + Lemma declared_zero (m : univ_model) : LevelSet.In Level.lzero (LoopCheck.levels m.(model)). + Proof. + have := LoopCheck.zero_declared m.(model). + rewrite /zero_declared. + move=> [k hm]. + declared_levels : + forall l, LevelSet.In l (LoopCheck.levels model) -> declared_init_constraint_of_level l constraints; + + + Module C := LoopCheck.Impl.I.Model.Model.Clauses. Import C. @@ -445,69 +479,26 @@ End ZUnivConstraint. init_model := {| model := LoopCheck.init_model; constraints := UnivConstraintSet.empty |}. Proof. - move: H. now rewrite UnivConstraintSetFact.empty_iff. - move: H. now rewrite ClausesFact.empty_iff. + - LoopCheck.Impl.rsets. + - LoopCheck.Impl.rsets. move: H; rewrite LevelSet.add_spec => -[->|h]. + now cbn. lsets. + - move: H. now rewrite UnivConstraintSetFact.empty_iff. + - move: H. now rewrite ClausesFact.empty_iff. Qed. Local Obligation Tactic := idtac. - Local Definition declare_levels_aux m l := - LevelSet.fold (fun l m => match LoopCheck.declare_level m l return _ with None => m | Some m => m end) l m. - - Lemma declare_levels_aux_spec m l : LoopCheck.levels (declare_levels_aux m l) =_lset - LevelSet.union l (LoopCheck.levels m). - Proof. - rewrite /declare_levels_aux. - eapply LevelSetProp.fold_rec. - - move=> s' he. lsets. - - move=> x a s' s'' hin hnin hadd heq. - apply LevelSetProp.Add_Equal in hadd. - destruct LoopCheck.declare_level eqn:decl. - * apply LoopCheck.declare_level_levels in decl as [hnin' ->]. - rewrite hadd heq. lsets. - * apply LoopCheck.declare_level_None in decl. - rewrite heq hadd. - rewrite heq LevelSet.union_spec in decl. - destruct decl => //. lsets. - Qed. - - Lemma declare_levels_aux_clauses m l : - LoopCheck.clauses (declare_levels_aux m l) =_clset LoopCheck.clauses m. - Proof. - rewrite /declare_levels_aux. - eapply LevelSetProp.fold_rec. - - move=> s' he. clsets. - - move=> x a s' s'' hin hnin hadd heq. - apply LevelSetProp.Add_Equal in hadd. - destruct LoopCheck.declare_level eqn:hd => //. - rewrite -heq. - apply LoopCheck.declare_level_clauses in hd. - unfold LoopCheck.clauses. - now rewrite hd. - Qed. - - (* We ignore errors here, which can happen only if the levels are already declared *) - Program Definition declare_levels (m : univ_model) (l : LevelSet.t) := - {| model := declare_levels_aux m.(model) l; constraints := m.(constraints); |}. - Next Obligation. - Proof. - intros m l c. - rewrite [LoopCheck.Impl.Abstract.clauses _]declare_levels_aux_clauses => hin. - move: (repr_constraints m c hin) => h. - etransitivity; tea. reflexivity. - Qed. - Next Obligation. - move=> m l cl. - rewrite [LoopCheck.Impl.Abstract.clauses _]declare_levels_aux_clauses => hin. - now exact: repr_constraints_inv m cl hin. - Qed. - Equations? enforce m (c : UnivConstraint.t) : option _ := enforce m c with inspect (LoopCheck.enforce m.(model) (to_constraint c)) := | exist None eq => None | exist (Some (inl m')) eq => Some (inl {| model := m'; constraints := UnivConstraintSet.add c m.(constraints) |}) | exist (Some (inr loop)) eq => Some (inr loop). Proof. + - move/LoopCheck.enforce_levels: eq0. intros eq; rewrite eq. apply m. + - move/LoopCheck.enforce_levels: eq0. intros eq; rewrite eq. + have hd := declared_levels m. + move=> l /hd. rewrite /declared_init_constraint_of_level. + destruct init_constraint_of_level => //. ucsets. - move=> c'. move/LoopCheck.enforce_clauses: eq0. rewrite /LoopCheck.clauses => ->. rewrite UnivConstraintSet.add_spec => -[]. @@ -524,15 +515,6 @@ End ZUnivConstraint. rewrite UnivConstraintSet.add_spec. now left. Qed. - Lemma clauses_levels_union cls cls' : clauses_levels (Clauses.union cls cls') =_lset - LevelSet.union (clauses_levels cls) (clauses_levels cls'). - Proof. - intros l. - rewrite clauses_levels_spec LevelSet.union_spec. - rw Clauses.union_spec; rewrite !clauses_levels_spec. - rw clause_levels_spec. firstorder. - Qed. - Definition univ_constraint_levels (c : UnivConstraint.t) := let '(l, d, r) := c in LevelSet.union (Universe.levels l) (Universe.levels r). @@ -629,6 +611,138 @@ End ZUnivConstraint. - clear H Heqcall. reflexivity. Qed. + Lemma declared_init_constraint_of_level_spec {l c cstrs}: + init_constraint_of_level l = Some c -> + declared_init_constraint_of_level l (UnivConstraintSet.add c cstrs). + Proof. + rewrite /declared_init_constraint_of_level => ->. ucsets. + Qed. + + Lemma declared_init_constraint_of_level_add' {l c cstrs}: + declared_init_constraint_of_level l cstrs -> + declared_init_constraint_of_level l (UnivConstraintSet.add c cstrs). + Proof. + rewrite /declared_init_constraint_of_level. destruct init_constraint_of_level => //. ucsets. + Qed. + + (* We ignore errors here, which can happen only if the levels are already declared *) + Equations? declare_level (m : univ_model) (l : Level.t) : option univ_model := + declare_level m l with inspect (LoopCheck.declare_level m.(model) l) := + { | exist (Some model) eq with inspect (init_constraint_of_level l) := + { | exist (Some c) eqc with inspect (LoopCheck.enforce model (to_constraint c)) := + { | exist (Some (inl m')) _ => Some {| model := m'; constraints := UnivConstraintSet.add c m.(constraints) |} + | exist (Some (inr _)) _ => False_rect _ _ + | exist None eqm => False_rect _ _ } + | exist None eqc => False_rect _ _ } ; + | exist None eqdecl := None }. + Proof. + Import LoopCheck.Impl.Abstract LoopCheck. + - move/LoopCheck.declare_level_levels: eq0 => -[] hnin. + move/LoopCheck.enforce_levels: e => eq. rewrite eq. intros ->. + have := declared_zero m. lsets. + - move/LoopCheck.declare_level_levels: eq0 => -[] hnin eq l'. + move/LoopCheck.enforce_levels: e => eq'. rewrite eq'. + rewrite eq. rewrite LevelSet.add_spec => -[]. + * intros ->. now apply declared_init_constraint_of_level_spec. + * intros. apply declared_init_constraint_of_level_add'. + now apply declared_levels. + - move/LoopCheck.enforce_clauses: e. + move/LoopCheck.declare_level_clauses: eq0 => eqcl. + intros eq c'. + rewrite UnivConstraintSet.add_spec => -[]; intros h; rewrite [_ m']eq => l'; rewrite Clauses.union_spec. + now right. subst. setoid_rewrite <- eqcl. left. + now apply (repr_constraints _ _ h). + - move/LoopCheck.enforce_clauses: e. + move/LoopCheck.declare_level_clauses: eq0 => eqcl. + intros eq c'. setoid_rewrite eq. rewrite Clauses.union_spec; setoid_rewrite <- eqcl. + move=> [] h. + * have [ec [? ?]] := repr_constraints_inv _ _ h. exists ec. + split => //. ucsets. + * exists c. split => //. ucsets. + - move/LoopCheck.enforce_inconsistent: e. + have val := LoopCheck.model_valuation model0. + destruct l; cbn in eqc => //; noconf eqc. + move=> hv. + pose (l' := fun l => if eqb l (Level.level t0) then 1%Z else (to_Z_val (valuation model0) l)). + move: (hv Z Zsemilattice l'). + move/LoopCheck.declare_level_levels: eq0 => -[] hnin heq. + move=> /fwd. + setoid_rewrite LoopCheck.Impl.Abstract.clauses_sem_union. + split. admit. cbn. unfold flip. + cbn. rewrite clauses_sem_add; cbn -[Z.add]. + rewrite Z.add_0_l. admit. + rewrite clauses_sem_eq. cbn. + setoid_rewrite interp_add_prems; cbn -[Z.add]. lia. + + rewrite UnivConstraintSet.add_spec => -[]; intros h; rewrite [_ m']eq => l'; + now right. subst. setoid_rewrite <- eqcl. left. + now apply (repr_constraints _ _ h). + - + * intros hin [_ m']eq => l'. + + + + {| model := declare_levels_aux m.(model) l; + constraints := m.(constraints); |}. + Next Obligation. + + Local Definition declare_levels_aux m l := + LevelSet.fold (fun l m => + match LoopCheck.declare_level m l return _ with + | None => m + | Some m => m + end) l m. + + Lemma declare_levels_aux_spec m l : LoopCheck.levels (declare_levels_aux m l) =_lset + LevelSet.union l (LoopCheck.levels m). + Proof. + rewrite /declare_levels_aux. + eapply LevelSetProp.fold_rec. + - move=> s' he. lsets. + - move=> x a s' s'' hin hnin hadd heq. + apply LevelSetProp.Add_Equal in hadd. + destruct LoopCheck.declare_level eqn:decl. + * apply LoopCheck.declare_level_levels in decl as [hnin' ->]. + rewrite hadd heq. lsets. + * apply LoopCheck.declare_level_None in decl. + rewrite heq hadd. + rewrite heq LevelSet.union_spec in decl. + destruct decl => //. lsets. + Qed. + + Lemma declare_levels_aux_clauses m l : + LoopCheck.clauses (declare_levels_aux m l) =_clset LoopCheck.clauses m. + Proof. + rewrite /declare_levels_aux. + eapply LevelSetProp.fold_rec. + - move=> s' he. clsets. + - move=> x a s' s'' hin hnin hadd heq. + apply LevelSetProp.Add_Equal in hadd. + destruct LoopCheck.declare_level eqn:hd => //. + rewrite -heq. + apply LoopCheck.declare_level_clauses in hd. + unfold LoopCheck.clauses. + now rewrite hd. + Qed. + + (* We ignore errors here, which can happen only if the levels are already declared *) + Program Definition declare_levels (m : univ_model) (l : LevelSet.t) := + {| model := declare_levels_aux m.(model) l; + constraints := m.(constraints); |}. + Next Obligation. + Proof. + intros m l c. + rewrite [LoopCheck.Impl.Abstract.clauses _]declare_levels_aux_clauses => hin. + move: (repr_constraints m c hin) => h. + etransitivity; tea. reflexivity. + Qed. + Next Obligation. + move=> m l cl. + rewrite [LoopCheck.Impl.Abstract.clauses _]declare_levels_aux_clauses => hin. + now exact: repr_constraints_inv m cl hin. + Qed. + + Definition to_valuation (v : Level.t -> nat) : valuation := {| valuation_mono := fun s => Pos.of_nat (v (Level.level s)); valuation_poly := fun i => v (Level.lvar i); diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v index ac20b5cbc..c885cef4e 100644 --- a/utils/theories/NonEmptyLevelExprSet.v +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -13,6 +13,8 @@ End OrderedTypeWithLeibniz. Module Type OrderedTypeWithLeibnizWithReflect. Include OrderedTypeWithLeibniz. + Parameter zero : t. + Parameter is_global : t -> bool. Parameter reflect_eq : ReflectEq t. Parameter to_string : t -> string. End OrderedTypeWithLeibnizWithReflect. @@ -157,6 +159,9 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) apply nis_empty => he. eapply (he e). lesets. Qed. + Lemma singleton_spec {le e} : LevelExprSet.In le (singleton e) <-> le = e. + Proof. rewrite LevelExprSet.singleton_spec. reflexivity. Qed. + Lemma not_Empty_is_empty s : ~ LevelExprSet.Empty s <-> LevelExprSet.is_empty s = false. Proof. now rewrite nis_empty. Qed. @@ -169,6 +174,9 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) left; reflexivity. Qed. + Lemma add_spec_les {le e es} : LevelExprSet.In le (add e es) <-> LevelExprSet.In le (LevelExprSet.add e es). + Proof. reflexivity. Qed. + Lemma add_spec e u e' : In e' (add e u) <-> e' = e \/ In e' u. Proof. From cf146dad8443fc8ad07d9304af3b71e97f2a313a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 29 Sep 2025 06:36:21 +0200 Subject: [PATCH 075/164] Invariants on valuations for zero/global/local verified --- common/theories/LoopChecking/Deciders.v | 512 ++++++++++++++---- common/theories/LoopChecking/Model.v | 62 ++- .../theories/LoopChecking/UnivLoopChecking.v | 179 +++--- utils/theories/NonEmptyLevelExprSet.v | 1 + 4 files changed, 544 insertions(+), 210 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 3b9b2639d..763569ea0 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -556,7 +556,7 @@ Ltac2 Notation "rsets" cl(opt(clause)) := Autorew.autorewrite0 [id] cl. Definition init_clause_of_level l := - (singleton (l, if Level.is_global l then 1 else 0), (Level.zero, 0)). + (singleton (l, 0), (Level.zero, if Level.is_global l then 1 else 0)). Definition declared_init_clause_of_level l cls := if eqb l Level.zero then True @@ -565,7 +565,7 @@ Definition declared_init_clause_of_level l cls := Module CorrectModel. Definition zero_declared m := - exists k, LevelMap.MapsTo Level.zero (Some (Z.of_nat k)) m. + exists k, LevelMap.MapsTo Level.zero (Some (Z.of_nat (S k))) m. Lemma zero_declared_ext {m m'} : zero_declared m -> @@ -573,8 +573,27 @@ Module CorrectModel. zero_declared m'. Proof. rewrite /zero_declared. move=> [] k hm ext. red in ext. - move/ext: hm => -[] k' [hm' hle]; depelim hle. - exists (Z.to_nat y). rewrite Z2Nat.id //; by lia. + move/ext: hm => -[] k' [hm' hle]. + rewrite Nat2Z.inj_succ in hle. depelim hle. + setoid_rewrite Nat2Z.inj_succ. + exists (Z.to_nat (Z.pred y)). + rewrite Z2Nat.id //. by lia. + have -> : Z.succ (Z.pred y) = y. lia. + exact hm'. + Qed. + + Definition declared_pos V (m : model) := + forall l, LevelSet.In l V -> exists k, LevelMap.MapsTo l (Some (Z.of_nat k)) m. + + Lemma declared_pos_ext {V} {m m' : model} : + declared_pos V m -> + m ⩽ m' -> + declared_pos V m'. + Proof. rewrite /declared_pos. + move=> hl ext l /hl [] k /ext [] k' [] hm' hle. + depelim hle. + exists (Z.to_nat y). + rewrite Z2Nat.id //. by lia. Qed. Definition above_zero_declared V cls := @@ -593,6 +612,7 @@ Module CorrectModel. Record t {V cls} := { initial_model : model; declared_zero : zero_declared initial_model; + declared_positive : declared_pos V initial_model; declared_above_zero : above_zero_declared V cls; enabled_model : enabled_clauses initial_model cls; only_model_of_V : only_model_of V initial_model; @@ -602,6 +622,7 @@ Module CorrectModel. Arguments t : clear implicits. Definition model_of {V cls} (x : t V cls) := x.(model_valid).(model_model). + Coercion model_of : t >-> model. Lemma declared_zero_model_of {V cls} (x :t V cls) : zero_declared (model_of x). Proof. @@ -611,28 +632,47 @@ Module CorrectModel. eapply zero_declared_ext; tea. Qed. + Lemma declared_pos_model_of {V cls} (x :t V cls) : declared_pos V (model_of x). + Proof. + have h := declared_positive x. + have hupd := I.model_updates x.(model_valid). + eapply is_update_of_ext in hupd. + eapply declared_pos_ext; tea. + Qed. + + (* Lemma zero_is_max {V cls} (x : t V cls) : + level_value (model_of x) Level.zero = Some (model_max (model_of x)). + Proof. + intros hl. + have ha : forall l, (level_value (model_of x) l ≤ level_value (model_of x) Level.zero)%opt. + { admit. } + have hmax := model_max_spec. + have hmax' := model_max_spec2. + Print model_max. + + *) + + Equations? init_model : t (LevelSet.singleton Level.zero) Clauses.empty := init_model := {| - initial_model := LevelMap.add Level.zero (Some 0) (LevelMap.empty _); + initial_model := LevelMap.add Level.zero (Some 1) (LevelMap.empty _); only_model_of_V := _; model_updates := LevelSet.empty; |}. Proof. - exists 0%nat. rsets. left; auto. + - exists 1%nat. rsets. - rsets. red. now rewrite eqb_refl. - clsets. - rsets. split. - * intros ->. exists (Some 0). rsets. now left. + * intros ->. exists (Some 1). rsets. now left. * move=> [] k'. rsets. destruct p; intuition auto. - lsets. - - refine {| model_model := LevelMap.add Level.zero (Some 0) (LevelMap.empty _) |}. - * red. rsets. exists (Some 0). rsets; firstorder. + - refine {| model_model := LevelMap.add Level.zero (Some 1) (LevelMap.empty _) |}. + * red. rsets. exists (Some 1). rsets; firstorder. * red. now rsets. * now rsets. * rewrite /is_model. eapply Clauses.for_all_spec. tc. now rsets. Qed. - - - Record loop {cls} := { loop_univ : premises; loop_on_univ : cls ⊢a loop_univ → succ_prems loop_univ; @@ -650,8 +690,9 @@ Module CorrectModel. (hs' : clauses_levels cls' ⊂_lset V) (hdeclz : zero_declared init) (hdecla : above_zero_declared V (Clauses.union cls cls')) + (declp : declared_pos V init) : result V (Clauses.union cls cls') := - infer_extension_correct m enabled hincl hs cls' hs' hdeclz hdecla with infer_extension m hincl hs cls' := + infer_extension_correct m enabled hincl hs cls' hs' hdeclz hdecla hdeclp with infer_extension m hincl hs cls' := | Loop u isl => inr {| loop_univ := u; loop_on_univ := isl |} | Model w m' _ => inl {| @@ -664,6 +705,11 @@ Module CorrectModel. have mupd := I.model_updates m. eapply is_update_of_ext in mupd. assert (hr := transitivity mupd hm). eapply zero_declared_ext; tea. + - move=> l inv. + have [_ [_ hm]] := min_model_map_spec cls' (model_model m). + have mupd := I.model_updates m. eapply is_update_of_ext in mupd. + assert (hr := transitivity mupd hm). + eapply declared_pos_ext; tea. - eapply min_model_map_enabled. eapply enabled_clauses_ext. have mupd := I.model_updates m. eapply is_update_of_ext in mupd. exact mupd. @@ -685,7 +731,7 @@ Module CorrectModel. Equations? infer_extension_valid {V cls} (m : t V cls) cls' : option (result V (Clauses.union cls cls')) := infer_extension_valid m cls' with inspect (LevelSet.subset (clauses_levels cls') V) := | exist false heq => None - | exist true heq => Some (infer_extension_correct (model_valid m) _ _ _ cls' _ _ _). + | exist true heq => Some (infer_extension_correct (model_valid m) _ _ _ cls' _ _ _ _). Proof. - apply enabled_model. - apply only_model_of_V. @@ -694,6 +740,7 @@ Module CorrectModel. - now apply m. - apply LevelSet.subset_spec in heq. eapply above_zero_declared_ext. now apply m. clsets. + - now apply m. Qed. Lemma infer_extension_valid_None {V cls} (m : t V cls) cls' : @@ -706,6 +753,321 @@ Module CorrectModel. move/negP: heq => /LevelSet.subset_spec. contradiction. Qed. + Lemma initial_model_levels {V cls} (m : t V cls) : forall l, (exists k, LevelMap.MapsTo l (Some k) (initial_model m)) <-> LevelSet.In l V. + Proof. + intros l. split. + - move=> [] k hm. + have hv := (only_model_of_V m). + apply hv. now exists (Some k). + - intros hin. + have := declared_above_zero m _ hin. + rewrite /declared_init_clause_of_level. + case: (eqb_spec l Level.zero). + * move=> ->. + have := CorrectModel.declared_zero m. + unfold CorrectModel.zero_declared. + now move=> [] k hm; exists (Z.of_nat (S k)). + * intros nzero. + have he := enabled_model m. + move/he. rewrite /enabled_clause /init_clause_of_level. + move=> [] k hm. cbn in hm. + rewrite min_premise_singleton /min_atom_value in hm. + destruct level_value eqn:hl => //. + exists z. apply (level_value_MapsTo' hl). + Qed. + + + Definition clause_sem {S} {SL : Semilattice S Q.t} (V : Level.t -> S) (cl : clause) : Prop := + let '(prems, concl) := cl in + le (interp_expr V concl) (interp_prems V prems). + + Definition clauses_sem {S} {SL : Semilattice S Q.t} (V : Level.t -> S) (cls : Clauses.t) : Prop := + Clauses.For_all (clause_sem V) cls. + + + Definition to_val (v : LevelMap.t nat) l := + match LevelMap.find l v with + | Some n => n + | None => 0%nat + end. + + Definition to_Z_val (v : Level.t -> nat) := fun l => Z.of_nat (v l). + + Definition valuation m := to_val (Model.valuation_of_model m). + + Lemma valuation_range {m l k} : + LevelMap.MapsTo l (Some k) m -> + model_min m <= k <= model_max m. + Proof. + move=> hm. + have mins := model_min_spec m _ _ hm. + have maxs := model_max_spec m _ _ hm. + depelim maxs. lia. + Qed. + + (** Enabled and valid clauses are satisfied by valuation. + *) + Lemma valid_clause_model model cl : + enabled_clause model cl -> + valid_clause model cl -> + clause_sem (to_Z_val (to_val (valuation_of_model model))) cl. + Proof. + unfold enabled_clause, valid_clause. + destruct min_premise eqn:hmin => //= => //. + 2:{ intros [k' eq]. congruence. } + intros [k' eq]. noconf eq. + destruct cl as [prems [concl k]]. cbn -[le]. + unfold level_value_above. + destruct level_value eqn:hl => //. + unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. + move/Z.leb_le => hrel. + eapply LevelMap.find_2 in hfind. + have conclm := valuation_of_model_spec _ _ _ hfind. + set (v := (model_max _ - _)) in *. + cbn in conclm. + eapply LevelMap.find_1 in conclm. + subst v. + pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. + rewrite hmin in premeq. + eapply transitivity. 2:{ eapply interp_prems_ge; tea. } + unfold interp_expr. destruct prem as [prem k']. + symmetry in premeq. + move: premeq. unfold min_atom_value. + unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. + destruct o => //. + intros [= <-]. + eapply LevelMap.find_2 in findp. + have premm := valuation_of_model_spec _ _ _ findp. + eapply LevelMap.find_1 in premm. + assert (z1 - k' <= z0 - k). lia. + have [z0min z0max] := valuation_range hfind. + have [z1min z1max] := valuation_range findp. + assert (0 <= model_max model)%Z by apply model_max_spec2. + assert (model_min model <= 0)%Z by apply model_min_spec2. + rewrite /to_Z_val /to_val premm conclm. + cbn. lia. + Qed. + + Lemma valid_clauses_model model cls : + enabled_clauses model cls -> + is_model cls model -> + clauses_sem (to_Z_val (to_val (valuation_of_model model))) cls. + Proof. + move=> en ism cl hin. + apply valid_clause_model. + now apply en. + now move/Clauses.for_all_spec: ism; apply. + Qed. + + Definition model_valuation {V cls} (m : t V cls) : clauses_sem (to_Z_val (valuation (model_of m))) cls. + Proof. + destruct m as []; cbn. + apply valid_clauses_model; tea; cbn. + - eapply enabled_clauses_ext; tea. + eapply is_update_of_ext, model_valid0. + - apply model_valid. + Qed. + + Lemma is_update_of_only_model_of {V cls W m m'} : + only_model_of V m -> + is_update_of cls W m m' -> + clauses_conclusions cls ⊂_lset V -> + only_model_of V m'. + Proof. + intros om. + move/is_update_of_case => -[]. + - move=> [] he heq. now rewrite -heq. + - move/[dup]/strictly_updates_only_model_gen. + move/(_ _ om) => om' /strictly_updates_incl incl incl'. + have he : (V ∪ W) =_lset V. + { lsets. } + now rewrite he in om'. + Qed. + + Lemma model_levels {V cls} (m : t V cls) : + forall l, LevelSet.In l V <-> (exists k, LevelMap.MapsTo l (Some k) (model_valid m).(model_model)). + Proof. + intros l. rewrite -initial_model_levels. split. + - move=> [] k hm. + have hupd := (I.model_updates m.(model_valid)). + apply is_update_of_ext in hupd. + eapply hupd in hm as [k' [hm hle]]. + depelim hle. now exists y. + - intros hin. + rewrite initial_model_levels. + have hv := only_model_of_V m. + have hupd := (I.model_updates m.(model_valid)). + eapply is_update_of_only_model_of in hupd; tea. + destruct hin as [k hm]. apply hupd. now exists (Some k). + apply (model_valid m). + Qed. + + Lemma model_zero_level {V cls} (m : t V cls) : + exists k, LevelMap.MapsTo Level.zero (Some k) (model_valid m).(model_model) /\ 0 < k. + Proof. + have [k hm] := declared_zero m. + have hupd := I.model_updates m.(model_valid). + move/is_update_of_ext: hupd. + move/(_ _ _ hm) => [k' [hm' ha]]. rewrite Nat2Z.inj_succ in ha. depelim ha. + exists y; split => //. rewrite -Nat2Z.inj_succ in H. clear - H. cbn in *. lia. + Qed. + + Lemma initial_model_min {V cls} (m : t V cls) : model_min (initial_model m) = 0. + Proof. + have minlt := model_min_spec2 (initial_model m). + apply antisymmetry => //. + have mins := model_min_spec. + have [?|[l [k [mapmin ismin]]]] := model_has_min (initial_model m); try lia. + rewrite ismin. + have := (declared_positive m l) => /fwd. + { rewrite -initial_model_levels; now eexists. } + move=> [] k' hm. + eapply LevelMapFact.F.MapsTo_fun in mapmin; tea. noconf mapmin. lia. + Qed. + + Lemma model_min_ext {V m m'} : + defined_model_of V m -> + only_model_of V m' -> + m ⩽ m' -> + model_min m <= model_min m'. + Proof. + move=> om om' hext. + have ms := model_min_spec m. + have ms' := model_min_spec m'. + (* have [m0|mhas] := model_has_min m. *) + have [m0'|[l [k [mhas' kle]]]] := model_has_min m'; try lia. + have ms2 := (model_min_spec2 m). lia. + specialize (om l). + forward om. rewrite om'. now exists (Some k). + destruct om as [lk hmk]. + move: hmk => /[dup]/ms hle /hext [k' [hm' hle']]. depelim hle'. + eapply LevelMapFact.F.MapsTo_fun in mhas'; tea. noconf mhas'. rewrite kle. lia. + Qed. + + Lemma model_min_0 {V cls} (m : t V cls) : model_min m = 0. + Proof. + have initm := initial_model_min m. + have hupd := I.model_updates m.(model_valid). + move/is_update_of_ext: hupd => ext. + have := model_min_ext (V:=V) _ _ ext => /fwd. + { intros l. now rewrite initial_model_levels. } + move=> /fwd. + { apply (valid_model_only_model _ _ _ _ (model_valid m)). + eapply m. } + move=> hle. + have minupd := model_min_spec2 m. + rewrite initm in hle. rewrite -/(model_of m) in ext hle. lia. + Qed. + + Lemma model_max {V cls} {m : t V cls}: forall l k, LevelMap.MapsTo l (Some k) (model_of m) -> + (Some k ≤ level_value (model_of m) (Level.zero))%opt. + Proof. + intros l k hm. + have hab := declared_above_zero m l. + rewrite (model_levels m) in hab. + forward hab by now eexists. + red in hab. + move: hab hm; case: (eqb_spec l Level.zero). + * move=> -> _ hm. + now rewrite (level_value_MapsTo hm). + * move=> nz hin hm. + have hv := model_valuation m. + apply hv in hin. + move: hin; rewrite /clause_sem /init_clause_of_level //=. + rewrite interp_prems_singleton //=. + rewrite /to_Z_val /to_val /valuation /to_val. + have vs:= valuation_of_model_spec _ _ _ hm. + rewrite (LevelMap.find_1 vs). + have [kz [hz hzpos]] := model_zero_level m. + have vzs := valuation_of_model_spec _ _ _ hz. + rewrite (LevelMap.find_1 vzs). cbn. rewrite -/(model_of m). + rewrite (level_value_MapsTo hz). + intros ineq; constructor. + destruct (Level.is_global) eqn:isg. + + lia. + + cbn in ineq. + have hk := valuation_range hm. + have hk' := valuation_range hz. + rewrite -/(model_of m) in hk'. + have mmax := model_max_spec2 (model_of m). + have mmin := model_min_spec2 (model_of m). + lia. + Qed. + + Lemma model_max_gen {V cls} {m : t V cls} {l k} : LevelMap.MapsTo l (Some k) (model_of m) -> + (if Level.is_global l then + (to_val (valuation_of_model (model_of m)) Level.zero) < (to_val (valuation_of_model (model_of m)) l) + else + (to_val (valuation_of_model (model_of m)) Level.zero) <= (to_val (valuation_of_model (model_of m)) l))%nat. + Proof. + intros hm. + have hab := declared_above_zero m l. + rewrite (model_levels m) in hab. + forward hab by now eexists. + red in hab. + move: hab hm; case: (eqb_spec l Level.zero). + * move=> -> _ hm. + have := Level.is_global_zero. + destruct Level.is_global => //. + * move=> nz hin hm. + have hv := model_valuation m. + apply hv in hin. + move: hin; rewrite /clause_sem /init_clause_of_level //=. + rewrite interp_prems_singleton //=. + rewrite /to_Z_val /to_val /valuation /to_val. + have vs:= valuation_of_model_spec _ _ _ hm. + rewrite (LevelMap.find_1 vs). + have [kz [hz hzpos]] := model_zero_level m. + have vzs := valuation_of_model_spec _ _ _ hz. + rewrite (LevelMap.find_1 vzs). cbn. rewrite -/(model_of m). + intros ineq. + destruct (Level.is_global) eqn:isg. + + lia. + + cbn in ineq. + have hk := valuation_range hm. + have hk' := valuation_range hz. + rewrite -/(model_of m) in hk'. + have mmax := model_max_spec2 (model_of m). + have mmin := model_min_spec2 (model_of m). + lia. + Qed. + + Lemma valuation_0 {V cls} {m : t V cls}: to_val (valuation_of_model (model_of m)) Level.zero = 0%nat. + Proof. + have mmax := model_max_spec2 m. + have mmin := model_min_spec2 m. + have mmax' := model_has_max m. + have [kzero [hzero hpos]] := model_zero_level m. + have zerom := model_max_spec m _ _ hzero. depelim zerom. + destruct mmax'. rewrite H0 in H. cbn in *. lia. + destruct H0 as [l' [k' [hm' eqmax]]]. + move/model_max: hm'. rewrite (level_value_MapsTo hzero) => hle; depelim hle. + have mr := valuation_range hzero. subst k'. + have hs := valuation_of_model_spec (model_of m) _ _ hzero. + cbn in hs. + rewrite /to_val. rewrite (LevelMap.find_1 hs). + have min0 := model_min_0 m. + lia. + Qed. + + Lemma valuation_global {V cls} {m : t V cls} : + forall l, LevelSet.In l V -> Level.is_global l -> (0 < to_val (valuation_of_model (model_of m)) l)%nat. + Proof. + move=> l /(model_levels m) [] k inm isg. + have hmax := model_max_gen inm. + rewrite isg in hmax. + rewrite valuation_0 in hmax. lia. + Qed. + + Lemma valuation_not_global {V cls} {m : t V cls} : + forall l, LevelSet.In l V -> ~~ Level.is_global l -> (0 <= to_val (valuation_of_model (model_of m)) l)%nat. + Proof. + move=> l /(model_levels m) [] k inm isg. + have hmax := model_max_gen inm. + move/negbTE: isg hmax => ->. + now rewrite valuation_0. + Qed. + End CorrectModel. Module Abstract. @@ -740,27 +1102,9 @@ Module Abstract. Lemma above_zero_declared m : above_zero_declared (levels m) (clauses m). Proof. eapply (declared_above_zero m). Qed. - Lemma model_levels (m : t) : forall l, (exists k, LevelMap.MapsTo l (Some k) (initial_model m)) <-> LevelSet.In l (levels m). - Proof. - intros l. split. - - move=> [] k hm. - have hv := (only_model_of_V m.(correct_model)). - apply hv. now exists (Some k). - - intros hin. - have := above_zero_declared m _ hin. - rewrite /declared_init_clause_of_level. - case: (eqb_spec l Level.zero). - * move=> -> _. - have := CorrectModel.declared_zero m. - unfold CorrectModel.zero_declared. - now move=> [] k hm; exists (Z.of_nat k). - * intros nzero. - have he := enabled_model m. - move/he. rewrite /enabled_clause /init_clause_of_level. - move=> [] k hm. cbn in hm. rewrite min_premise_singleton /min_atom_value in hm. - destruct level_value eqn:hl => //. - exists z. apply (level_value_MapsTo' hl). - Qed. + Lemma model_levels m : + forall l, LevelSet.In l (levels m) <-> (exists k, LevelMap.MapsTo l (Some k) (model m)). + Proof. apply (model_levels m). Qed. Lemma init_model_clause : clauses init_model = Clauses.empty. @@ -871,7 +1215,6 @@ Module Abstract. Proof. rewrite /level_value => hl. destruct (find_spec l' m) => //. - Search LevelMap.find. rewrite LevelMapFact.F.add_neq_o => //. erewrite LevelMap.find_1; tea. reflexivity. rewrite LevelMapFact.F.add_neq_o => //. @@ -933,7 +1276,7 @@ Module Abstract. | exist true _ => None | exist false hneq => Some {| levels := LevelSet.add l m.(levels); clauses := Clauses.add (init_clause_of_level l) m.(clauses) |}. Proof. - refine {| initial_model := LevelMap.add l (Some (if Level.is_global l then -1 else 0)) m.(initial_model); + refine {| initial_model := LevelMap.add l (Some (if Level.is_global l then 0 else 1)) m.(initial_model); only_model_of_V := _; model_updates := m.(model_updates); |}. - have hv := only_model_of_V m. @@ -942,6 +1285,11 @@ Module Abstract. { move=> hin'. apply hneq. apply hv, hin'. } constructor. + - have hd := declared_positive m. + move=> l' /LevelSet.add_spec [] hin'. + * red in hin'; subst l'. destruct Level.is_global; [exists 0%nat|exists 1%nat]; rsets. + * eapply hd in hin' as [k' hm']. exists k'. rsets. right. split => //. + intros ->. apply hneq. eapply initial_model_levels; now eexists. - intros l'. rsets. destruct H; subst. * red. destruct eqb => //. clsets. * have hv := declared_above_zero m.(correct_model). @@ -971,13 +1319,13 @@ Module Abstract. * move: b => [] cl [] hin. right. apply (clauses_levels_declared m a). rsets. firstorder. - destruct m as [levels clauses vm]; cbn in *. - destruct vm as [init zerod azerod en omofV W incl vm]. + destruct vm as [init zerod azerod dpos en omofV W incl vm]. destruct vm as [M mofV mupd mcls mok]. cbn in *. - refine {| model_model := LevelMap.add l (Some (if Level.is_global l then -1 else 0)) M |}. + refine {| model_model := LevelMap.add l (Some (if Level.is_global l then 0 else 1)) M |}. * intros k. rewrite LevelSet.add_spec LevelMapFact.F.add_in_iff. firstorder. now left. * move: mupd; rewrite /is_update_of. destruct (LevelSet.is_empty) eqn:hw. - now intros ->. + { now intros ->. } { eapply levelset_not_Empty_is_empty in hw. apply LevelSetFact.not_mem_iff in hneq. intros s. eapply strictly_updates_weaken; revgoals. @@ -993,15 +1341,15 @@ Module Abstract. rewrite /valid_clause. cbn. rewrite min_premise_singleton //=. rewrite level_value_add /level_value_above. set value := Some _. - have hl : (value ≤ level_value (LevelMap.add l value M) Level.zero)%opt. + have hl : (Some 1 ≤ level_value (LevelMap.add l value M) Level.zero)%opt. { rewrite level_value_add_other. intros ->. apply hneq. { now apply omofV, zero_declared_in. } eapply is_update_of_ext in mupd. eapply zero_declared_ext in zerod; tea. destruct zerod as [k hzero]. rewrite (level_value_MapsTo hzero). - subst value. constructor. destruct Level.is_global; lia. } + subst value. constructor. lia. } depelim hl. rewrite H0. - apply Z.leb_le. destruct Level.is_global; lia. + apply Z.leb_le. cbn. destruct Level.is_global; lia. apply is_model_add => //. lsets => //. Qed. @@ -1076,13 +1424,6 @@ Module Abstract. Import I.Model.Model.Clauses.ISL. - Definition clause_sem {S} {SL : Semilattice S Q.t} (V : Level.t -> S) (cl : clause) : Prop := - let '(prems, concl) := cl in - le (interp_expr V concl) (interp_prems V prems). - - Definition clauses_sem {S} {SL : Semilattice S Q.t} (V : Level.t -> S) (cls : Clauses.t) : Prop := - Clauses.For_all (clause_sem V) cls. - Lemma enforce_clauses_inconsistent m cls u : enforce_clauses m cls = Some (inr u) -> entails_L_clauses (Clauses.union (clauses m) cls) (loop_univ u ≡ succ_prems (loop_univ u)). @@ -1162,74 +1503,6 @@ Module Abstract. eapply entails_clauses_trans; tea. eapply entails_clauses_of_relations. Qed. - Definition to_val (v : LevelMap.t nat) l := - match LevelMap.find l v with - | Some n => n - | None => 0%nat - end. - - Definition to_Z_val (v : Level.t -> nat) := fun l => Z.of_nat (v l). - - (** Enabled and valid clauses are satisfied by valuation. - *) - Lemma valid_clause_model model cl : - enabled_clause model cl -> - valid_clause model cl -> - clause_sem (to_Z_val (to_val (valuation_of_model model))) cl. - Proof. - unfold enabled_clause, valid_clause. - destruct min_premise eqn:hmin => //= => //. - 2:{ intros [k' eq]. congruence. } - intros [k' eq]. noconf eq. - destruct cl as [prems [concl k]]. cbn -[le]. - unfold level_value_above. - destruct level_value eqn:hl => //. - unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. - move/Z.leb_le => hrel. - eapply LevelMap.find_2 in hfind. - have conclm := valuation_of_model_spec _ _ _ hfind. - set (v := (model_max _ - _)) in *. - cbn in conclm. - eapply LevelMap.find_1 in conclm. - subst v. - pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. - rewrite hmin in premeq. - eapply transitivity. 2:{ eapply interp_prems_ge; tea. } - unfold interp_expr. destruct prem as [prem k']. - symmetry in premeq. - move: premeq. unfold min_atom_value. - unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. - destruct o => //. - intros [= <-]. - eapply LevelMap.find_2 in findp. - have premm := valuation_of_model_spec _ _ _ findp. - eapply LevelMap.find_1 in premm. - assert (z1 - k' <= z0 - k). lia. - have hm : z0 <= model_max model. - { eapply model_max_spec in hfind; tea. now depelim hfind. } - have hm' : z1 <= model_max model. - { eapply model_max_spec in findp; tea. now depelim findp. } - have hmi : model_min model <= z0. - { eapply model_min_spec; tea. } - have hmi' : model_min model <= z1. - { eapply model_min_spec; tea. } - assert (0 <= model_max model)%Z by apply model_max_spec2. - assert (model_min model <= 0)%Z by apply model_min_spec2. - rewrite /to_Z_val /to_val premm conclm. - cbn. lia. - Qed. - - Lemma valid_clauses_model model cls : - enabled_clauses model cls -> - is_model cls model -> - clauses_sem (to_Z_val (to_val (valuation_of_model model))) cls. - Proof. - move=> en ism cl hin. - apply valid_clause_model. - now apply en. - now move/Clauses.for_all_spec: ism; apply. - Qed. - Lemma clauses_of_le_singleton le r : (singleton le ⋞ r)%cls =_clset Clauses.singleton (r, le). Proof. @@ -1400,6 +1673,7 @@ End Deciders. Module LoopChecking (LS : LevelSets). Module Impl := Deciders(LS). + Import Impl.CorrectModel. Import Impl.I. Import Impl.Abstract. @@ -1536,8 +1810,8 @@ Module LoopChecking (LS : LevelSets). Proof. destruct m as [levels clauses []]; cbn. apply valid_clauses_model; tea; cbn. - - eapply enabled_clauses_ext; tea. - eapply is_update_of_ext, model_valid. + - eapply enabled_clauses_ext; tea; cbn. + eapply is_update_of_ext, model_valid0. - apply model_valid. Qed. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 111f8b728..84359bb00 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -83,6 +83,8 @@ Module Model (LS : LevelSets). Import Init.Logic (eq). Definition model := LevelMap.t (option Z). + Implicit Type m : model. + Definition equal_model (m m' : model) := LevelMap.Equal m m'. Definition defined_map (m : LevelMap.t (option Z)) := exists l k, LevelMap.MapsTo l (Some k) m. @@ -124,7 +126,7 @@ Module Model (LS : LevelSets). - constructor. constructor. Qed. - Inductive findSpec {A} l m : option A -> Prop := + Inductive findSpec {A} l (m : LevelMap.t A) : option A -> Prop := | inm k : LevelMap.MapsTo l k m -> findSpec l m (Some k) | ninm : ~ LevelMap.In l m -> findSpec l m None. @@ -2452,7 +2454,7 @@ Module Model (LS : LevelSets). Qed. - Definition model_min m := + Definition model_min (m : model) := LevelMap.fold (fun l k acc => Z.min acc (option_get 0 k)) m 0. Lemma model_min_spec m : forall l k, LevelMap.MapsTo l (Some k) m -> (model_min m <= k)%Z. @@ -2478,10 +2480,36 @@ Module Model (LS : LevelSets). - intros k' e a m' m'' hm nin hadd hle. lia. Qed. - Definition model_max m := + Lemma model_has_min m : (model_min m = 0) \/ exists l k, LevelMap.MapsTo l (Some k) m /\ model_min m = k. + Proof. + rewrite /model_min. + eapply LevelMapFact.fold_rec. + - move=> he hm. now left. + - intros l' e a m' m'' hm nin hadd hle. + destruct hle as [eqa|[l [k [hm' hle]]]]. + subst a. + destruct (Z.min_spec 0 (option_get 0 e)) as [[hlt heq]|[hlt heq]]. + * now left. + * destruct e; cbn in *. right. exists l', z. split => //. + apply levelmap_add_spec in hadd. rewrite hadd. + eapply LevelMapFact.F.add_mapsto_iff. now left. + now left. + * subst a. + destruct (Z.min_spec k (option_get 0 e)) as [[hlt heq]|[hlt heq]]. + + right. exists l, k. split; try lia. + apply levelmap_add_spec in hadd. rewrite hadd. + rewrite LevelMapFact.F.add_mapsto_iff. right; split => //. + intros eq. apply nin. rewrite eq. now eexists. + + destruct e; cbn in *. 2:{ now left. } + right. exists l', z. split; try lia. + apply levelmap_add_spec in hadd. rewrite hadd. + rewrite LevelMapFact.F.add_mapsto_iff. now left. + Qed. + + Definition model_max (m : model) := LevelMap.fold (fun l k acc => Z.max acc (option_get 0 k)) m 0. - Lemma model_max_spec m : forall l k, LevelMap.MapsTo l k m -> (k ≤ Some (model_max m)). + Lemma model_max_spec (m : model) : forall l k, LevelMap.MapsTo l k m -> (k ≤ Some (model_max m)). Proof. intros l k hm. rewrite /model_max. @@ -2504,6 +2532,32 @@ Module Model (LS : LevelSets). - intros k' e a m' m'' hm nin hadd hle. lia. Qed. + Lemma model_has_max m : model_max m = 0 \/ exists l k, LevelMap.MapsTo l (Some k) m /\ model_max m = k. + Proof. + rewrite /model_max. + eapply LevelMapFact.fold_rec. + - move=> he hm. now left. + - intros l' e a m' m'' hm nin hadd hle. + destruct hle as [hz|[l [k [hm' hle]]]]. + subst a. + destruct (Z.max_spec 0 (option_get 0 e)) as [[hlt heq]|[hlt heq]]. + * destruct e; cbn in *. right. exists l', z. split => //. + apply levelmap_add_spec in hadd. rewrite hadd. + eapply LevelMapFact.F.add_mapsto_iff. now left. + now left. + * now left. + * subst a. + destruct (Z.max_spec k (option_get 0 e)) as [[hlt heq]|[hlt heq]]. + + destruct e; cbn in *. 2:{ now left. } + right. exists l', z. split; try lia. + apply levelmap_add_spec in hadd. rewrite hadd. + rewrite LevelMapFact.F.add_mapsto_iff. now left. + + right. exists l, k. split => //. + apply levelmap_add_spec in hadd. rewrite hadd. + rewrite LevelMapFact.F.add_mapsto_iff. right; split => //. + intros eq. apply nin. rewrite eq. now eexists. + Qed. + Definition valuation_of_model (m : model) : LevelMap.t nat := let max := model_max m in let min := model_min m in diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index f48b986e0..17f9fb3a5 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -404,17 +404,13 @@ End ZUnivConstraint. exists c, UnivConstraintSet.In c constraints /\ Clauses.In cl (LoopCheck.to_clauses (to_constraint c)) }. - Import LoopCheck.Impl.CorrectModel. - Lemma declared_zero (m : univ_model) : LevelSet.In Level.lzero (LoopCheck.levels m.(model)). Proof. - have := LoopCheck.zero_declared m.(model). - rewrite /zero_declared. - move=> [k hm]. - declared_levels : - forall l, LevelSet.In l (LoopCheck.levels model) -> declared_init_constraint_of_level l constraints; - - + have := LoopCheck.zero_declared m. + have := LoopCheck.Impl.Abstract.model_levels m.(model) Level.lzero. + rewrite /LoopCheck.Impl.CorrectModel.zero_declared. intros ->. + intros [k hm]. now exists (Z.of_nat k). + Qed. Module C := LoopCheck.Impl.I.Model.Model.Clauses. Import C. @@ -479,9 +475,6 @@ End ZUnivConstraint. init_model := {| model := LoopCheck.init_model; constraints := UnivConstraintSet.empty |}. Proof. - - LoopCheck.Impl.rsets. - - LoopCheck.Impl.rsets. move: H; rewrite LevelSet.add_spec => -[->|h]. - now cbn. lsets. - move: H. now rewrite UnivConstraintSetFact.empty_iff. - move: H. now rewrite ClausesFact.empty_iff. Qed. @@ -494,11 +487,6 @@ End ZUnivConstraint. | exist (Some (inl m')) eq => Some (inl {| model := m'; constraints := UnivConstraintSet.add c m.(constraints) |}) | exist (Some (inr loop)) eq => Some (inr loop). Proof. - - move/LoopCheck.enforce_levels: eq0. intros eq; rewrite eq. apply m. - - move/LoopCheck.enforce_levels: eq0. intros eq; rewrite eq. - have hd := declared_levels m. - move=> l /hd. rewrite /declared_init_constraint_of_level. - destruct init_constraint_of_level => //. ucsets. - move=> c'. move/LoopCheck.enforce_clauses: eq0. rewrite /LoopCheck.clauses => ->. rewrite UnivConstraintSet.add_spec => -[]. @@ -625,19 +613,50 @@ End ZUnivConstraint. rewrite /declared_init_constraint_of_level. destruct init_constraint_of_level => //. ucsets. Qed. + Lemma init_constraint_spec {l c} : + init_constraint_of_level l = Some c -> + LoopCheck.to_clauses (to_constraint c) =_clset + Clauses.singleton (LoopCheck.Impl.init_clause_of_level l). + Proof. + intros h. + destruct l; cbn in h => //; noconf h. + - intros l. cbn. unfold flip. + rewrite Clauses.add_spec. cbn. + rewrite /LoopCheck.Impl.init_clause_of_level. + split. intros []. subst l. + * apply Clauses.singleton_spec. + f_equal. + apply equal_exprsets => le. + rewrite /to_atoms //=. + * clsets. + * move/Clauses.singleton_spec => -> //=. + left. f_equal. unfold LevelExprSet.elt, Universes.Level.t. + f_equal. apply equal_exprsets. rewrite /to_atoms //=. + - intros l. cbn. unfold flip. + rewrite Clauses.add_spec. cbn. + rewrite /LoopCheck.Impl.init_clause_of_level. + split. intros []. subst l. + * apply Clauses.singleton_spec. + f_equal. + apply equal_exprsets => le. + rewrite /to_atoms //=. + * clsets. + * move/Clauses.singleton_spec => -> //=. + left. f_equal. unfold LevelExprSet.elt, Universes.Level.t. + f_equal. apply equal_exprsets. rewrite /to_atoms //=. + Qed. + + (* We ignore errors here, which can happen only if the levels are already declared *) Equations? declare_level (m : univ_model) (l : Level.t) : option univ_model := declare_level m l with inspect (LoopCheck.declare_level m.(model) l) := { | exist (Some model) eq with inspect (init_constraint_of_level l) := - { | exist (Some c) eqc with inspect (LoopCheck.enforce model (to_constraint c)) := - { | exist (Some (inl m')) _ => Some {| model := m'; constraints := UnivConstraintSet.add c m.(constraints) |} - | exist (Some (inr _)) _ => False_rect _ _ - | exist None eqm => False_rect _ _ } + { | exist (Some c) eqc => Some {| model := model; constraints := UnivConstraintSet.add c m.(constraints) |} | exist None eqc => False_rect _ _ } ; | exist None eqdecl := None }. Proof. Import LoopCheck.Impl.Abstract LoopCheck. - - move/LoopCheck.declare_level_levels: eq0 => -[] hnin. + (* - move/LoopCheck.declare_level_levels: eq0 => -[] hnin. move/LoopCheck.enforce_levels: e => eq. rewrite eq. intros ->. have := declared_zero m. lsets. - move/LoopCheck.declare_level_levels: eq0 => -[] hnin eq l'. @@ -645,46 +664,27 @@ End ZUnivConstraint. rewrite eq. rewrite LevelSet.add_spec => -[]. * intros ->. now apply declared_init_constraint_of_level_spec. * intros. apply declared_init_constraint_of_level_add'. - now apply declared_levels. - - move/LoopCheck.enforce_clauses: e. - move/LoopCheck.declare_level_clauses: eq0 => eqcl. - intros eq c'. - rewrite UnivConstraintSet.add_spec => -[]; intros h; rewrite [_ m']eq => l'; rewrite Clauses.union_spec. - now right. subst. setoid_rewrite <- eqcl. left. - now apply (repr_constraints _ _ h). - - move/LoopCheck.enforce_clauses: e. - move/LoopCheck.declare_level_clauses: eq0 => eqcl. - intros eq c'. setoid_rewrite eq. rewrite Clauses.union_spec; setoid_rewrite <- eqcl. + now apply declared_levels. *) + - move/LoopCheck.declare_level_clauses: eq0 => eqcl. + intros c'. + rewrite UnivConstraintSet.add_spec => -[]; intros h; try subst; + rewrite eqcl => l'; rewrite Clauses.add_spec. + * rewrite init_constraint_spec; tea => //. + rewrite Clauses.singleton_spec. auto. + * right. + now apply (repr_constraints _ _ h). + - move/LoopCheck.declare_level_clauses: eq0 => ->. + intros c'. rewrite Clauses.add_spec. move=> [] h. + * exists c. split => //. ucsets. + subst c'. rewrite init_constraint_spec; tea. clsets. * have [ec [? ?]] := repr_constraints_inv _ _ h. exists ec. split => //. ucsets. - * exists c. split => //. ucsets. - - move/LoopCheck.enforce_inconsistent: e. - have val := LoopCheck.model_valuation model0. - destruct l; cbn in eqc => //; noconf eqc. - move=> hv. - pose (l' := fun l => if eqb l (Level.level t0) then 1%Z else (to_Z_val (valuation model0) l)). - move: (hv Z Zsemilattice l'). - move/LoopCheck.declare_level_levels: eq0 => -[] hnin heq. - move=> /fwd. - setoid_rewrite LoopCheck.Impl.Abstract.clauses_sem_union. - split. admit. cbn. unfold flip. - cbn. rewrite clauses_sem_add; cbn -[Z.add]. - rewrite Z.add_0_l. admit. - rewrite clauses_sem_eq. cbn. - setoid_rewrite interp_add_prems; cbn -[Z.add]. lia. - - rewrite UnivConstraintSet.add_spec => -[]; intros h; rewrite [_ m']eq => l'; - now right. subst. setoid_rewrite <- eqcl. left. - now apply (repr_constraints _ _ h). - - - * intros hin [_ m']eq => l'. - - - - {| model := declare_levels_aux m.(model) l; - constraints := m.(constraints); |}. - Next Obligation. + + - destruct l; noconf eqc. + move/declare_level_levels: eq0 => [] hnin _; apply hnin. + eapply declared_zero. + Qed. Local Definition declare_levels_aux m l := LevelSet.fold (fun l m => @@ -693,7 +693,8 @@ End ZUnivConstraint. | Some m => m end) l m. - Lemma declare_levels_aux_spec m l : LoopCheck.levels (declare_levels_aux m l) =_lset + Lemma declare_levels_aux_spec m l : + LoopCheck.levels (declare_levels_aux m l) =_lset LevelSet.union l (LoopCheck.levels m). Proof. rewrite /declare_levels_aux. @@ -710,8 +711,9 @@ End ZUnivConstraint. destruct decl => //. lsets. Qed. - Lemma declare_levels_aux_clauses m l : - LoopCheck.clauses (declare_levels_aux m l) =_clset LoopCheck.clauses m. + (* Lemma declare_levels_aux_clauses m l : + LoopCheck.clauses (declare_levels_aux m l) =_clset + LoopCheck.clauses m. Proof. rewrite /declare_levels_aux. eapply LevelSetProp.fold_rec. @@ -723,11 +725,11 @@ End ZUnivConstraint. apply LoopCheck.declare_level_clauses in hd. unfold LoopCheck.clauses. now rewrite hd. - Qed. + Qed. *) (* We ignore errors here, which can happen only if the levels are already declared *) - Program Definition declare_levels (m : univ_model) (l : LevelSet.t) := - {| model := declare_levels_aux m.(model) l; + (* Program Definition declare_levels (m : univ_model) (l : LevelSet.t) := + {| UnivLoopChecking.model := declare_levels_aux m.(UnivLoopChecking.model) l; constraints := m.(constraints); |}. Next Obligation. Proof. @@ -740,15 +742,15 @@ End ZUnivConstraint. move=> m l cl. rewrite [LoopCheck.Impl.Abstract.clauses _]declare_levels_aux_clauses => hin. now exact: repr_constraints_inv m cl hin. - Qed. + Qed. *) - Definition to_valuation (v : Level.t -> nat) : valuation := + Definition to_valuation (v : Level.t -> nat) : Universes.valuation := {| valuation_mono := fun s => Pos.of_nat (v (Level.level s)); valuation_poly := fun i => v (Level.lvar i); |}. - Definition of_valuation V (v : valuation) : LevelMap.t nat := + Definition of_valuation V (v : Universes.valuation) : LevelMap.t nat := let add_val l := LevelMap.add l (val v l) in LevelSet.fold add_val V (LevelMap.empty _). @@ -814,11 +816,12 @@ End ZUnivConstraint. rewrite Universes.LevelExprSet.add_spec. now right. Qed. - Lemma interp_prem_to_atom v le : interp_expr (to_Z_val v) (to_atom le) = Z.of_nat (val (to_valuation v) le). + Lemma interp_prem_to_atom v le : + interp_expr (to_Z_val v) (to_atom le) = Z.of_nat (val (to_valuation v) le). Proof. destruct le => //=. cbn. destruct t0. - - (* lzero is forced to have value 0, has it should stay maximal *) todo "handle lzero". + - cbn. - todo "handle monos". - cbn. unfold to_Z_val; cbn. lia. Qed. @@ -849,8 +852,8 @@ End ZUnivConstraint. cbn in *. lia. Qed. - Lemma model_satisfies m : - satisfies (to_valuation (LoopCheck.valuation (model m))) (constraints m). + Lemma model_satisfies (m : univ_model) : + satisfies (to_valuation (LoopCheck.valuation m)) (constraints m). Proof. destruct m as [m cstrs repr repr_inv]. cbn. have val := LoopCheck.model_valuation m. @@ -944,8 +947,8 @@ End ZUnivConstraint. Qed. (* Lemma in_to_clauses_elem {l k a} : *) - Definition check m (c : UnivConstraint.t) : bool := - LoopCheck.check m.(model) (to_constraint c). + Definition check (m : univ_model) (c : UnivConstraint.t) : bool := + LoopCheck.check m.(UnivLoopChecking.model) (to_constraint c). Derive Signature for satisfies0. Lemma in_to_clauses_sem {l r V v} : @@ -969,10 +972,10 @@ End ZUnivConstraint. cbn; u; lia. Qed. - Lemma satisfies_clauses_sem v m V : - LoopCheck.levels (model m) ⊂_lset V -> + Lemma satisfies_clauses_sem v {m : univ_model} V : + LoopCheck.levels (UnivLoopChecking.model m) ⊂_lset V -> satisfies v (constraints m) -> - clauses_sem (to_Z_val (to_val (of_valuation V v))) (LoopCheck.clauses (model m)). + clauses_sem (to_Z_val (to_val (of_valuation V v))) (LoopCheck.clauses (UnivLoopChecking.model m)). Proof. have repr := repr_constraints_inv m. have repr_inv := repr_constraints m. @@ -983,20 +986,20 @@ End ZUnivConstraint. depelim sat. cbn -[clause_sem]. - apply in_to_clauses_sem; auto. cbn; intros le inr. apply hsub. - apply (LoopCheck.clauses_levels_declared m.(model)). + apply (LoopCheck.clauses_levels_declared m). move/clauses_levels_mon: hr; apply. rewrite in_to_clauses_levels. rewrite in_constraint_levels_to_constraint //=. - cbn. move=> []. * apply in_to_clauses_sem; [|lia]. cbn; intros le inr. - apply hsub, (LoopCheck.clauses_levels_declared m.(model)). + apply hsub, (LoopCheck.clauses_levels_declared m). move/clauses_levels_mon: hr; apply. rewrite in_to_clauses_levels. rewrite in_constraint_levels_to_constraint //=. * apply in_to_clauses_sem; [|lia]. cbn; intros le inr. - apply hsub, (LoopCheck.clauses_levels_declared m.(model)). + apply hsub, (LoopCheck.clauses_levels_declared m). move/clauses_levels_mon: hr; apply. rewrite in_to_clauses_levels. rewrite in_constraint_levels_to_constraint //=. lsets. @@ -1192,15 +1195,17 @@ End ZUnivConstraint. Qed. Lemma equiv_constraints_clauses m : - relations_of_constraints (to_z_cstrs (constraints m)) ⊫ℒ Clauses.relations_of_clauses (LoopCheck.clauses (model m)). + relations_of_constraints (to_z_cstrs (constraints m)) ⊫ℒ + Clauses.relations_of_clauses (LoopCheck.clauses (UnivLoopChecking.model m)). Proof. have repr := repr_constraints. have repr_inv := repr_constraints_inv. rewrite -rels_of_z_constraints_spec. rewrite -to_clauses_of_z_constraints. - rewrite (@relations_of_clauses_eq (to_clauses (constraints m)) (LoopCheck.clauses (model m))) //. + rewrite (@relations_of_clauses_eq (to_clauses (constraints m)) + (LoopCheck.clauses m)) //. 2:{ reflexivity. } - intros cl; rewrite to_clauses_spec. + intros cl. rewrite UnivLoopChecking.to_clauses_spec. split. - move=> [] cstrs [] /repr incl intocl. apply incl, intocl. @@ -1255,13 +1260,13 @@ End ZUnivConstraint. Import Semilattice. Import ISL. - Definition model_val m := (LoopCheck.valuation (model m)). + Definition model_val (m : univ_model) := (LoopCheck.valuation m). - Definition model_Z_val m := (to_Z_val (LoopCheck.valuation (model m))). + Definition model_Z_val (m : univ_model) := (to_Z_val (LoopCheck.valuation m)). Lemma interp_rels_of_m m : interp_rels (model_Z_val m) (relations_of_constraints (to_z_cstrs (constraints m))). Proof. - have hv := (LoopCheck.model_valuation m.(model)). + have hv := (LoopCheck.model_valuation m). red. apply Forall_forall. move=> [l r] /relations_of_constraints_spec => -[cl [hin heq]]. eapply to_z_cstrs_spec_2 in hin as [cstr [hin ->]]. @@ -1336,7 +1341,7 @@ End ZUnivConstraint. Qed. Lemma interp_cstrs_clauses_sem {m} {S} {SL : Semilattice S Q.t} {v : Level.t -> S} : - interp_univ_cstrs v (constraints m) <-> clauses_sem v (LoopCheck.clauses (model m)). + interp_univ_cstrs v (constraints m) <-> clauses_sem v (LoopCheck.clauses m). Proof. rewrite interp_univ_cstrs_relations. rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v index c885cef4e..ee8809264 100644 --- a/utils/theories/NonEmptyLevelExprSet.v +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -15,6 +15,7 @@ Module Type OrderedTypeWithLeibnizWithReflect. Parameter zero : t. Parameter is_global : t -> bool. + Parameter is_global_zero : ~~ is_global zero. Parameter reflect_eq : ReflectEq t. Parameter to_string : t -> string. End OrderedTypeWithLeibnizWithReflect. From 2b8e04a14c44b2ed03e7f04882a8a9a27a800626 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 29 Sep 2025 10:29:22 +0200 Subject: [PATCH 076/164] Finished adapting to valuations for monos and zero --- common/theories/LoopChecking/Deciders.v | 159 ++++------ common/theories/LoopChecking/HornClauses.v | 4 + common/theories/LoopChecking/Interfaces.v | 64 +++- .../theories/LoopChecking/UnivLoopChecking.v | 282 ++++++++++++++---- common/theories/Universes.v | 4 +- utils/theories/NonEmptyLevelExprSet.v | 34 ++- 6 files changed, 379 insertions(+), 168 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 763569ea0..4fda0c91d 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -10,12 +10,6 @@ From Equations Require Import Equations. From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model Models PartialLoopChecking InitialSemilattice HornSemilatticeEquiv. -Module Autorew. - Import Ltac2. - #[global] Ltac2 autorewrite0 ids cl := - Std.autorewrite true None ids (default_on_concl cl). -End Autorew. - Set Equations Transparent. Module Type LoopCheckingItf (LS : LevelSets). @@ -503,57 +497,6 @@ Proof. exists (y - z). now rewrite /min_atom_value (level_value_MapsTo hmap). Qed. -Ltac lset := - match goal with - | [ H : LevelSet.In _ (LevelSet.singleton _) |- _ ] => - apply LevelSet.singleton_spec in H; red in H; try subst - | [ H : LevelSet.In _ (LevelSet.add _ _) |- _ ] => - apply LevelSet.add_spec in H as [] - | [ H : LevelSet.mem _ _ = false |- _ ] => - apply LevelSetProp.FM.not_mem_iff in H - | [ H : LevelSet.mem _ _ = true |- _ ] => - apply LevelSetProp.FM.mem_iff in H - | [ H : LevelExprSet.In _ (LevelExprSet.singleton _) |- _ ] => - apply LevelExprSet.singleton_spec in H; red in H; try subst - | [ H : LevelExprSet.In _ (LevelExprSet.add _ _) |- _ ] => - apply LevelExprSet.add_spec in H as [] - | [ H : LevelMap.MapsTo _ _ (LevelMap.add _ _ _) |- _ ] => - rewrite LevelMapFact.F.add_mapsto_iff in H; unfold Level.eq in H - | [ H : LevelMap.MapsTo _ _ (LevelMap.empty _) |- _ ] => - rewrite LevelMapFact.F.empty_mapsto_iff in H; unfold Level.eq in H - | [ H : LevelSet.In _ (LevelSet.union _ _) |- _ ] => - apply LevelSet.union_spec in H as [] - | [ |- LevelSet.In _ (LevelSet.singleton _) ] => - apply LevelSet.singleton_spec; rewrite ?/LevelSet.E.eq - | [ |- LevelSet.In _ (LevelSet.add _) ] => - apply LevelSet.add_spec - | [ |- LevelSet.In _ (LevelSet.union _) ] => - apply LevelSet.union_spec - | [ |- LevelSet.In _ (LevelSet.singleton _) -> _ ] => - move/LevelSet.singleton_spec; rewrite ?/LevelSet.E.eq - | [ |- LevelSet.In _ (LevelSet.add _) -> _ ] => - move/LevelSet.add_spec - | [ |- LevelSet.In _ (LevelSet.union _) -> _ ] => - move/LevelSet.union_spec - end; try lsets. - -Hint Rewrite clauses_of_le_spec clauses_levels_spec - LevelSet.singleton_spec LevelSet.add_spec LevelSet.union_spec - LevelSetFact.is_empty_1 LevelSetFact.empty_iff - LevelExprSet.singleton_spec LevelExprSet.add_spec LevelExprSet.union_spec LevelExprSetFact.empty_iff - @NES.singleton_spec @NES.add_spec_les - Clauses.singleton_spec Clauses.add_spec Clauses.union_spec ClausesFact.empty_iff - LevelMapFact.F.add_mapsto_iff LevelMapFact.F.empty_mapsto_iff - : set_specs. - -Hint Rewrite <- LevelSetProp.FM.not_mem_iff LevelSetProp.FM.mem_iff : set_specs. - -Ltac rsets := repeat (progress (autorewrite with set_specs || lset || intro - || unfold Level.eq, LevelSet.E.eq in * )). - -Ltac2 Notation "rsets" cl(opt(clause)) := - let id := Option.get (Ident.of_string "set_specs") in - Autorew.autorewrite0 [id] cl. Definition init_clause_of_level l := (singleton (l, 0), (Level.zero, if Level.is_global l then 1 else 0)). @@ -784,6 +727,41 @@ Module CorrectModel. Definition clauses_sem {S} {SL : Semilattice S Q.t} (V : Level.t -> S) (cls : Clauses.t) : Prop := Clauses.For_all (clause_sem V) cls. + Instance clauses_sem_proper {S} {SL : Semilattice S Q.t} : + Proper (Logic.eq ==> Clauses.Equal ==> iff) clauses_sem. + Proof. + move=> ?? -> ?? h. + rewrite /clauses_sem. + now rewrite h. + Qed. + + Lemma clauses_sem_singleton {S} {SL : Semilattice S Q.t} {V cl} : + clauses_sem V (Clauses.singleton cl) <-> clause_sem V cl. + Proof. + rewrite /clauses_sem /Clauses.For_all. + split; firstorder. apply H. clsets. + apply Clauses.singleton_spec in H0. now subst. + Qed. + + Lemma clauses_sem_add {S} {SL : Semilattice S Q.t} {V cl cls} : + clauses_sem V (Clauses.add cl cls) <-> clause_sem V cl /\ clauses_sem V cls. + Proof. + rewrite /clauses_sem /Clauses.For_all. + split. + - intros hcl. split. + * apply hcl, Clauses.add_spec; now left. + * move=> x hin; apply hcl, Clauses.add_spec; now right. + - move=> [] hcl hcls x /Clauses.add_spec -[]. now subst. + apply hcls. + Qed. + + Lemma clauses_sem_union {S} {SL : Semilattice S Q.t} {V cls cls'} : + clauses_sem V (Clauses.union cls cls') <-> clauses_sem V cls /\ clauses_sem V cls'. + Proof. + rewrite /clauses_sem /Clauses.For_all. + setoid_rewrite Clauses.union_spec. firstorder. + Qed. + Definition to_val (v : LevelMap.t nat) l := match LevelMap.find l v with @@ -1250,18 +1228,7 @@ Module Abstract. exists x. firstorder. now rsets. Qed. Hint Rewrite @clauses_levels_add : set_specs. - - Lemma levelexprset_singleton {l le} : (exists k : Z, LevelExprSet.In (l, k) (singleton le)) <-> (l, le.2) = le. - Proof. - split. - - move=> [] k. rsets. now subst le. - - intros <-. exists le.2; now rsets. - Qed. Hint Rewrite @levelexprset_singleton : set_specs. - - Lemma levels_singleton le : NES.levels (LevelExprSet.singleton le) =_lset LevelSet.singleton le.1. - Proof. intros l; rewrite NES.levels_spec. rsets. split; intros h; subst. destruct h. rsets. exists le.2. - rsets. now destruct le. Qed. Hint Rewrite levels_singleton : set_specs. Lemma clause_levels_init_constraint l : clause_levels (init_clause_of_level l) @@ -1529,41 +1496,6 @@ Module Abstract. exists k. split => //. now apply LevelExprSet.add_spec. Qed. - Instance clauses_sem_proper {S} {SL : Semilattice S Q.t} : - Proper (Logic.eq ==> Clauses.Equal ==> iff) clauses_sem. - Proof. - move=> ?? -> ?? h. - rewrite /clauses_sem. - now rewrite h. - Qed. - - Lemma clauses_sem_singleton {S} {SL : Semilattice S Q.t} {V cl} : - clauses_sem V (Clauses.singleton cl) <-> clause_sem V cl. - Proof. - rewrite /clauses_sem /Clauses.For_all. - split; firstorder. apply H. clsets. - apply Clauses.singleton_spec in H0. now subst. - Qed. - - Lemma clauses_sem_add {S} {SL : Semilattice S Q.t} {V cl cls} : - clauses_sem V (Clauses.add cl cls) <-> clause_sem V cl /\ clauses_sem V cls. - Proof. - rewrite /clauses_sem /Clauses.For_all. - split. - - intros hcl. split. - * apply hcl, Clauses.add_spec; now left. - * move=> x hin; apply hcl, Clauses.add_spec; now right. - - move=> [] hcl hcls x /Clauses.add_spec -[]. now subst. - apply hcls. - Qed. - - Lemma clauses_sem_union {S} {SL : Semilattice S Q.t} {V cls cls'} : - clauses_sem V (Clauses.union cls cls') <-> clauses_sem V cls /\ clauses_sem V cls'. - Proof. - rewrite /clauses_sem /Clauses.For_all. - setoid_rewrite Clauses.union_spec. firstorder. - Qed. - Lemma clauses_sem_leq {S} {SL : Semilattice S Q.t} (V : Level.t -> S) l r : clauses_sem V (l ⋞ r) <-> (interp_prems V l ≤ interp_prems V r)%sl. @@ -1802,6 +1734,18 @@ Module LoopChecking (LS : LevelSets). check m c <-> valid_entailments (clauses m) (to_clauses c). Proof. apply check_clauses_complete. Qed. + Lemma check_declared m c : + check m c -> LevelSet.Subset (clauses_levels (to_clauses c)) (levels m). + Proof. + rewrite /check /Impl.check_clauses. + move: (to_clauses c) => cls. + move/Clauses.for_all_spec. + move: cls; apply: ClausesProp.set_induction. + - intros s he. + cl. hin. + + + (* Returns the valuation of the model: a minimal assignement from levels to constraints that make the enforced clauses valid. *) Definition valuation m := to_val (Model.valuation_of_model (model m)). @@ -1821,4 +1765,13 @@ Module LoopChecking (LS : LevelSets). Lemma above_zero_declared m : Impl.CorrectModel.above_zero_declared (levels m) (clauses m). Proof. eapply above_zero_declared. Qed. + Lemma model_valuation_zero m : valuation m Level.zero = 0%nat. + Proof. apply valuation_0. Qed. + + Lemma model_valuation_global {m l} : LevelSet.In l (levels m) -> Level.is_global l -> (valuation m l > 0)%nat. + Proof. apply valuation_global. Qed. + + Lemma model_valuation_not_global {m l} : LevelSet.In l (levels m) -> ~~ Level.is_global l -> (valuation m l >= 0)%nat. + Proof. apply valuation_not_global. Qed. + End LoopChecking. diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 895561d84..4106672f9 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -1771,6 +1771,10 @@ Module Clauses (LS : LevelSets). apply levels_spec. now exists k. Qed. + Hint Rewrite clauses_of_le_spec clauses_levels_spec + Clauses.singleton_spec Clauses.add_spec Clauses.union_spec ClausesFact.empty_iff + : set_specs. + Lemma to_entails_all {cls s t} : cls ⊢ℋ s ⋞ t <-> cls ⊢a t → s. Proof. diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 6a2fbb131..3d47b9326 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -1,4 +1,5 @@ (* Distributed under the terms of the MIT license. *) +From Ltac2 Require Ltac2. From Stdlib Require Import ssreflect ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. @@ -9,6 +10,12 @@ From MetaRocq.Common Require Import LoopChecking.Common. From Equations Require Import Equations. Set Equations Transparent. +Module Autorew. + Import Ltac2. + #[global] Ltac2 autorewrite0 ids cl := + Std.autorewrite true None ids (default_on_concl cl). +End Autorew. + Module FMapOrderedType_from_UsualOrderedType (O : UsualOrderedType). Import O. Definition t := O.t. @@ -90,9 +97,9 @@ Bind Scope levels_scope with LevelSet.t. Ltac lsets := LevelSetDecide.fsetdec. Notation "(=_lset)" := LevelSet.Equal (at level 0) : levels_scope. -Infix "=_lset" := LevelSet.Equal (at level 30) : levels_scope. +Infix "=_lset" := LevelSet.Equal (at level 70) : levels_scope. Infix "⊂_lset" := LevelSet.Subset (at level 70) : levels_scope. -Infix "∪" := LevelSet.union (at level 70) : levels_scope. +Infix "∪" := LevelSet.union (at level 60) : levels_scope. Infix "=m" := LevelMap.Equal (at level 50) : levels_scope. Notation "#| V |" := (LevelSet.cardinal V) : levels_scope. @@ -297,4 +304,57 @@ Proof. rewrite diff_cardinal_inter LevelSetProp.inter_sym LevelSetProp.inter_subset_equal //. Qed. + + +Ltac lset := + match goal with + | [ H : LevelSet.In _ (LevelSet.singleton _) |- _ ] => + apply LevelSet.singleton_spec in H; red in H; try subst + | [ H : LevelSet.In _ (LevelSet.add _ _) |- _ ] => + apply LevelSet.add_spec in H as [] + | [ H : LevelSet.mem _ _ = false |- _ ] => + apply LevelSetProp.FM.not_mem_iff in H + | [ H : LevelSet.mem _ _ = true |- _ ] => + apply LevelSetProp.FM.mem_iff in H + | [ H : LevelExprSet.In _ (LevelExprSet.singleton _) |- _ ] => + apply LevelExprSet.singleton_spec in H; red in H; try subst + | [ H : LevelExprSet.In _ (LevelExprSet.add _ _) |- _ ] => + apply LevelExprSet.add_spec in H as [] + | [ H : LevelMap.MapsTo _ _ (LevelMap.add _ _ _) |- _ ] => + rewrite LevelMapFact.F.add_mapsto_iff in H; unfold Level.eq in H + | [ H : LevelMap.MapsTo _ _ (LevelMap.empty _) |- _ ] => + rewrite LevelMapFact.F.empty_mapsto_iff in H; unfold Level.eq in H + | [ H : LevelSet.In _ (LevelSet.union _ _) |- _ ] => + apply LevelSet.union_spec in H as [] + | [ |- LevelSet.In _ (LevelSet.singleton _) ] => + apply LevelSet.singleton_spec; rewrite ?/LevelSet.E.eq + | [ |- LevelSet.In _ (LevelSet.add _) ] => + apply LevelSet.add_spec + | [ |- LevelSet.In _ (LevelSet.union _) ] => + apply LevelSet.union_spec + | [ |- LevelSet.In _ (LevelSet.singleton _) -> _ ] => + move/LevelSet.singleton_spec; rewrite ?/LevelSet.E.eq + | [ |- LevelSet.In _ (LevelSet.add _) -> _ ] => + move/LevelSet.add_spec + | [ |- LevelSet.In _ (LevelSet.union _) -> _ ] => + move/LevelSet.union_spec + end; try lsets. + +Hint Rewrite + LevelSet.singleton_spec LevelSet.add_spec LevelSet.union_spec + LevelSetFact.is_empty_1 LevelSetFact.empty_iff + LevelExprSet.singleton_spec LevelExprSet.add_spec LevelExprSet.union_spec LevelExprSetFact.empty_iff + @NES.singleton_spec @NES.add_spec_les + LevelMapFact.F.add_mapsto_iff LevelMapFact.F.empty_mapsto_iff + : set_specs. + +Hint Rewrite <- LevelSetProp.FM.not_mem_iff LevelSetProp.FM.mem_iff : set_specs. + +Ltac rsets := repeat (progress (autorewrite with set_specs || lset || intro + || unfold Level.eq, LevelSet.E.eq in * )). + +Ltac2 Notation "rsets" cl(opt(clause)) := + let id := Option.get (Ident.of_string "set_specs") in + Autorew.autorewrite0 [id] cl. + End FromLevelSets. \ No newline at end of file diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 17f9fb3a5..9fef51d63 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -31,6 +31,9 @@ Module MoreLevel. | Level.lvar _ | Level.lzero => false | Level.level _ => true end. + + Lemma is_global_zero : ~~ is_global zero. + Proof. reflexivity. Qed. End MoreLevel. Module LevelMap. @@ -409,7 +412,7 @@ End ZUnivConstraint. have := LoopCheck.zero_declared m. have := LoopCheck.Impl.Abstract.model_levels m.(model) Level.lzero. rewrite /LoopCheck.Impl.CorrectModel.zero_declared. intros ->. - intros [k hm]. now exists (Z.of_nat k). + intros [k hm]. now exists (Z.of_nat (S k)). Qed. Module C := LoopCheck.Impl.I.Model.Model.Clauses. @@ -754,7 +757,7 @@ End ZUnivConstraint. let add_val l := LevelMap.add l (val v l) in LevelSet.fold add_val V (LevelMap.empty _). - Import LoopCheck.Impl.Abstract (clause_sem, clauses_sem, clauses_sem_union, to_val, to_Z_val). + Import LoopCheck.Impl.CorrectModel (clause_sem, clauses_sem, clauses_sem_union, to_val, to_Z_val). Lemma clauses_sem_subset {S} {SL : Semilattice.Semilattice S Q.t} {v cls cls'} : clauses_sem v cls -> cls' ⊂_clset cls -> clauses_sem v cls'. Proof. @@ -816,40 +819,98 @@ End ZUnivConstraint. rewrite Universes.LevelExprSet.add_spec. now right. Qed. - Lemma interp_prem_to_atom v le : + Import LoopCheck (valuation). + + Definition wf_valuation V v := + forall l, LevelSet.In l V -> + if l == Level.zero then v l = 0 + else if Level.is_global l then v l > 0 + else v l >= 0. + + Lemma wf_valuation_union {V V' v} : wf_valuation (V ∪ V') v -> wf_valuation V v /\ wf_valuation V' v. + Proof. + intros wf; split; intros l hin; specialize (wf l); apply wf; lsets. + Qed. + + Lemma interp_prem_to_atom V {v} le : + wf_valuation V v -> + LevelSet.In (LevelExpr.level le) V -> interp_expr (to_Z_val v) (to_atom le) = Z.of_nat (val (to_valuation v) le). Proof. - destruct le => //=. cbn. - destruct t0. - - cbn. - - todo "handle monos". + destruct le as [l k]; cbn. + move => /(_ l) wf /wf. + destruct l => //. + - rewrite eqb_refl //= /to_Z_val; cbn. now move => ->. + - cbn. rewrite /to_Z_val => hin. hnf in hin. + change (Level.level t0) with (Universes.Level.level t0). lia. - cbn. unfold to_Z_val; cbn. lia. Qed. - Lemma interp_prems_to_atoms v l : interp_prems (to_Z_val v) (to_atoms l) = Z.of_nat (Universes.val (to_valuation v) l). + Lemma interp_prems_to_atoms {V v} (u : Universe.t) : + wf_valuation V v -> + LevelSet.Subset (Universe.levels u) V -> + interp_prems (to_Z_val v) (to_atoms u) = Z.of_nat (Universes.val (to_valuation v) u). Proof. - move: l. - apply Universe.elim. - - intros [l k]. + move: u. + apply: Universe.elim. + - intros [l k] => //= hin. rewrite to_atoms_singleton interp_prems_singleton. - rewrite val_singleton. - now rewrite (interp_prem_to_atom v (l, k)). - - intros le x eq nin. - rewrite to_atoms_add interp_prems_add. - rewrite val_add. - rewrite interp_prem_to_atom. cbn in *. + rewrite val_singleton Universe.levels_singleton => hwf. + rewrite (interp_prem_to_atom V (l, k)) //. + cbn in *; lsets. + - move=> le x eq nin wf. specialize (eq wf). + rewrite to_atoms_add interp_prems_add val_add. + rewrite Universe.levels_add => hincl. + forward eq by lsets. + rewrite (interp_prem_to_atom V) //. cbn in *. apply hincl. rsets. now left. + cbn. rewrite eq. unfold Universes.LevelExpr.t. lia. Qed. - Lemma clauses_sem_val m l r : - clauses_sem (to_Z_val (LoopCheck.valuation m)) (clauses_of_le (to_atoms l) (to_atoms r)) -> - Universes.val (to_valuation (LoopCheck.valuation m)) l <= - Universes.val (to_valuation (LoopCheck.valuation m)) r. + Lemma clauses_sem_val {V v} {l r : Universe.t} : + wf_valuation V v -> + LevelSet.Subset (Universe.levels l) V -> + LevelSet.Subset (Universe.levels r) V -> + clauses_sem (to_Z_val v) (clauses_of_le (to_atoms l) (to_atoms r)) -> + Universes.val (to_valuation v) l <= + Universes.val (to_valuation v) r. Proof. + move=> wf decll declr. move/clauses_sem_clauses_of_le. - have he := interp_prems_to_atoms (LoopCheck.valuation m) l. - have he' := interp_prems_to_atoms (LoopCheck.valuation m) r. - cbn in *. lia. + have he := @interp_prems_to_atoms V v l wf decll. + have he' := @interp_prems_to_atoms V v r wf declr. + cbn in *. unfold Universes.LevelExpr.t in *. lia. + Qed. + + Lemma clauses_sem_val_in_clauses {V v} {l r : Universe.t} : + wf_valuation V v -> + clauses_sem (to_Z_val v) (to_atoms l ⋞ to_atoms r) -> + Universe.levels l ⊂_lset V -> + Universe.levels r ⊂_lset V -> + Universes.val (to_valuation v) l <= Universes.val (to_valuation v) r. + Proof. + move=> wf cls incl incl'. + eapply clauses_sem_val; tea; etransitivity. + Qed. + + Lemma declared_clauses_levels {m} {l r : Universe.t} {d} : + LoopCheck.to_clauses (to_constraint (l, d, r)) ⊂_clset Impl.Abstract.clauses m -> + Universe.levels l ⊂_lset (levels m) /\ + Universe.levels r ⊂_lset (levels m). + Proof. + intros; split. + 1-2:etransitivity; [|apply clauses_levels_declared]. + 1-2:etransitivity; [|eapply clauses_levels_mon; tea]. + 1-2:intros l';rewrite in_to_clauses_levels in_constraint_levels_to_constraint //=; lsets. + Qed. + + Lemma wf_model_valuation m : wf_valuation (levels m) (valuation m). + Proof. + red. intros []; cbn. + - intros hz. rewrite eqb_refl. + eapply LoopCheck.model_valuation_zero. + - move=> hin. hnf. now apply LoopCheck.model_valuation_global. + - move=> hin. hnf. now apply LoopCheck.model_valuation_not_global. Qed. Lemma model_satisfies (m : univ_model) : @@ -857,12 +918,17 @@ End ZUnivConstraint. Proof. destruct m as [m cstrs repr repr_inv]. cbn. have val := LoopCheck.model_valuation m. - move=> cstr /repr /(clauses_sem_subset val). - intros cls. destruct cstr as [[l []] r]; cbn. - constructor. cbn in cls. now apply clauses_sem_val. - constructor. cbn in cls. - rewrite clauses_sem_union in cls. destruct cls as [hl hr]. - eapply Nat.le_antisymm; now apply clauses_sem_val. + move=> cstr /repr /[dup]/(clauses_sem_subset val) cls incl. + destruct cstr as [[l []] r]; cbn. + - constructor. cbn in cls. + eapply declared_clauses_levels in incl as []. + eapply clauses_sem_val_in_clauses; tea. + apply wf_model_valuation. + - constructor. cbn in cls. + rewrite clauses_sem_union in cls. destruct cls as [hl hr]. + eapply declared_clauses_levels in incl as []. + eapply Nat.le_antisymm; eapply clauses_sem_val_in_clauses; tea. + all:apply wf_model_valuation. Qed. Lemma of_valuation_spec V v : @@ -899,13 +965,18 @@ End ZUnivConstraint. Proof. intros l hin. destruct l; cbn. f_equal. - destruct e; cbn => //. todo ("mono valuation"). - unfold to_val. - destruct (find_spec (Level.lvar n0) (of_valuation V v)). - - eapply of_valuation_spec in H. - destruct H as [hin' ->]. cbn in *. - reflexivity. - - cbn in *. elim H. + destruct e; cbn => //. + all:unfold to_val; + elim: (find_spec _ (of_valuation V v)). + - move=> k H. eapply of_valuation_spec in H. + destruct H as [hin' ->]. cbn in *. lia. + - move=> hnin. cbn in *. elim hnin. + exists (val v (Level.level t0)). + rewrite [LevelMap.Raw.MapsTo _ _ _]of_valuation_spec. + split => //. + - move=> k H. eapply of_valuation_spec in H. + destruct H as [hin' ->]. cbn in *. lia. + - move=> hnin. cbn in *. elim hnin. exists (val v (Level.lvar n0)). rewrite [LevelMap.Raw.MapsTo _ _ _]of_valuation_spec. split => //. @@ -951,6 +1022,20 @@ End ZUnivConstraint. LoopCheck.check m.(UnivLoopChecking.model) (to_constraint c). Derive Signature for satisfies0. + Lemma wf_valuation_of_valuation V v : wf_valuation V (to_val (of_valuation V v)). + Proof. + move=> l hin. + have [_ hof] := of_valuation_spec V v l (val v l). + forward hof. split => //. + destruct l; cbn. + - hnf. rewrite /to_val. + now rewrite (LevelMap.find_1 hof). + - hnf. rewrite /to_val. + rewrite (LevelMap.find_1 hof). cbn. lia. + - hnf. rewrite /to_val. + rewrite (LevelMap.find_1 hof). cbn. lia. + Qed. + Lemma in_to_clauses_sem {l r V v} : LevelSet.Subset (univ_constraint_levels (l, ConstraintType.Le, r)) V -> val v l <= val v r -> @@ -959,7 +1044,8 @@ End ZUnivConstraint. Proof. move=> hlev leq [prems concl]. move=> [] [l'' k'] [] /to_levelexprzset_spec_2 [] inl' pos ->. - cbn -[le]. rewrite interp_prems_to_atoms. + cbn -[le]. + erewrite interp_prems_to_atoms. rewrite to_of_valuation_univ. { intros ? hin; apply hlev. cbn. lsets. } transitivity (Z.of_nat (val v l)). @@ -970,6 +1056,8 @@ End ZUnivConstraint. have vle := val_In_le l v _ inl'. cbn in vle. cbn; u; lia. cbn; u; lia. + apply wf_valuation_of_valuation. + intros lr hin. apply hlev. cbn. lsets. Qed. Lemma satisfies_clauses_sem v {m : univ_model} V : @@ -1010,17 +1098,22 @@ End ZUnivConstraint. clauses_sem (to_Z_val (to_val (of_valuation V v))) (LoopCheck.to_clauses (to_constraint c)) -> satisfies0 v c. Proof. + have wfv := @wf_valuation_of_valuation V v. intros hin hsem. destruct c as [[l []] r]; cbn in *. - constructor. move/clauses_sem_clauses_of_le: hsem. - rewrite !interp_prems_to_atoms. + erewrite !interp_prems_to_atoms; tea. rewrite !to_of_valuation_univ. lsets. lsets. cbn; lia. + setoid_rewrite <- hin. lsets. + setoid_rewrite <- hin. lsets. - constructor. rewrite clauses_sem_union in hsem. destruct hsem as [hsem hsem']. move/clauses_sem_clauses_of_le: hsem. move/clauses_sem_clauses_of_le: hsem'. - rewrite !interp_prems_to_atoms. + erewrite !interp_prems_to_atoms; tea. rewrite !to_of_valuation_univ. lsets. lsets. cbn; lia. + setoid_rewrite <- hin; lsets. + setoid_rewrite <- hin; lsets. Qed. Lemma val_respects cls v : @respects _ _ Z _ (horn_semi cls) _ Zsemilattice (fun u => interp_prems v u). @@ -1348,41 +1441,65 @@ End ZUnivConstraint. now rewrite -[Clauses.relations_of_clauses _]equiv_constraints_clauses. Qed. - Lemma to_valuation_val (v : Level.t -> nat) (l : Universes.Level.t) : v l = val (to_valuation v) l. + Lemma to_valuation_val V (v : Level.t -> nat) (l : Universes.Level.t) : + wf_valuation V v -> + LevelSet.In l V -> + v l = val (to_valuation v) l. Proof. + move=> wf /wf. destruct l => //=. - - todo "zero". - - todo "mono". + cbn. lia. Qed. + Hint Rewrite Universe.levels_singleton : set_specs. + (** Interpretation in the semilattice of natural numbers *) - Lemma interp_prems_val (v : Level.t -> nat) u : + Lemma interp_prems_val {V} (v : Level.t -> nat) (u : Universe.t) : + Universe.levels u ⊂_lset V -> + wf_valuation V v -> Universe.interp_prems v u = Universes.val (to_valuation v) u. Proof. - move: u. refine (Universe.interp_prems_elim v (fun u i => i = val (to_valuation v) u) _ _ _). - - now intros [l k]; rewrite val_singleton //= /val /Universe.interp_expr to_valuation_val; cbn. - - move=>[l k] u k' -> hnin. - rewrite val_add; cbn. now rewrite to_valuation_val; cbn. + move: u. refine (Universe.interp_prems_elim v (fun u i => _ -> _ -> i = val (to_valuation v) u) _ _ _). + - intros [l k]; rewrite val_singleton //= /val; rsets. cbn in *. + rewrite /Universe.interp_expr (to_valuation_val V) //; cbn. apply H; lsets. + - move=>[l k] u k' ih hnin. + rewrite Universe.levels_add //= => hincl wfv. + rewrite val_add; cbn. rewrite (to_valuation_val V) //; cbn. lsets. + forward ih. lsets. specialize (ih wfv). lia. Qed. - Lemma interp_univ_cstr_nat v cl : + Lemma interp_univ_cstr_nat V {v} cl : + wf_valuation V v -> declared_univ_cstr_levels V cl -> interp_univ_cstr (to_Z_val v) cl <-> interp_nat_cstr v cl. Proof. - destruct cl as [[l []] r] => //=; - cbn; rewrite !interp_prems_to_atoms !(interp_prems_val v) /model_val. split. all:lia. + move=> wfv. + destruct cl as [[l []] r] => //= decl; + cbn; erewrite !interp_prems_to_atoms; tea; + try rewrite !(@interp_prems_val V v) /model_val //; try (split; lia); intuition eauto. Qed. - Lemma interp_univ_cstrs_nat v cl : + Lemma interp_univ_cstrs_nat V v cl : + wf_valuation V v -> + UnivConstraintSet.For_all (declared_univ_cstr_levels V) cl -> interp_univ_cstrs (to_Z_val v) cl <-> interp_cstrs v cl. Proof. - split; move=> hin cl' /hin; now rewrite interp_univ_cstr_nat. + move=> wfV hcl. + split; move=> hin cl' /[dup]/hin => icl /hcl declcl. + now rewrite -(interp_univ_cstr_nat V) //. + now rewrite (interp_univ_cstr_nat V) //. Qed. Lemma interp_cstrs_of_m m : interp_cstrs (model_val m) (constraints m). Proof. have ha := interp_univ_cstrs_of_m m. - now apply interp_univ_cstrs_nat. + eapply interp_univ_cstrs_nat. + - eapply wf_model_valuation. + - move=> cstr /repr_constraints => hincl. + apply ndecl_nin_levels. + etransitivity; [|eapply clauses_levels_declared]. + now eapply clauses_levels_mon. + - exact ha. Qed. Lemma entails_L_completeness {p l r} : @@ -1416,14 +1533,63 @@ End ZUnivConstraint. now rewrite interp_cstr_clauses_sem. Qed. + Definition univ_constraints_levels cstrs := + UnivConstraintSet.fold (fun c => LevelSet.union (univ_constraint_levels c)) cstrs LevelSet.empty. + + Definition univ_constraints_levels_spec cstrs : + forall l, LevelSet.In l (univ_constraints_levels cstrs) <-> exists c, UnivConstraintSet.In c cstrs /\ LevelSet.In l (univ_constraint_levels c). + Proof. + rewrite /univ_constraints_levels. + eapply UnivConstraintSetProp.fold_rec. + - intros ? ? ?. split; try lsets. + intros [c [hin hin']]. ucsets. + - move=> x a s' s'' hin hin' hadd ih l. + rsets. eapply UnivConstraintSetProp.Add_Equal in hadd. setoid_rewrite hadd. + intuition eauto. + exists x. split => //. ucsets. apply ih in H0 as [c' []]. + exists c'. split; try ucsets. lsets. + destruct H as [c []]. + move:H; rewrite UnivConstraintSet.add_spec=> -[]. + * now intros <-. + * intros ins'. right. apply ih. exists c. now split. + Qed. + + Lemma constraint_levels_declared {m : univ_model} : univ_constraints_levels (constraints m) ⊂_lset levels m. + Proof. + etransitivity; [|eapply clauses_levels_declared]. + intros l; rewrite univ_constraints_levels_spec => -[] c [] hin. + revert l. change (univ_constraint_levels c ⊂_lset (clauses_levels (clauses m))). + etransitivity; [|eapply declared_univ_cstr_levels_spec]. reflexivity. + move/repr_constraints: hin => hincl. + apply ndecl_nin_levels. now apply clauses_levels_mon. + Qed. + + Lemma declared_cstrs {m : univ_model} : + UnivConstraintSet.For_all (declared_univ_cstr_levels (levels m)) (constraints m). + Proof. + intros cl hin. destruct cl as [[l d] r]. cbn. split; + transitivity (univ_constraint_levels (l, d, r)); cbn; try lsets. + transitivity (univ_constraints_levels (constraints m)) => //. + intros ?; rewrite univ_constraints_levels_spec; firstorder. + apply constraint_levels_declared. + transitivity (univ_constraint_levels (l, d, r)); cbn; try lsets. + transitivity (univ_constraints_levels (constraints m)) => //. + intros ?; rewrite univ_constraints_levels_spec; firstorder. + apply constraint_levels_declared. + Qed. + Theorem check_valid_nat {m c} : - check m c -> (forall (v : Level.t -> nat), interp_cstrs v (constraints m) -> interp_nat_cstr v c). + check m c -> (forall (v : Level.t -> nat), wf_valuation (levels m ∪ univ_constraint_levels c) v -> interp_cstrs v (constraints m) -> interp_nat_cstr v c). Proof. rewrite check_completeness. - intros hv v hp. + intros hv v wfv hp. + have [wfm wfc] := wf_valuation_union wfv. move: (hv Z Zsemilattice (to_Z_val v)). - rewrite interp_univ_cstr_nat; apply. - now apply interp_univ_cstrs_nat. + erewrite interp_univ_cstr_nat; tea. apply. + eapply interp_univ_cstrs_nat. exact wfm. + { apply declared_cstrs. } + exact hp. + destruct c as [[l d] r]; cbn. split; lsets. Qed. End UnivLoopChecking. diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 2e9686f3d..3d14f836e 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -162,7 +162,7 @@ Module Level. { ReflectEq.eqb := eqb }. Proof. intros x y. apply reflect_reflectProp, eqb_spec. - Qed. + Defined. End Level. @@ -177,7 +177,7 @@ Module LS := LevelSet. Ltac lsets := LevelSetDecide.fsetdec. Notation "(=_lset)" := LevelSet.Equal (at level 0). -Infix "=_lset" := LevelSet.Equal (at level 30). +Infix "=_lset" := LevelSet.Equal (at level 70). Notation "(==_lset)" := LevelSet.equal (at level 0). Infix "==_lset" := LevelSet.equal (at level 30). diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v index ee8809264..885a0020a 100644 --- a/utils/theories/NonEmptyLevelExprSet.v +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -94,9 +94,11 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) Module LevelExprSetExtraDecide := MSetDecide.Decide LevelExprSet. Ltac lesets := LevelExprSetDecide.fsetdec. + Infix "=_lset" := LevelSet.Equal (at level 70). + Import -(notations) LevelExprSet. - Infix "⊂_leset" := LevelExprSet.Subset (at level 90). - Infix "=_leset" := LevelExprSet.Equal (at level 90). + Infix "⊂_leset" := LevelExprSet.Subset (at level 70). + Infix "=_leset" := LevelExprSet.Equal (at level 70). Import CommutativeMonoid. Module Export OfQ := OfQuantity Q. @@ -402,7 +404,7 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) destruct t_ne0. lesets. Qed. - Infix "∪" := union (at level 70): nes_scope. + Infix "∪" := union (at level 60): nes_scope. Lemma union_spec u u' l : LevelExprSet.In l (u ∪ u') <-> @@ -468,6 +470,32 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) rewrite levels_spec_aux. intuition auto. lsets. Qed. + + Lemma levelexprset_singleton {l le} : (exists k : Q.t, LevelExprSet.In (l, k) (singleton le)) <-> (l, le.2) = le. + Proof. + split. + - move=> [] k. now move/LevelExprSet.singleton_spec; rewrite /E.eq => <-. + - intros <-. now exists le.2; apply LevelExprSet.singleton_spec. + Qed. + + Lemma levels_singleton le : levels (LevelExprSet.singleton le) =_lset LevelSet.singleton le.1. + Proof. + intros l; rewrite levels_spec. + rewrite LevelSet.singleton_spec; setoid_rewrite LevelExprSet.singleton_spec. + rewrite /E.eq /LevelSet.E.eq. firstorder. now subst. subst. exists le.2; now destruct le. + Qed. + + Lemma levels_union {u u'} : levels (u ∪ u') =_lset LevelSet.union (levels u) (levels u'). + Proof. + intros l; rewrite levels_spec; setoid_rewrite LevelExprSet.union_spec. + rewrite LevelSet.union_spec !levels_spec. firstorder. + Qed. + + Lemma levels_add {le u} : levels (add le u) =_lset LevelSet.union (LevelSet.singleton le.1) (levels u). + Proof. + rewrite -union_add_singleton levels_union levels_singleton; lsets. + Qed. + #[export] Instance proper_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) levels. Proof. From 2575b857d4a69e42e6bd7b24bcfef5705af542e6 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 29 Sep 2025 10:47:42 +0200 Subject: [PATCH 077/164] Close remaining admits --- common/theories/LoopChecking/Deciders.v | 83 ++++++++++++++++--------- 1 file changed, 54 insertions(+), 29 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 4fda0c91d..cd8f1ff81 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -135,11 +135,62 @@ Qed. Definition correct_model (cls : clauses) (m : model) := enabled_clauses m cls /\ is_model cls m. -Lemma enabled_clauses_le {m v u} : enabled_clauses m (v ⋞ u)%cls <-> - defined_model_of (levels u) m. + + +Lemma clauses_of_le_singleton le r : + (singleton le ⋞ r)%cls =_clset Clauses.singleton (r, le). +Proof. + intros l. + rewrite Clauses.singleton_spec clauses_of_le_spec. + firstorder. + - subst l. apply LevelExprSet.singleton_spec in H. + now red in H; subst x. + - subst l. exists le. split => //. now apply LevelExprSet.singleton_spec. +Qed. + +Lemma clauses_of_le_add le l r : + (NES.add le l ⋞ r)%cls =_clset Clauses.add (r, le) (l ⋞ r). Proof. + intros cl. + rewrite Clauses.add_spec clauses_of_le_spec. split. -Admitted. + - move=> [] x [] /LevelExprSet.add_spec; rewrite /LevelExprSet.E.eq. + move=> [->|hin]. now left. + intros ->. right. rewrite clauses_of_le_spec. now exists x. + - move=> [->|]. exists le. split => //. + * now apply LevelExprSet.add_spec; left. + * rewrite clauses_of_le_spec => -[] k [] hin ->. + exists k. split => //. now apply LevelExprSet.add_spec. +Qed. + +Lemma enabled_clauses_of_le m v u : + (exists z, min_premise m u = Some z) -> + enabled_clauses m (v ⋞ u)%cls. +Proof. + intros hmin cl hcl. + eapply clauses_of_le_spec in hcl. + destruct hcl as [lk [hin eq]]. subst cl. + hnf. now cbn. +Qed. + +Lemma enabled_clauses_le {m} {v u : NES.t} : defined_model_of (levels u) m -> enabled_clauses m (v ⋞ u)%cls. +Proof. + intros def. eapply enabled_clauses_of_le. + move: u def; apply: NES.elim. + - intros le. rewrite levels_singleton min_premise_singleton. + intros h. specialize (h le.1). forward h by now rsets. + destruct h as [k hm]; rewrite /min_atom_value. + destruct le; cbn. rewrite (level_value_MapsTo hm). now eexists. + - intros le r hd hnin hdef. + rewrite levels_add in hdef. + rewrite min_premise_add. + eapply defined_model_of_union_inv in hdef as []. + forward hd by auto. + destruct hd as [z ->]. + specialize (H le.1); forward H by now rsets. + destruct H as [k hm]; rewrite /min_atom_value. + destruct le; cbn. rewrite (level_value_MapsTo hm). now eexists. +Qed. Definition infer_correctness cls := match infer_model cls with @@ -1470,32 +1521,6 @@ Module Abstract. eapply entails_clauses_trans; tea. eapply entails_clauses_of_relations. Qed. - Lemma clauses_of_le_singleton le r : - (singleton le ⋞ r)%cls =_clset Clauses.singleton (r, le). - Proof. - intros l. - rewrite Clauses.singleton_spec clauses_of_le_spec. - firstorder. - - subst l. apply LevelExprSet.singleton_spec in H. - now red in H; subst x. - - subst l. exists le. split => //. now apply LevelExprSet.singleton_spec. - Qed. - - Lemma clauses_of_le_add le l r : - (NES.add le l ⋞ r)%cls =_clset Clauses.add (r, le) (l ⋞ r). - Proof. - intros cl. - rewrite Clauses.add_spec clauses_of_le_spec. - split. - - move=> [] x [] /LevelExprSet.add_spec; rewrite /LevelExprSet.E.eq. - move=> [->|hin]. now left. - intros ->. right. rewrite clauses_of_le_spec. now exists x. - - move=> [->|]. exists le. split => //. - * now apply LevelExprSet.add_spec; left. - * rewrite clauses_of_le_spec => -[] k [] hin ->. - exists k. split => //. now apply LevelExprSet.add_spec. - Qed. - Lemma clauses_sem_leq {S} {SL : Semilattice S Q.t} (V : Level.t -> S) l r : clauses_sem V (l ⋞ r) <-> (interp_prems V l ≤ interp_prems V r)%sl. From 755fc099b30a5f96f2f564d24a18157dcbc339b3 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 29 Sep 2025 11:45:02 +0200 Subject: [PATCH 078/164] Cleanups --- common/theories/LoopChecking/Deciders.v | 11 ----------- common/theories/LoopChecking/UnivLoopChecking.v | 3 +-- utils/theories/NonEmptyLevelExprSet.v | 2 +- 3 files changed, 2 insertions(+), 14 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index cd8f1ff81..40ed0d5a2 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -1759,17 +1759,6 @@ Module LoopChecking (LS : LevelSets). check m c <-> valid_entailments (clauses m) (to_clauses c). Proof. apply check_clauses_complete. Qed. - Lemma check_declared m c : - check m c -> LevelSet.Subset (clauses_levels (to_clauses c)) (levels m). - Proof. - rewrite /check /Impl.check_clauses. - move: (to_clauses c) => cls. - move/Clauses.for_all_spec. - move: cls; apply: ClausesProp.set_induction. - - intros s he. - cl. hin. - - (* Returns the valuation of the model: a minimal assignement from levels to constraints that make the enforced clauses valid. *) diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 9fef51d63..4ab883ff6 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -650,7 +650,6 @@ End ZUnivConstraint. Qed. - (* We ignore errors here, which can happen only if the levels are already declared *) Equations? declare_level (m : univ_model) (l : Level.t) : option univ_model := declare_level m l with inspect (LoopCheck.declare_level m.(model) l) := { | exist (Some model) eq with inspect (init_constraint_of_level l) := @@ -1567,7 +1566,7 @@ End ZUnivConstraint. Lemma declared_cstrs {m : univ_model} : UnivConstraintSet.For_all (declared_univ_cstr_levels (levels m)) (constraints m). Proof. - intros cl hin. destruct cl as [[l d] r]. cbn. split; + intros cl hin. destruct cl as [[l d] r]. cbn. split. transitivity (univ_constraint_levels (l, d, r)); cbn; try lsets. transitivity (univ_constraints_levels (constraints m)) => //. intros ?; rewrite univ_constraints_levels_spec; firstorder. diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v index 885a0020a..06e091990 100644 --- a/utils/theories/NonEmptyLevelExprSet.v +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -846,7 +846,7 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) now rewrite join_assoc. Qed. - Lemma clauses_sem_subset {u u' : t} : u ⊂_leset u' -> + Lemma interp_prems_subset {u u' : t} : u ⊂_leset u' -> interp_prems u ≤ interp_prems u'. Proof. intros hsub. From 6d3706cf9b96ffc94e75825d817af5ea51e843d9 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 29 Sep 2025 18:11:41 +0200 Subject: [PATCH 079/164] Finished tedious enforce/add_level specs --- .../theories/LoopChecking/UnivLoopChecking.v | 919 ++++++++++----- common/theories/Universes.v | 1 + common/theories/UniversesDec.v | 2 +- common/theories/uGraph.v | 1046 +---------------- utils/_RocqProject | 2 +- 5 files changed, 630 insertions(+), 1340 deletions(-) diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 4ab883ff6..273323b9f 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -183,8 +183,12 @@ Qed. Module UnivLoopChecking. Module LoopCheck := LoopChecking LS. + Import LoopCheck.Impl.Abstract. + Import LoopCheck.Impl.CorrectModel (clauses_sem, clause_sem, clauses_sem_union). Import LoopCheck.Impl.I. + Definition to_atom '(l, k) : LevelExpr.t := (l, Z.of_nat k). + Program Definition to_atoms (u : Universe.t) : NES.t := {| NES.t_set := to_levelexprzset u |}. Next Obligation. @@ -198,6 +202,38 @@ Module UnivLoopChecking. congruence. Qed. + Lemma to_atoms_singleton l k : to_atoms (Universe.singleton (l, k)) = NES.singleton (l, Z.of_nat k). + Proof. + apply NES.equal_exprsets. + rewrite /to_atoms //=. + Qed. + + Lemma to_atoms_add le u : to_atoms (Universe.add le u) = NES.add (to_atom le) (to_atoms u). + Proof. apply NES.equal_exprsets => //=. + move=> [l k]. + rewrite LevelExprSet.add_spec. + split. + - move/to_levelexprzset_spec_2 => []. + rewrite Universes.LevelExprSet.add_spec => -[<-|hin]. + * move=> pos. + left. cbn. lia_f_equal. + * move=> pos. right. + apply to_levelexprzset_spec_1 in hin. + rewrite Z2Nat.id // in hin. + - move=> [eq|hin]. + destruct le; noconf eq. + * apply to_levelexprzset_spec_1. + rewrite Universes.LevelExprSet.add_spec. + now left. + * apply to_levelexprzset_spec_2 in hin as [hin pos]. + have [k' eq] : exists z, Z.of_nat z = k. exists (Z.to_nat k). + rewrite Z2Nat.id //. subst k. + apply to_levelexprzset_spec_1. + rewrite Nat2Z.id in hin. + rewrite Universes.LevelExprSet.add_spec. now right. + Qed. + + Program Definition from_atoms (u : NES.t) : Universe.t := {| Universe.t_set := from_levelexprzset (NES.t_set u) |}. Next Obligation. @@ -451,8 +487,6 @@ End ZUnivConstraint. exists (Z.of_nat k). now rewrite (in_to_atoms (l, k)). Qed. - Definition to_atom '(l, k) : LevelExpr.t := (l, Z.of_nat k). - Lemma exists_to_atoms_spec f u : LevelExprSet.Exists f (to_atoms u) <-> exists le, Universes.LevelExprSet.In le u /\ f (to_atom le). @@ -474,6 +508,253 @@ End ZUnivConstraint. rewrite Nat2Z.id //. Qed. + + Definition relation_of_constraint (c : ZUnivConstraint.t) := + let '(l, d, r) := c in + match d with + | ConstraintType.Le => ((l ∪ r)%nes, r) + | ConstraintType.Eq => (l, r) + end. + + Definition Zuniv_constraint_levels (c : ZUnivConstraint.t) := + let '(l, d, r) := c in + LevelSet.union (NES.levels l) (NES.levels r). + + Definition relations_of_constraints c := + ZUnivConstraintSet.fold (fun c acc => relation_of_constraint c :: acc) c []. + + Lemma relations_of_constraints_spec {r cstrs} : List.In r (relations_of_constraints cstrs) <-> + exists cl, ZUnivConstraintSet.In cl cstrs /\ r = relation_of_constraint cl. + Proof. + rewrite /relations_of_constraints. + eapply ZUnivConstraintSetProp.fold_rec. + - move=> s' he; split => //. + intros [cl []]. now apply he in H. + - move=> x a s' s'' hni hnin hadd. + split. + { cbn. move=> [] h. + * exists x. split => //. apply hadd. now left. + * apply H in h as [cl []]; eexists; split; tea. apply hadd. now right. } + { move=> [] cl [] /hadd[]. + * intros -> ->. now left. + * intros hin heq. right; apply H. exists cl; split => //. } + Qed. + + Definition levels_of_z_constraints c := + ZUnivConstraintSet.fold (fun c acc => LevelSet.union (Zuniv_constraint_levels c) acc) c LevelSet.empty. + + Import ISL. + + Lemma equiv_L_rels_eq {l r} : + [l ≡ r] ⊫ℒ relations_of_clauses (clauses_of_le l r) ++ relations_of_clauses (clauses_of_le r l). + Proof. + rewrite /clauses_of_eq. split. + - apply app_Forall. + * apply Forall_forall => rel. + have [he he'] := entails_L_relations_of_clauses_le l r. + red in he, he'. + rewrite Forall_forall in he'. move/he'. + intros ent. destruct rel. + eapply entails_L_all_one_trans; tea. + constructor. apply entails_L_eq_le_1, entails_c; repeat constructor. constructor. + * apply Forall_forall => rel. + have [he he'] := entails_L_relations_of_clauses_le r l. + red in he, he'. + rewrite Forall_forall in he'. move/he'. + intros ent. destruct rel. + eapply entails_L_all_one_trans; tea. + constructor. apply entails_L_eq_le_2, entails_c; repeat constructor. constructor. + - constructor; [|constructor]. + apply entails_L_eq_antisym. split. + * have [he he'] := entails_L_relations_of_clauses_le l r. + eapply entails_L_rels_subset. depelim he. tea. + red. intros r' hin. rewrite in_app_iff. now left. + * have [he he'] := entails_L_relations_of_clauses_le r l. + eapply entails_L_rels_subset. depelim he. tea. + red. intros r' hin. rewrite in_app_iff. now right. + Qed. + + Lemma entails_L_relations_of_clauses_eq l r : + relations_of_clauses (l ≡ r) ⊫ℒ [l ≡ r]. + Proof. + split. + - constructor. apply entails_L_relations_of_clauses_eq. constructor. + - apply Forall_forall => rel. + move/relations_of_clauses_spec => [] prems [] concl [] hin ->. + move: hin; rewrite /clauses_of_eq Clauses.union_spec => -[] hin. + * setoid_rewrite equiv_L_rels_eq. + eapply entails_L_rels_subset; revgoals. + { intros rel'. rewrite in_app_iff. left. tea. } + now eapply entails_L_in_cls. + * setoid_rewrite equiv_L_rels_eq. + eapply entails_L_rels_subset; revgoals. + { intros rel'. rewrite in_app_iff. right. tea. } + now eapply entails_L_in_cls. + Qed. + + Lemma relation_of_constraint_of_clause cstr : + relations_of_clauses (LoopCheck.to_clauses cstr) ⊫ℒ [relation_of_constraint cstr]. + Proof. + destruct cstr as [[l []] r]. cbn. + apply entails_L_relations_of_clauses_le. + apply entails_L_relations_of_clauses_eq. + Qed. + + Lemma of_z_constraints_subset {cstrs cstrs'} : + ZUnivConstraintSet.Subset cstrs cstrs' -> + of_z_constraints cstrs ⊂_clset of_z_constraints cstrs'. + Proof. + move=> hsub cl /of_z_constraints_spec => -[] cstr [] hin incl. + rewrite of_z_constraints_spec. exists cstr. split => //. now apply hsub. + Qed. + + Lemma of_z_constraints_add x s : + of_z_constraints (ZUnivConstraintSet.add x s) =_clset Clauses.union (LoopCheck.to_clauses x) (of_z_constraints s). + Proof. + move=> cl; split. + - move/of_z_constraints_spec => -[] cstr [] hin incl. + rewrite Clauses.union_spec. rewrite ZUnivConstraintSet.add_spec in hin. + move: hin => [<-|]. now left. + move=> ins. right. rewrite of_z_constraints_spec. exists cstr; split => //; now right. + - rewrite Clauses.union_spec => -[]; destruct x as [[l []] r]. + * move/LoopCheck.to_clauses_spec => [] k [hin] ->. + rewrite of_z_constraints_spec. eexists; split => //. + rewrite ZUnivConstraintSet.add_spec; left; trea. + cbn. now eapply in_clause_of_le. + * intros hcl; rewrite of_z_constraints_spec //. eexists; split. + rewrite ZUnivConstraintSet.add_spec; left; trea. exact hcl. + * rewrite of_z_constraints_spec => -[] cstr [] hin heq. + rewrite of_z_constraints_spec. exists cstr. split => //. + rewrite ZUnivConstraintSet.add_spec; now right. + * rewrite of_z_constraints_spec => -[] cstr [] hin heq. + rewrite of_z_constraints_spec. exists cstr. split => //. + rewrite ZUnivConstraintSet.add_spec; now right. + Qed. + + Lemma relations_of_clauses_constraints_add {x s} : + (relation_of_constraint x :: relations_of_clauses (of_z_constraints s)) ⊫ℒ + (relations_of_clauses (of_z_constraints (ZUnivConstraintSet.add x s))). + Proof. + rewrite of_z_constraints_add relations_of_clauses_union. + eapply (entails_L_all_union (x := [_])). + 2:{ reflexivity. } + now rewrite relation_of_constraint_of_clause. + Qed. + + Lemma rels_of_z_constraints_spec {cstrs} : + relations_of_clauses (of_z_constraints cstrs) ⊫ℒ relations_of_constraints cstrs. + Proof. + rewrite /relations_of_constraints. + have he := ZUnivConstraintSetProp.fold_rec + (P := fun s f => relations_of_clauses (of_z_constraints s) ⊫ℒ f). apply: he. + - split. constructor. red. apply Forall_forall => [] l r. + eapply relations_of_clauses_spec in r as [prems [concl [hin heq]]]. subst l. + eapply of_z_constraints_spec in hin as [cstr [hin ]]. now apply H in hin. + - move=> x a s' s'' hin hnin hadd hr. + rewrite entails_equiv_cons. + split; [|split] => //. + * have hins'' : ZUnivConstraintSet.In x s''. + { apply hadd; now left. } + rewrite -relation_of_constraint_of_clause. + apply entails_L_clauses_subset_all. + move=> cl incl. apply of_z_constraints_spec. now exists x. + * have ha := @entails_L_clauses_subset_all (of_z_constraints s') (of_z_constraints s''). + transitivity (relations_of_clauses (of_z_constraints s')) => //. + apply ha. apply of_z_constraints_subset => ? hin'. apply hadd. now right. + apply hr. + * destruct hr. + transitivity (relation_of_constraint x :: relations_of_clauses (of_z_constraints s')). + apply entails_L_clauses_cons. now apply entails_L_c; constructor. + now eapply (entails_L_all_weaken (w:=[_])). + clear -hadd; intros. + rewrite relations_of_clauses_constraints_add. + eapply entails_L_clauses_subset_all. + eapply of_z_constraints_subset. + apply ZUnivConstraintSetProp.Add_Equal in hadd. now rewrite hadd. + Qed. + + Lemma equiv_constraints_clauses m : + relations_of_constraints (to_z_cstrs (constraints m)) ⊫ℒ + Clauses.relations_of_clauses (LoopCheck.clauses (UnivLoopChecking.model m)). + Proof. + have repr := repr_constraints. + have repr_inv := repr_constraints_inv. + rewrite -rels_of_z_constraints_spec. + rewrite -to_clauses_of_z_constraints. + rewrite (@relations_of_clauses_eq (to_clauses (constraints m)) + (LoopCheck.clauses m)) //. + 2:{ reflexivity. } + intros cl. rewrite UnivLoopChecking.to_clauses_spec. + split. + - move=> [] cstrs [] /repr incl intocl. + apply incl, intocl. + - now move/repr_inv. + Qed. + (** Equivalence of interpretations between constraints and relations derived from them *) + + Import Semilattice. + (** Lifting interpretation to constraints (on Z). *) + + Section interp. + Import Semilattice. + Context {S : Type} {SL : Semilattice S Z}. + Context (v : Level.t -> S). + + Definition interp_z_cstr c := + let '(l, d, r) := c in + match d with + | ConstraintType.Le => interp_prems v l ≤ interp_prems v r + | ConstraintType.Eq => interp_prems v l ≡ interp_prems v r + end%Z. + + Definition interp_univ_cstr c := interp_z_cstr (to_constraint c). + Definition interp_univ_cstrs c := UnivConstraintSet.For_all interp_univ_cstr c. + + End interp. + + Lemma interp_univ_cstrs_relations {S} {SL : Semilattice S Z} v cstrs : + interp_univ_cstrs v cstrs <-> + interp_rels v (relations_of_constraints (to_z_cstrs cstrs)). + Proof. + rewrite /interp_univ_cstrs. + split. + - intros hf. red in hf. red. + apply Forall_forall. move=> [l r] /relations_of_constraints_spec [[[l' d] r'] [hin heq]]. + cbn in heq; noconf heq. destruct d; noconf heq. + * eapply to_z_cstrs_spec_2 in hin as [cstr [hin heq]]. + destruct cstr as [[] ?]; noconf heq. specialize (hf _ hin). cbn in hf. + rewrite /interp_rel interp_prems_union; cbn in *. exact hf. + * eapply to_z_cstrs_spec_2 in hin as [cstr [hin heq]]. + destruct cstr as [[] ?]; noconf heq. specialize (hf _ hin). cbn in hf. + exact hf. + - intros hi uc hin. red in hi. rewrite Forall_forall in hi. + move: (hi (relation_of_constraint (to_constraint uc))) => /fwd. + rewrite relations_of_constraints_spec; exists (to_constraint uc); split => //. + now apply to_z_cstrs_spec_1 in hin as [cstrz [hin ->]]. + destruct uc as [[l []] r] => //=. + rewrite interp_prems_union //=. + Qed. + + Import LoopCheck.Impl.CorrectModel (clause_sem, clauses_sem, clauses_sem_union, to_val, to_Z_val). + + Lemma interp_cstr_clauses_sem {c} {S} {SL : Semilattice S Q.t} {v : Level.t -> S} : + interp_univ_cstr v c <-> clauses_sem v (LoopCheck.to_clauses (to_constraint c)). + Proof. + rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. + rewrite relation_of_constraint_of_clause. + rewrite /Clauses.ISL.interp_rels Forall_tip. + destruct c as [[l []] r]; cbn => //. + now rewrite interp_prems_union. + Qed. + + Lemma interp_cstrs_clauses_sem {m} {S} {SL : Semilattice S Q.t} {v : Level.t -> S} : + interp_univ_cstrs v (constraints m) <-> clauses_sem v (LoopCheck.clauses m). + Proof. + rewrite interp_univ_cstrs_relations. + rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. + now rewrite -[Clauses.relations_of_clauses _]equiv_constraints_clauses. + Qed. + Equations? init_model : univ_model := init_model := {| model := LoopCheck.init_model; constraints := UnivConstraintSet.empty |}. @@ -602,6 +883,167 @@ End ZUnivConstraint. - clear H Heqcall. reflexivity. Qed. + Definition valuation_to_Z (v : Universes.valuation) : Level.t -> Z := + fun l => Z.of_nat (val v l). + + Lemma interp_prems_valuation_to_Z v u : + interp_prems (valuation_to_Z v) (to_atoms u) = Z.of_nat (Universes.val v u). + Proof. + move: u. + apply: Universe.elim. + - intros [l k]; rewrite to_atoms_singleton interp_prems_singleton //= val_singleton //=. + rewrite /valuation_to_Z. cbn. lia. + - intros [l k] x hx hnin. + rewrite to_atoms_add !interp_prems_add //= val_add //= /valuation_to_Z hx; cbn. + lia. + Qed. + + Lemma clauses_sem_satisfies0_equiv v cstr : clauses_sem (valuation_to_Z v) (LoopCheck.to_clauses (to_constraint cstr)) <-> satisfies0 v cstr. + Proof. + destruct cstr as [[l []] r]; cbn. + - rewrite clauses_sem_leq !interp_prems_valuation_to_Z. + split; cbn. + * constructor; lia. + * intros s; depelim s. lia. + - rewrite clauses_sem_eq !interp_prems_valuation_to_Z. + split; cbn. + * constructor. lia. + * intros s; depelim s. lia. + Qed. + + Lemma clauses_sem_satisfies_equiv v cstrs : clauses_sem (valuation_to_Z v) (to_clauses cstrs) <-> satisfies v cstrs. + Proof. + unfold to_clauses. + eapply UnivConstraintSetProp.fold_rec. + - split; cbn. + intro cs. red. intros cl hin. ucsets. + intros cl hin. clsets. + - intros x a s' s'' hin hnin hadd ih. + rewrite clauses_sem_union ih. + rewrite clauses_sem_satisfies0_equiv. + eapply UnivConstraintSetProp.Add_Equal in hadd. rewrite hadd. + rewrite UnivConstraintSetProp.add_union_singleton satisfies_union. + split => -[]; split => //. red. intros c hin'. + apply UnivConstraintSet.singleton_spec in hin'. now subst x. + move: (a0 x) => /fwd. ucsets. trivial. + Qed. + + Lemma satisfies_clauses_sem_to_Z v {m : univ_model} : + satisfies v (constraints m) -> + clauses_sem (valuation_to_Z v) (LoopCheck.clauses (UnivLoopChecking.model m)). + Proof. + have repr := repr_constraints_inv m. + have repr_inv := repr_constraints m. + move=> hs cl /[dup] hin /repr [] c [] /[dup] /repr_inv hr /hs sat. + destruct c as [[l' d] r]. + apply clauses_sem_satisfies0_equiv in sat. + red in sat. now move/sat. + Qed. + + Lemma enforce_inconsistent m (c : UnivConstraint.t) u : + UnivLoopChecking.enforce m c = Some (inr u) -> ~ exists v, satisfies v (UnivConstraintSet.add c (constraints m)). + Proof. + funelim (UnivLoopChecking.enforce m c) => //=. + move=> [=]; intros <-; cbn. clear H Heqcall. + intros [v sat]. + have he := LoopCheck.enforce_inconsistent eq0 Z Zsemilattice (valuation_to_Z v). + rewrite clauses_sem_union clauses_sem_satisfies0_equiv in he. + rewrite UnivConstraintSetProp.add_union_singleton satisfies_union in sat. + destruct sat as [satc satcs]. + specialize (satc c). forward satc; try ucsets. + forward he. + { split => //. now apply satisfies_clauses_sem_to_Z. } + destruct loop0 as [u hu]. cbn in he. + apply clauses_sem_eq in he. rewrite interp_add_prems in he. cbn -[Z.add] in he. lia. + Qed. + + Definition enforce_constraints_aux (g : option univ_model) (cstrs : UnivConstraintSet.t) : option univ_model := + UnivConstraintSet.fold (fun l g => + match g with + | None => None + | Some g => match UnivLoopChecking.enforce g l with + | Some (inl m) => Some m + | _ => None + end + end) cstrs g. + + Definition enforce_constraints g cstrs := enforce_constraints_aux (Some g) cstrs. + + Definition declared_univ_cstrs_levels levels cstrs := UnivConstraintSet.For_all (declared_univ_cstr_levels levels) cstrs. + + Lemma satisfies_singleton v x : satisfies v (UnivConstraintSet.singleton x) <-> satisfies0 v x. + Proof. Admitted. + + Lemma enforce_constraints_aux_spec m cstrs : + match enforce_constraints_aux m cstrs with + | None => + (m = None) \/ (exists minit, m = Some minit /\ + (~ (declared_univ_cstrs_levels (levels minit) cstrs) \/ + ~ (exists v : valuation, satisfies v (UnivConstraintSet.union cstrs (constraints minit))))) + | Some m' => exists init, m = Some init /\ levels m' = levels init /\ constraints m' =_ucset UnivConstraintSet.union cstrs (constraints init) + end. + Proof. + unfold enforce_constraints_aux. + eapply UnivConstraintSetProp.fold_rec. + - intros s' he. destruct m => //. exists u. split => //. split => //. + ucsets. now left. + - intros x a s' s'' incstrs ins' hadd. + destruct a => //. + intros [init [heq []]]. subst m. + destruct (UnivLoopChecking.enforce u x) as [[m'|lo]|] eqn:he. + * move/enforce_model: he. + move=> [] eql eqc. rewrite -eql. setoid_rewrite <- eqc. + exists init; split => //. split => //. + apply UnivConstraintSetProp.Add_Equal in hadd. rewrite hadd H0. + ucsets. + * move/enforce_inconsistent: he. + apply UnivConstraintSetProp.Add_Equal in hadd. + right. exists init. split => //. right. + move: he. setoid_rewrite UnivConstraintSetProp.add_union_singleton; setoid_rewrite hadd. + setoid_rewrite H0. + intros he [v sat]. apply he. exists v. + match goal with + | [ sat : satisfies _ ?s |- satisfies _ ?s' ] => have eq : s =_ucset s' + end. ucsets. + now rewrite -eq. + * move/enforce_None: he. right. exists init. split => //. left. + rewrite -H. intros hd; apply he. + apply UnivConstraintSetProp.Add_Equal in hadd. + rewrite hadd in hd. red in hd. + move: (hd x) => /fwd. ucsets. auto. + * intros []; intuition auto. + right. destruct H as [minit []]. exists minit. split => //. subst m. + apply UnivConstraintSetProp.Add_Equal in hadd. + setoid_rewrite hadd. destruct H0. left. + intros. apply H. move=> l hin. move: (H0 l) => /fwd //. ucsets. + right. + intros [v sat]. apply H; exists v. move: sat. + setoid_rewrite UnivConstraintSetProp.add_union_singleton. + move/satisfies_union => [] /satisfies_union [] ? ? ?. now apply satisfies_union. + Qed. + + Lemma enforce_constraints_spec {m m' cstrs} : + enforce_constraints m cstrs = Some m' -> levels m' = levels m /\ + constraints m' =_ucset UnivConstraintSet.union cstrs (constraints m). + Proof. + have := (enforce_constraints_aux_spec (Some m) cstrs). + rewrite /enforce_constraints. destruct enforce_constraints_aux. + move=> [] init [] [=] eq [] eql eqc. subst m. + intros [=]. subst m'. split=> //. + intros _ => //. + Qed. + + Lemma enforce_constraints_None {m cstrs} : + enforce_constraints m cstrs = None -> + ~ (declared_univ_cstrs_levels (levels m) cstrs) \/ + ~ (exists v : valuation, satisfies v (UnivConstraintSet.union cstrs (constraints m))). + Proof. + have := (enforce_constraints_aux_spec (Some m) cstrs). + rewrite /enforce_constraints. destruct enforce_constraints_aux. + move=> [] init [] [=] eq [] eql eqc. subst m. move=> //. + move=> [] => // [] [] minit [] [=] -> [] ne _. now left. now right. + Qed. + Lemma declared_init_constraint_of_level_spec {l c cstrs}: init_constraint_of_level l = Some c -> declared_init_constraint_of_level l (UnivConstraintSet.add c cstrs). @@ -649,6 +1091,11 @@ End ZUnivConstraint. f_equal. apply equal_exprsets. rewrite /to_atoms //=. Qed. + Definition add_opt_cstr (c : option UnivConstraint.t) s := + match c with + | None => s + | Some c => UnivConstraintSet.add c s + end. Equations? declare_level (m : univ_model) (l : Level.t) : option univ_model := declare_level m l with inspect (LoopCheck.declare_level m.(model) l) := @@ -688,29 +1135,141 @@ End ZUnivConstraint. eapply declared_zero. Qed. - Local Definition declare_levels_aux m l := - LevelSet.fold (fun l m => - match LoopCheck.declare_level m l return _ with - | None => m - | Some m => m - end) l m. + Lemma declare_level_None {l m}: declare_level m l = None <-> LevelSet.In l (levels m). + Proof. + funelim (declare_level m l) => //. + - split => // _. + clear H. + now move/LoopCheck.declare_level_None: eqdecl. + - split => //. rewrite -LoopCheck.declare_level_None. rewrite eq0 => //. + - bang. + Qed. - Lemma declare_levels_aux_spec m l : - LoopCheck.levels (declare_levels_aux m l) =_lset - LevelSet.union l (LoopCheck.levels m). + Lemma declare_level_Some {l m m'}: declare_level m l = Some m' -> + [/\ ~ LevelSet.In l (levels m), levels m' =_lset LevelSet.add l (levels m) & + exists c, init_constraint_of_level l = Some c /\ constraints m' =_ucset UnivConstraintSet.add c (constraints m)]. Proof. - rewrite /declare_levels_aux. + funelim (declare_level m l) => //. + - move=> [=] <-. cbn. + clear H H0 Heqcall. + move/LoopCheck.declare_level_levels: eq0 => -[] nin eql. + split => //. exists c. split => //. + - bang. + Qed. + + Definition declare_level_aux l (g : option univ_model) := + match g with + | None => None + | Some g => declare_level g l + end. + + (* Import UnivLoopChecking. *) + Lemma declare_level_aux_spec l g : + declare_level_aux l g = None <-> (g = None \/ exists g', g = Some g' /\ LevelSet.In l (levels g')). + Proof. + destruct g => //=. + - rewrite declare_level_None. + split => //. right. exists u. split => //. + now move=> [] // [] g' [] [=] ->. + - split => //. move=> _. now left. + Qed. + + Lemma declare_level_aux_Some l g g'' : + declare_level_aux l g = Some g'' -> (exists g', g = Some g' /\ ~ LevelSet.In l (levels g') /\ levels g'' =_lset LevelSet.add l (levels g') /\ + exists c, init_constraint_of_level l = Some c /\ constraints g'' =_ucset UnivConstraintSet.add c (constraints g')). + Proof. + destruct g => //=. + exists u. split => //. rewrite -declare_level_None H; split=> //. + apply declare_level_Some in H as [] => //. + Qed. + + Definition declare_levels_aux (g : option univ_model) (levels : LevelSet.t) : option univ_model := + LevelSet.fold declare_level_aux levels g. + + Definition declare_levels (g : univ_model) (levels : LevelSet.t) : option univ_model := + declare_levels_aux (Some g) levels. + + Definition init_constraints_of_levels ls := + LevelSet.fold (fun l cstrs => + match init_constraint_of_level l with + | None => cstrs + | Some c => UnivConstraintSet.add c cstrs + end) ls UnivConstraintSet.empty. + + Lemma init_constraints_of_levels_spec ls : + forall l, LevelSet.In l ls -> forall c, init_constraint_of_level l = Some c -> UnivConstraintSet.In c (init_constraints_of_levels ls). + Proof. Admitted. + + Lemma init_constraints_of_levels_spec_inv ls : + forall c, UnivConstraintSet.In c (init_constraints_of_levels ls) -> + exists l c, LevelSet.In l ls /\ init_constraint_of_level l = Some c. + Proof. Admitted. + + Instance init_constraints_of_levels_proper : Proper (LevelSet.Equal ==> UnivConstraintSet.Equal) (init_constraints_of_levels). + Proof. + intros l l' eqll' cl. + rewrite /init_constraints_of_levels. + Admitted. + + Lemma init_constraints_of_levels_add l c ls : + init_constraint_of_level l = Some c -> + init_constraints_of_levels (LevelSet.add l ls) =_ucset UnivConstraintSet.add c (init_constraints_of_levels ls). + Proof. Admitted. + + + Hint Rewrite UnivConstraintSet.union_spec : set_specs. + + Lemma declare_levels_aux_spec og ls : + match declare_levels_aux og ls with + | None => og = None \/ exists l, LevelSet.In l ls /\ LevelSet.In l (option_get LevelSet.empty (option_map UnivLoopChecking.levels og)) + | Some g' => exists init, og = Some init /\ (forall l, LevelSet.In l ls -> ~ LevelSet.In l (levels init)) /\ levels g' =_lset LevelSet.union ls (levels init) /\ + constraints g' =_ucset UnivConstraintSet.union (init_constraints_of_levels ls) (constraints init) + end. + Proof. + unfold declare_levels_aux. eapply LevelSetProp.fold_rec. - - move=> s' he. lsets. - - move=> x a s' s'' hin hnin hadd heq. - apply LevelSetProp.Add_Equal in hadd. - destruct LoopCheck.declare_level eqn:decl. - * apply LoopCheck.declare_level_levels in decl as [hnin' ->]. - rewrite hadd heq. lsets. - * apply LoopCheck.declare_level_None in decl. - rewrite heq hadd. - rewrite heq LevelSet.union_spec in decl. - destruct decl => //. lsets. + - move=> s' he. destruct og => //. exists u. split => //. + split. lsets. split => //. lsets. + intros c. rsets. split; auto. intros []; auto. + apply init_constraints_of_levels_spec_inv in H as [l [c' [he' _]]]; lsets. + now left. + - move=> x a s' s'' hin hnin hadd. + destruct a. + destruct (declare_level_aux) eqn: hd. + move/declare_level_aux_Some: hd. + + move=> [] g' [] [=] <- [] hnin' [hadd' [c [eqc hcstr']]]. + move=> [init [eqog [inv' [inv'' invc]]]]. + exists init. split => //. split. + * move=> l /hadd []. + { intros ->. intros hinl. lsets. } + { intros inls'. now apply inv'. } + * rewrite hadd' inv''. + apply LevelSetProp.Add_Equal in hadd. + split => //. rewrite hadd. lsets. + rewrite hcstr' invc. + rewrite hadd // init_constraints_of_levels_add; tea. ucsets. + + move/declare_level_aux_spec: hd. + intros [] => //. destruct H as [g' [[=] hin']]. subst g'. + move=> [init [-> [inv [invl invc]]]]. right. cbn. + rewrite invl in hin'. rsets. exists x. split => //. apply hadd. now left. + + cbn. move=> [] h; [left|right]; auto. + destruct h as [l [inls' cb]]. exists l. split => //. + apply hadd. now right. + Qed. + + Lemma declare_levels_spec g ls : + match declare_levels g ls with + | None => exists l, LevelSet.In l ls /\ LevelSet.In l (UnivLoopChecking.levels g) + | Some g' => [/\ (forall l, LevelSet.In l ls -> ~ LevelSet.In l (levels g)), + levels g' =_lset LevelSet.union ls (levels g) & + constraints g' =_ucset UnivConstraintSet.union (init_constraints_of_levels ls) (constraints g)] + end. + Proof. + have hs := declare_levels_aux_spec (Some g) ls. + unfold declare_levels. + destruct (declare_levels_aux (Some g) ls) => //. + destruct hs as [init [[=] hl]]. now subst g. + destruct hs => //. Qed. (* Lemma declare_levels_aux_clauses m l : @@ -729,24 +1288,6 @@ End ZUnivConstraint. now rewrite hd. Qed. *) - (* We ignore errors here, which can happen only if the levels are already declared *) - (* Program Definition declare_levels (m : univ_model) (l : LevelSet.t) := - {| UnivLoopChecking.model := declare_levels_aux m.(UnivLoopChecking.model) l; - constraints := m.(constraints); |}. - Next Obligation. - Proof. - intros m l c. - rewrite [LoopCheck.Impl.Abstract.clauses _]declare_levels_aux_clauses => hin. - move: (repr_constraints m c hin) => h. - etransitivity; tea. reflexivity. - Qed. - Next Obligation. - move=> m l cl. - rewrite [LoopCheck.Impl.Abstract.clauses _]declare_levels_aux_clauses => hin. - now exact: repr_constraints_inv m cl hin. - Qed. *) - - Definition to_valuation (v : Level.t -> nat) : Universes.valuation := {| valuation_mono := fun s => Pos.of_nat (v (Level.level s)); valuation_poly := fun i => v (Level.lvar i); @@ -756,7 +1297,6 @@ End ZUnivConstraint. let add_val l := LevelMap.add l (val v l) in LevelSet.fold add_val V (LevelMap.empty _). - Import LoopCheck.Impl.CorrectModel (clause_sem, clauses_sem, clauses_sem_union, to_val, to_Z_val). Lemma clauses_sem_subset {S} {SL : Semilattice.Semilattice S Q.t} {v cls cls'} : clauses_sem v cls -> cls' ⊂_clset cls -> clauses_sem v cls'. Proof. @@ -777,48 +1317,21 @@ End ZUnivConstraint. rewrite interp_prems_singleton. move: (he (r, le)) => /fwd. exists le. split => //. now apply LevelExprSet.singleton_spec. - cbn. lia. - - intros le x ih hnin ih'. - rewrite interp_prems_add. - forward ih. intros x0 [x1 [hin ->]]. - move: (ih' (r, x1)) => /fwd. exists x1. split => //. apply LevelExprSet.add_spec. now right. - auto. - move: (ih' (r, le)) => /fwd. exists le. split => //. apply LevelExprSet.add_spec. now left. - cbn. cbn in ih. lia. - Qed. - - Lemma to_atoms_singleton l k : to_atoms (Universe.singleton (l, k)) = NES.singleton (l, Z.of_nat k). - Proof. - apply NES.equal_exprsets. - rewrite /to_atoms //=. - Qed. - - Lemma to_atoms_add le u : to_atoms (Universe.add le u) = NES.add (to_atom le) (to_atoms u). - Proof. apply NES.equal_exprsets => //=. - move=> [l k]. - rewrite LevelExprSet.add_spec. - split. - - move/to_levelexprzset_spec_2 => []. - rewrite Universes.LevelExprSet.add_spec => -[<-|hin]. - * move=> pos. - left. cbn. lia_f_equal. - * move=> pos. right. - apply to_levelexprzset_spec_1 in hin. - rewrite Z2Nat.id // in hin. - - move=> [eq|hin]. - destruct le; noconf eq. - * apply to_levelexprzset_spec_1. - rewrite Universes.LevelExprSet.add_spec. - now left. - * apply to_levelexprzset_spec_2 in hin as [hin pos]. - have [k' eq] : exists z, Z.of_nat z = k. exists (Z.to_nat k). - rewrite Z2Nat.id //. subst k. - apply to_levelexprzset_spec_1. - rewrite Nat2Z.id in hin. - rewrite Universes.LevelExprSet.add_spec. now right. + cbn. lia. + - intros le x ih hnin ih'. + rewrite interp_prems_add. + forward ih. intros x0 [x1 [hin ->]]. + move: (ih' (r, x1)) => /fwd. exists x1. split => //. apply LevelExprSet.add_spec. now right. + auto. + move: (ih' (r, le)) => /fwd. exists le. split => //. apply LevelExprSet.add_spec. now left. + cbn. cbn in ih. lia. Qed. + Import LoopCheck (valuation). + Import LoopCheck.Impl.CorrectModel (clauses_sem, clause_sem). + (* Import LoopCheck.Impl.Abstract. *) + Definition wf_valuation V v := forall l, LevelSet.In l V -> @@ -1017,10 +1530,6 @@ End ZUnivConstraint. Qed. (* Lemma in_to_clauses_elem {l k a} : *) - Definition check (m : univ_model) (c : UnivConstraint.t) : bool := - LoopCheck.check m.(UnivLoopChecking.model) (to_constraint c). - Derive Signature for satisfies0. - Lemma wf_valuation_of_valuation V v : wf_valuation V (to_val (of_valuation V v)). Proof. move=> l hin. @@ -1122,206 +1631,12 @@ End ZUnivConstraint. - intros x y. rewrite interp_prems_union; cbn. lia. Qed. - Definition relation_of_constraint (c : ZUnivConstraint.t) := - let '(l, d, r) := c in - match d with - | ConstraintType.Le => ((l ∪ r)%nes, r) - | ConstraintType.Eq => (l, r) - end. - - Definition Zuniv_constraint_levels (c : ZUnivConstraint.t) := - let '(l, d, r) := c in - LevelSet.union (NES.levels l) (NES.levels r). - - Definition relations_of_constraints c := - ZUnivConstraintSet.fold (fun c acc => relation_of_constraint c :: acc) c []. - - Lemma relations_of_constraints_spec {r cstrs} : List.In r (relations_of_constraints cstrs) <-> - exists cl, ZUnivConstraintSet.In cl cstrs /\ r = relation_of_constraint cl. - Proof. - rewrite /relations_of_constraints. - eapply ZUnivConstraintSetProp.fold_rec. - - move=> s' he; split => //. - intros [cl []]. now apply he in H. - - move=> x a s' s'' hni hnin hadd. - split. - { cbn. move=> [] h. - * exists x. split => //. apply hadd. now left. - * apply H in h as [cl []]; eexists; split; tea. apply hadd. now right. } - { move=> [] cl [] /hadd[]. - * intros -> ->. now left. - * intros hin heq. right; apply H. exists cl; split => //. } - Qed. - - Definition levels_of_z_constraints c := - ZUnivConstraintSet.fold (fun c acc => LevelSet.union (Zuniv_constraint_levels c) acc) c LevelSet.empty. - - Import ISL. - - Lemma equiv_L_rels_eq {l r} : - [l ≡ r] ⊫ℒ relations_of_clauses (clauses_of_le l r) ++ relations_of_clauses (clauses_of_le r l). - Proof. - rewrite /clauses_of_eq. split. - - apply app_Forall. - * apply Forall_forall => rel. - have [he he'] := entails_L_relations_of_clauses_le l r. - red in he, he'. - rewrite Forall_forall in he'. move/he'. - intros ent. destruct rel. - eapply entails_L_all_one_trans; tea. - constructor. apply entails_L_eq_le_1, entails_c; repeat constructor. constructor. - * apply Forall_forall => rel. - have [he he'] := entails_L_relations_of_clauses_le r l. - red in he, he'. - rewrite Forall_forall in he'. move/he'. - intros ent. destruct rel. - eapply entails_L_all_one_trans; tea. - constructor. apply entails_L_eq_le_2, entails_c; repeat constructor. constructor. - - constructor; [|constructor]. - apply entails_L_eq_antisym. split. - * have [he he'] := entails_L_relations_of_clauses_le l r. - eapply entails_L_rels_subset. depelim he. tea. - red. intros r' hin. rewrite in_app_iff. now left. - * have [he he'] := entails_L_relations_of_clauses_le r l. - eapply entails_L_rels_subset. depelim he. tea. - red. intros r' hin. rewrite in_app_iff. now right. - Qed. - - Lemma entails_L_relations_of_clauses_eq l r : - relations_of_clauses (l ≡ r) ⊫ℒ [l ≡ r]. - Proof. - split. - - constructor. apply entails_L_relations_of_clauses_eq. constructor. - - apply Forall_forall => rel. - move/relations_of_clauses_spec => [] prems [] concl [] hin ->. - move: hin; rewrite /clauses_of_eq Clauses.union_spec => -[] hin. - * setoid_rewrite equiv_L_rels_eq. - eapply entails_L_rels_subset; revgoals. - { intros rel'. rewrite in_app_iff. left. tea. } - now eapply entails_L_in_cls. - * setoid_rewrite equiv_L_rels_eq. - eapply entails_L_rels_subset; revgoals. - { intros rel'. rewrite in_app_iff. right. tea. } - now eapply entails_L_in_cls. - Qed. - - Lemma relation_of_constraint_of_clause cstr : - relations_of_clauses (LoopCheck.to_clauses cstr) ⊫ℒ [relation_of_constraint cstr]. - Proof. - destruct cstr as [[l []] r]. cbn. - apply entails_L_relations_of_clauses_le. - apply entails_L_relations_of_clauses_eq. - Qed. - - Lemma of_z_constraints_subset {cstrs cstrs'} : - ZUnivConstraintSet.Subset cstrs cstrs' -> - of_z_constraints cstrs ⊂_clset of_z_constraints cstrs'. - Proof. - move=> hsub cl /of_z_constraints_spec => -[] cstr [] hin incl. - rewrite of_z_constraints_spec. exists cstr. split => //. now apply hsub. - Qed. - - Lemma of_z_constraints_add x s : - of_z_constraints (ZUnivConstraintSet.add x s) =_clset Clauses.union (LoopCheck.to_clauses x) (of_z_constraints s). - Proof. - move=> cl; split. - - move/of_z_constraints_spec => -[] cstr [] hin incl. - rewrite Clauses.union_spec. rewrite ZUnivConstraintSet.add_spec in hin. - move: hin => [<-|]. now left. - move=> ins. right. rewrite of_z_constraints_spec. exists cstr; split => //; now right. - - rewrite Clauses.union_spec => -[]; destruct x as [[l []] r]. - * move/LoopCheck.to_clauses_spec => [] k [hin] ->. - rewrite of_z_constraints_spec. eexists; split => //. - rewrite ZUnivConstraintSet.add_spec; left; trea. - cbn. now eapply in_clause_of_le. - * intros hcl; rewrite of_z_constraints_spec //. eexists; split. - rewrite ZUnivConstraintSet.add_spec; left; trea. exact hcl. - * rewrite of_z_constraints_spec => -[] cstr [] hin heq. - rewrite of_z_constraints_spec. exists cstr. split => //. - rewrite ZUnivConstraintSet.add_spec; now right. - * rewrite of_z_constraints_spec => -[] cstr [] hin heq. - rewrite of_z_constraints_spec. exists cstr. split => //. - rewrite ZUnivConstraintSet.add_spec; now right. - Qed. - - Lemma relations_of_clauses_constraints_add {x s} : - (relation_of_constraint x :: relations_of_clauses (of_z_constraints s)) ⊫ℒ - (relations_of_clauses (of_z_constraints (ZUnivConstraintSet.add x s))). - Proof. - rewrite of_z_constraints_add relations_of_clauses_union. - eapply (entails_L_all_union (x := [_])). - 2:{ reflexivity. } - now rewrite relation_of_constraint_of_clause. - Qed. - - Lemma rels_of_z_constraints_spec {cstrs} : - relations_of_clauses (of_z_constraints cstrs) ⊫ℒ relations_of_constraints cstrs. - Proof. - rewrite /relations_of_constraints. - have he := ZUnivConstraintSetProp.fold_rec - (P := fun s f => relations_of_clauses (of_z_constraints s) ⊫ℒ f). apply: he. - - split. constructor. red. apply Forall_forall => [] l r. - eapply relations_of_clauses_spec in r as [prems [concl [hin heq]]]. subst l. - eapply of_z_constraints_spec in hin as [cstr [hin ]]. now apply H in hin. - - move=> x a s' s'' hin hnin hadd hr. - rewrite entails_equiv_cons. - split; [|split] => //. - * have hins'' : ZUnivConstraintSet.In x s''. - { apply hadd; now left. } - rewrite -relation_of_constraint_of_clause. - apply entails_L_clauses_subset_all. - move=> cl incl. apply of_z_constraints_spec. now exists x. - * have ha := @entails_L_clauses_subset_all (of_z_constraints s') (of_z_constraints s''). - transitivity (relations_of_clauses (of_z_constraints s')) => //. - apply ha. apply of_z_constraints_subset => ? hin'. apply hadd. now right. - apply hr. - * destruct hr. - transitivity (relation_of_constraint x :: relations_of_clauses (of_z_constraints s')). - apply entails_L_clauses_cons. now apply entails_L_c; constructor. - now eapply (entails_L_all_weaken (w:=[_])). - clear -hadd; intros. - rewrite relations_of_clauses_constraints_add. - eapply entails_L_clauses_subset_all. - eapply of_z_constraints_subset. - apply ZUnivConstraintSetProp.Add_Equal in hadd. now rewrite hadd. - Qed. - - Lemma equiv_constraints_clauses m : - relations_of_constraints (to_z_cstrs (constraints m)) ⊫ℒ - Clauses.relations_of_clauses (LoopCheck.clauses (UnivLoopChecking.model m)). - Proof. - have repr := repr_constraints. - have repr_inv := repr_constraints_inv. - rewrite -rels_of_z_constraints_spec. - rewrite -to_clauses_of_z_constraints. - rewrite (@relations_of_clauses_eq (to_clauses (constraints m)) - (LoopCheck.clauses m)) //. - 2:{ reflexivity. } - intros cl. rewrite UnivLoopChecking.to_clauses_spec. - split. - - move=> [] cstrs [] /repr incl intocl. - apply incl, intocl. - - now move/repr_inv. - Qed. - - (** Lifting interpretation to constraints (on Z). *) - - Section interp. - Import Semilattice. - Context {S : Type} {SL : Semilattice S Z}. - Context (v : Level.t -> S). - Definition interp_z_cstr c := - let '(l, d, r) := c in - match d with - | ConstraintType.Le => interp_prems v l ≤ interp_prems v r - | ConstraintType.Eq => interp_prems v l ≡ interp_prems v r - end%Z. - Definition interp_univ_cstr c := interp_z_cstr (to_constraint c). - Definition interp_univ_cstrs c := UnivConstraintSet.For_all interp_univ_cstr c. + Definition check (m : univ_model) (c : UnivConstraint.t) : bool := + LoopCheck.check m.(UnivLoopChecking.model) (to_constraint c). + Derive Signature for satisfies0. - End interp. Section interp_nat. Import Semilattice. @@ -1397,48 +1712,6 @@ End ZUnivConstraint. by []. Qed. - (** Equivalence of interpretations between constraints and relations derived from them *) - - Lemma interp_univ_cstrs_relations {S} {SL : Semilattice S Z} v cstrs : - interp_univ_cstrs v cstrs <-> - interp_rels v (relations_of_constraints (to_z_cstrs cstrs)). - Proof. - rewrite /interp_univ_cstrs. - split. - - intros hf. red in hf. red. - apply Forall_forall. move=> [l r] /relations_of_constraints_spec [[[l' d] r'] [hin heq]]. - cbn in heq; noconf heq. destruct d; noconf heq. - * eapply to_z_cstrs_spec_2 in hin as [cstr [hin heq]]. - destruct cstr as [[] ?]; noconf heq. specialize (hf _ hin). cbn in hf. - rewrite /interp_rel interp_prems_union; cbn in *. exact hf. - * eapply to_z_cstrs_spec_2 in hin as [cstr [hin heq]]. - destruct cstr as [[] ?]; noconf heq. specialize (hf _ hin). cbn in hf. - exact hf. - - intros hi uc hin. red in hi. rewrite Forall_forall in hi. - move: (hi (relation_of_constraint (to_constraint uc))) => /fwd. - rewrite relations_of_constraints_spec; exists (to_constraint uc); split => //. - now apply to_z_cstrs_spec_1 in hin as [cstrz [hin ->]]. - destruct uc as [[l []] r] => //=. - rewrite interp_prems_union //=. - Qed. - - Lemma interp_cstr_clauses_sem {c} {S} {SL : Semilattice S Q.t} {v : Level.t -> S} : - interp_univ_cstr v c <-> clauses_sem v (LoopCheck.to_clauses (to_constraint c)). - Proof. - rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. - rewrite relation_of_constraint_of_clause. - rewrite /Clauses.ISL.interp_rels Forall_tip. - destruct c as [[l []] r]; cbn => //. - now rewrite interp_prems_union. - Qed. - - Lemma interp_cstrs_clauses_sem {m} {S} {SL : Semilattice S Q.t} {v : Level.t -> S} : - interp_univ_cstrs v (constraints m) <-> clauses_sem v (LoopCheck.clauses m). - Proof. - rewrite interp_univ_cstrs_relations. - rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. - now rewrite -[Clauses.relations_of_clauses _]equiv_constraints_clauses. - Qed. Lemma to_valuation_val V (v : Level.t -> nat) (l : Universes.Level.t) : wf_valuation V v -> diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 3d14f836e..6d5f6ccd6 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -965,6 +965,7 @@ Section Univ. -> satisfies0 v (l, ConstraintType.Le, l') | satisfies0_Eq (l l' : Universe.t) : val v l = val v l' -> satisfies0 v (l, ConstraintType.Eq, l'). + Derive Signature for satisfies0. Definition satisfies v : UnivConstraintSet.t -> Prop := UnivConstraintSet.For_all (satisfies0 v). diff --git a/common/theories/UniversesDec.v b/common/theories/UniversesDec.v index 1f858852e..798783b92 100644 --- a/common/theories/UniversesDec.v +++ b/common/theories/UniversesDec.v @@ -2,7 +2,7 @@ From Stdlib Require Import PArith NArith ZArith Lia. From MetaRocq.Utils Require Import MRList MROption MRUtils. From MetaRocq.Common Require Import uGraph. From MetaRocq.Common Require Import Universes. -Import wGraph. +(* Import wGraph. *) Definition levels_of_cs (cstr : UnivConstraintSet.t) : LevelSet.t := UnivConstraintSet.fold (fun '(l1, _, l2) acc => LevelSet.add l1 (LevelSet.add l2 acc)) cstr (LevelSet.singleton Level.lzero). diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index e6cb552ae..89385de59 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -1,679 +1,13 @@ (* Distributed under the terms of the MIT license. *) From Stdlib Require Import ssreflect ssrbool OrderedTypeAlt MSetAVL MSetFacts MSetProperties MSetDecide Morphisms. -From MetaRocq.Utils Require Import utils wGraph. -From MetaRocq.Common Require Import config Universes. +From MetaRocq.Utils Require Import utils. +From MetaRocq.Common Require Import config UnivConstraintType Universes UnivLoopChecking. From Equations.Prop Require Import DepElim. From Equations Require Import Equations. Import ConstraintType. -Import MRMonadNotation. - - -Arguments Z.add : simpl nomatch. -Arguments Nat.leb : simpl nomatch. -Arguments Nat.eqb : simpl nomatch. - -Definition Z_of_bool (b : bool) : Z := - match b with - | true => 1 - | false => 0 - end. -Notation "⎩ b ⎭" := (Z_of_bool b). - -(** variable levels are levels which are Level or Var *) -Module VariableLevel. - Inductive t_ := level (_ : string) | lvar (_ : nat). - Definition t := t_. - - Declare Scope var_level. - Delimit Scope var_level with var_level. - - Definition lt : t -> t -> Prop := - fun x y => match x, y with - | level _, lvar _ => True - | level s, level s' => StringOT.lt s s' - | lvar n, lvar n' => n < n' - | lvar _, level _ => False - end. - Global Instance lt_strorder : StrictOrder lt. - split. - - intros [s|n] H; cbn in H. - now eapply irreflexivity in H. - lia. - - intros [s1|n1] [s2|n2] [s3|n3]; cbn; intuition. - eapply transitivity; eassumption. - Qed. - Definition lt_trans : Transitive lt := _. - - Definition lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt. - intros x y [] z t []; reflexivity. - Qed. - Definition compare : t -> t -> comparison := - fun x y => match x, y with - | level _, lvar _ => Datatypes.Lt - | level s, level s' => string_compare s s' - | lvar n, lvar n' => Nat.compare n n' - | lvar _, level _ => Datatypes.Gt - end. - Infix "?=" := compare : var_level. - Definition compare_spec : - forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y). - intros [s|n] [s'|n']; cbn; try now constructor. - - eapply CompareSpec_Proper. 2-4: reflexivity. - 2: apply CompareSpec_string. - split; congruence. - - eapply CompareSpec_Proper. 2-4: reflexivity. - 2: apply PeanoNat.Nat.compare_spec. - split; congruence. - Qed. - Lemma compare_refl (x : t) : compare x x = Datatypes.Eq. - Proof. - destruct x => /= //. - rewrite string_compare_eq //. - now rewrite Nat.compare_refl. - Qed. - - Definition eq_dec : forall x y : t, {x = y} + {x <> y}. - intros [s|n] [s'|n']; try now constructor. - destruct (Classes.eq_dec s s'); [left|right]; congruence. - destruct (PeanoNat.Nat.eq_dec n n'); [left|right]; congruence. - Defined. - - Lemma compare_eq : forall x y : t, compare x y = Datatypes.Eq -> x = y. - Proof. - intros x y. destruct (compare_spec x y) => //. - Qed. - - Lemma compare_sym : forall x y : t, (compare y x) = CompOpp (compare x y). - Proof. - induction x; destruct y; simpl; auto. - apply StringOT.compare_sym. - apply PeanoNat.Nat.compare_antisym. - Qed. - - Lemma compare_trans : - forall c (x y z : t), (x?=y)%var_level = c -> (y?=z)%var_level = c -> (x?=z)%var_level = c. - Proof. - intros c x y z. - destruct (compare_spec x y) => <-; subst. - destruct (compare_spec y z); auto. - destruct (compare_spec y z); auto; try congruence. - destruct (compare_spec x z); auto; try congruence. - subst. exfalso. eapply irreflexivity. etransitivity; [exact H|exact H0]. - exfalso. eapply irreflexivity. etransitivity; [exact H|]. - eapply transitivity; [exact H0|exact H1]. - destruct (compare_spec y z); auto; try congruence. - destruct (compare_spec x z); auto; try congruence. - subst. exfalso. eapply irreflexivity. etransitivity; [exact H|exact H0]. - exfalso. eapply irreflexivity. etransitivity; [exact H|]. - eapply transitivity; [exact H1|exact H0]. - Qed. - - Definition to_noprop (l : t) : Level.t := - match l with - | level s => Level.level s - | lvar n => Level.lvar n - end. - - Definition to_level (l : t) : Level.t := to_noprop l. - - Global Instance Evaluable : Evaluable t - := fun v l => match l with - | level s => Pos.to_nat (v.(valuation_mono) s) - | lvar x => (v.(valuation_poly) x) - end. -End VariableLevel. - -Module VariableLevelOT := OrderedType_from_Alt VariableLevel. - -Coercion VariableLevel.to_noprop : VariableLevel.t >-> Level.t. - -Module GoodConstraint. - Inductive t_ := - (* l + z <= l' *) - | gc_le : VariableLevel.t -> Z -> VariableLevel.t -> t_ - (* Set + k < Level n *) - | gc_lt_set_level : nat -> string -> t_ - (* Set + k <= Var n *) - | gc_le_set_var : nat -> nat -> t_ - (* Level n <= Set + k *) - | gc_le_level_set : string -> nat -> t_ - (* Var n <= Set + k *) - | gc_le_var_set : nat -> nat -> t_. - Derive NoConfusion for t_. - Definition t : Set := t_. - Definition eq : t -> t -> Prop := Logic.eq. - Definition eq_refl := @eq_refl t. - Definition eq_sym := @eq_sym t. - Definition eq_trans := @eq_trans t. - - Definition eq_equiv : RelationClasses.Equivalence eq := _. - Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. - unfold eq. - decide equality. all: try apply VariableLevel.eq_dec. - apply Z.eq_dec. all:apply Classes.eq_dec || apply Peano_dec.eq_nat_dec. - Defined. - - Reserved Notation "x - compare_cont (VariableLevel.compare u u') (compare_cont (Z.compare n n') (VariableLevel.compare v v')) - | _, gc_le _ _ _ => Datatypes.Lt - | gc_le _ _ _, _ => Gt - | gc_lt_set_level n s, gc_lt_set_level n' s' => - compare_cont (Nat.compare n n') (string_compare s s') - | _, gc_lt_set_level _ _ => Datatypes.Lt - | gc_lt_set_level _ _, _ => Gt - | gc_le_set_var n s, gc_le_set_var n' s' => - compare_cont (Nat.compare n n') (Nat.compare s s') - | _, gc_le_set_var _ _ => Datatypes.Lt - | gc_le_set_var _ _, _ => Datatypes.Gt - | gc_le_level_set s n, gc_le_level_set s' n' => - compare_cont (Nat.compare n n') (string_compare s s') - | _, gc_le_level_set _ _ => Datatypes.Lt - | gc_le_level_set _ _, _ => Datatypes.Gt - | gc_le_var_set n k, gc_le_var_set n' k' => - compare_cont (Nat.compare n n') (Nat.compare k k') - end. - Infix "?=" := compare. - - Lemma compare_sym (a b : t): - compare b a = CompOpp (compare a b). - Proof. - revert b. destruct a, b; try easy; cbn; - rewrite !compare_cont_CompOpp -?VariableLevel.compare_sym ?Zcompare_antisym -?PeanoNat.Nat.compare_antisym - -?StringOT.compare_sym //. - Qed. - - - Lemma nat_compare_trans : forall c (x y z : nat), (x?=y)%nat = c -> (y?=z)%nat = c -> (x?=z)%nat = c. - Proof. - intros c x y z. - destruct (Nat.compare_spec x y); subst => // <-; - destruct (Nat.compare_spec y z); subst => //; - destruct (Nat.compare_spec x z); subst => //; try lia. - Qed. - - Lemma Z_compare_trans : forall c (x y z : Z), (x?=y)%Z = c -> (y?=z)%Z = c -> (x?=z)%Z = c. - Proof. - intros c x y z. - destruct (Z.compare_spec x y); subst => // <-; - destruct (Z.compare_spec y z); subst => //; - destruct (Z.compare_spec x z); subst => //; try lia. - Qed. - - Lemma nat_compare_eq : forall (x y : nat), (x?=y)%nat = Datatypes.Eq -> x = y. - Proof. - intros x y. - destruct (Nat.compare_spec x y) => //. - Qed. - - Lemma compare_trans : forall c (x y z : t), (x?=y) = c -> (y?=z) = c -> (x?=z) = c. - Proof. - intros c x y z. - destruct x, y, z; cbn; try repeat apply compare_cont_trans; eauto using VariableLevel.compare_trans, VariableLevel.compare_eq; - try congruence. - all:eauto using StringOT.compare_trans, nat_compare_trans, nat_compare_eq. - intros. eapply compare_cont_trans; tea; - eauto using VariableLevel.compare_trans, VariableLevel.compare_eq, Z.compare_eq, Z_compare_trans. - Qed. - - Lemma compare_eq (x y : t) : x ?= y = Datatypes.Eq -> x = y. - Proof. - destruct x, y; cbn => //. - destruct (VariableLevel.compare t0 t2) eqn:e => /= //. - apply VariableLevel.compare_eq in e. subst. cbn. - destruct (Z.compare z z0) eqn:e' => /= //. - apply Z.compare_eq in e'; subst. - intros H; apply VariableLevel.compare_eq in H; subst. reflexivity. - destruct (Nat.compare_spec n n0) => /= //; subst. - rewrite StringOT.compare_eq => -> //. - destruct (Nat.compare_spec n n1) => /= //; subst. - destruct (Nat.compare_spec n0 n2) => /= //; subst => //. - destruct (Nat.compare_spec n n0) => /= //; subst. - rewrite (StringOT.compare_eq) => -> //. - destruct (Nat.compare_spec n n1) => /= //; subst. - destruct (Nat.compare_spec n0 n2) => /= //; subst => //. - Qed. - - Lemma compare_refl (x : t) : x ?= x = Datatypes.Eq. - Proof. - destruct x => /= //; - rewrite ?VariableLevel.compare_refl /= ?Z.compare_refl /= ?Nat.compare_refl ?string_compare_eq //. - Qed. - - Definition lt (x y : t) := (x ?= y = Datatypes.Lt). - Lemma lt_trans (x y z : t) : lt x y -> lt y z -> lt x z. - Proof. apply compare_trans. Qed. - Lemma lt_not_eq (x y : t) : lt x y -> ~ eq x y. - Proof. - intros lt eq. red in eq. subst x. - red in lt. rewrite compare_refl in lt => //. - Qed. - - Lemma lt_strorder : StrictOrder lt. - Proof. - split. - - intros x hlt. apply lt_not_eq in hlt. now apply hlt. - - red. eapply lt_trans. - Qed. - Lemma lt_compat : Proper (eq ==> eq ==> iff) lt. - Proof. - intros x y ? ? ? ?. now rewrite H H0. - Qed. - - Lemma compare_spec : forall x y : t, CompSpec eq lt x y (compare x y). - Proof. - intros x y. - destruct (x ?= y) eqn:e; constructor. - - now eapply compare_eq in e. - - now red. - - red. rewrite compare_sym e //. - Qed. - - Definition satisfies v (gc : GoodConstraint.t) : bool := - match gc with - | gc_le l z l' => (Z.of_nat (val v l) <=? Z.of_nat (val v l') - z)%Z - | gc_lt_set_level k l => k k <=? v.(valuation_poly) l - | gc_le_level_set l k => Pos.to_nat (v.(valuation_mono) l) <=? k - | gc_le_var_set l k => v.(valuation_poly) l <=? k - end. - -End GoodConstraint. - -Notation gc_satisfies0 := GoodConstraint.satisfies. - -Module GoodConstraintSet := Make GoodConstraint. -Module GoodConstraintSetFact := WFactsOn GoodConstraint GoodUnivConstraintSet. -Module GoodConstraintSetProp := WPropertiesOn GoodConstraint GoodUnivConstraintSet. -Module GoodConstraintSetDecide := WDecide (GoodConstraintSet). -Module GCS := GoodUnivConstraintSet. -Ltac gcsets := GoodConstraintSetDecide.fsetdec. - -Definition gcs_equal x y : Prop := - LevelSet.Equal x.1 y.1 /\ GoodUnivConstraintSet.Equal x.2 y.2. - -Infix "=_gcs" := gcs_equal (at level 200). -Notation "(=_gcs)" := gcs_equal (at level 0). - -Global Instance proper_pair_levels_gcs : Proper ((=_lset) ==> GoodUnivConstraintSet.Equal ==> (=_gcs)) (@pair LevelSet.t GoodUnivConstraintSet.t). -Proof. - intros l l' eq gcs gcs' eq'. - split; cbn; auto. -Qed. - -Global Instance GCS_For_all_Proper f : Proper (GCS.eq ==> iff) (GCS.For_all f). -Proof. - move=> s s' eq; split; move=> h x hx; apply h; by rewrite eq + rewrite <- eq. -Qed. - -Definition GoodConstraintSet_pair x y - := GoodUnivConstraintSet.add y (GoodUnivConstraintSet.singleton x). - -Lemma GoodConstraintSet_pair_In x y z - : GoodUnivConstraintSet.In x (GoodConstraintSet_pair y z) - -> x = y \/ x = z. -Proof. - intro H. apply GoodConstraintSetFact.add_iff in H. - destruct H; [intuition|]. - apply GoodConstraintSetFact.singleton_1 in H. intuition. -Qed. - -Lemma GCS_pair_spec x y z : - GCS.In x (GoodConstraintSet_pair y z) <-> x = y \/ x = z. -Proof. - split; first apply: GoodConstraintSet_pair_In. - move=> [->|->]; apply/GCS.add_spec; by [right; apply/GCS.singleton_spec| left]. -Qed. - -Definition gc_satisfies v : GoodUnivConstraintSet.t -> bool := - GoodUnivConstraintSet.for_all (gc_satisfies0 v). - -Arguments GoodUnivConstraintSet.for_all : simpl never. - -Definition gc_consistent ctrs : Prop := exists v, gc_satisfies v ctrs. - -Lemma gc_satisfies_pair v gc1 gc2 : - (gc_satisfies0 v gc1 /\ gc_satisfies0 v gc2) <-> - gc_satisfies v (GoodConstraintSet_pair gc1 gc2). -Proof. - unfold gc_satisfies, GoodConstraintSet_pair. - rewrite [is_true (GoodUnivConstraintSet.for_all _ _)]GoodUnivConstraintSet.for_all_spec. - split. - - intros [sat1 sat2] x. - rewrite GoodUnivConstraintSet.add_spec. move=> [->|] //. - rewrite GoodUnivConstraintSet.singleton_spec => -> //. - - intros ha. split; apply ha; - rewrite GoodUnivConstraintSet.add_spec; - rewrite GoodUnivConstraintSet.singleton_spec; auto. -Qed. - -Section GcOfConstraint. - Import VariableLevel GoodConstraint. - - (* None -> not satisfiable *) - (* Some empty -> useless *) - (* else: singleton or two elements set (l = l' -> {l<=l', l'<=l}) *) - Definition gc_of_constraint `{checker_flags} (uc : LevelConstraint.t) - : option GoodUnivConstraintSet.t - := let empty := Some GoodUnivConstraintSet.empty in - let singleton := fun x => Some (GoodUnivConstraintSet.singleton x) in - let pair := fun x y => Some (GoodConstraintSet_pair x y) in - match uc with - (* Set _ _ *) - | (Level.lzero, Le z, r) => - match Z.compare z 0 with - | Datatypes.Eq => empty - | Datatypes.Lt => (* Set <= l + n *) empty - | Datatypes.Gt => (* Set + n <= l *) - match r with - | Level.lzero => None - | Level.level s => singleton (gc_lt_set_level (Z.to_nat (z - 1)) s) - | Level.lvar n => singleton (gc_le_set_var (Z.to_nat z) n) - end - end - | (Level.lzero, Eq, Level.lzero) => empty - | (Level.lzero, Eq, Level.level _) => None - | (Level.lzero, Eq, Level.lvar n) => singleton (gc_le_var_set n 0%nat) - - (* Level _ _ *) - | (Level.level l, Le z, Level.lzero) => - (* l - n <= Set <-> l <= Set + n *) - if (z <=? 0)%Z then singleton (gc_le_level_set l (Z.to_nat (Z.abs z))) - else None - - | (Level.level l, Le z, Level.level l') - => singleton (gc_le (level l) z (level l')) - | (Level.level l, Le z, Level.lvar n) => singleton (gc_le (level l) z (lvar n)) - | (Level.level _, Eq, Level.lzero) => None - | (Level.level l, Eq, Level.level l') - => pair (gc_le (level l) 0 (level l')) (gc_le (level l') 0 (level l)) - | (Level.level l, Eq, Level.lvar n) - => pair (gc_le (level l) 0 (lvar n)) (gc_le (lvar n) 0 (level l)) - - (* Var _ _ *) - | (Level.lvar n, Le z, Level.lzero) => - (* l - n <= Set <-> l <= Set + n *) - if (z <=? 0)%Z then singleton (gc_le_var_set n (Z.to_nat (Z.abs z))) - else None - - | (Level.lvar n, Le z, Level.level l) => singleton (gc_le (lvar n) z (level l)) - | (Level.lvar n, Le z, Level.lvar n') => singleton (gc_le (lvar n) z (lvar n')) - | (Level.lvar n, Eq, Level.lzero) => singleton (gc_le_var_set n 0) - | (Level.lvar n, Eq, Level.level l) - => pair (gc_le (lvar n) 0%Z (level l)) (gc_le (level l) 0%Z (lvar n)) - - | (Level.lvar n, Eq, Level.lvar n') - => pair (gc_le (lvar n) 0 (lvar n')) (gc_le (lvar n') 0 (lvar n)) - end. -End GcOfConstraint. - -Section GC. - -Context `{cf : checker_flags}. - -Lemma gc_satisfies_singleton v c : - gc_satisfies0 v c <-> - gc_satisfies v (GoodUnivConstraintSet.singleton c). -Proof using Type. - split. - - intros H; unfold gc_satisfies. - eapply GoodUnivConstraintSet.for_all_spec; auto. proper. - intros x xin. eapply GoodUnivConstraintSet.singleton_spec in xin. - now subst. - - unfold gc_satisfies. - intros gc. - eapply GoodUnivConstraintSet.for_all_spec in gc; auto. 2:proper. - specialize (gc c). - rewrite -> GoodUnivConstraintSet.singleton_spec in gc. - now apply gc. -Qed. - -Lemma gc_of_constraint_spec v uc : - satisfies0 v uc <-> on_Some (gc_satisfies v) (gc_of_constraint uc). -Proof using Type. - split. - - destruct 1; destruct l, l'; try constructor. - all:unfold gc_of_constraint. - all: cbn -[GoodConstraintSet_pair] in *. - all: cbn -[GoodConstraintSet_pair]; try reflexivity. - all: rewrite ?if_true_false; repeat toProp ; try lia. - all: try solve [destruct (Z.compare_spec z 0); simpl; try constructor; lia]. - destruct (Z.compare_spec z 0); simpl; try constructor; try lia. - apply gc_satisfies_singleton. - simpl. apply Nat.ltb_lt. lia. - all:try (destruct (Z.compare_spec z 0); simpl; try constructor; try lia; - apply gc_satisfies_singleton; simpl; try (apply Nat.ltb_lt||apply Nat.leb_le); lia). - all:try (destruct (Z.leb_spec z 0); simpl; try constructor; try lia; - apply gc_satisfies_singleton; simpl; apply Nat.leb_le; lia). - all: try (apply gc_satisfies_pair; split; cbn; toProp; try lia). - all: (apply gc_satisfies_singleton; cbn; toProp; lia). - - destruct uc as [[[] []] []]; intro H; constructor. - all: cbn -[GoodConstraintSet_pair] in *; try contradiction. - all: rewrite -> ?if_true_false in *; cbn -[GoodConstraintSet_pair] in *; - try contradiction; repeat toProp; try lia. - all:try (destruct (Z.compare_spec z 0); simpl in H; auto; try lia; - apply gc_satisfies_singleton in H; simpl in H; - (apply Nat.ltb_lt in H || apply Nat.leb_le in H); - try lia). - all:try (destruct (Z.leb_spec z 0); simpl in H; auto; try lia; - apply gc_satisfies_singleton in H; simpl in H; - (apply Nat.ltb_lt in H || apply Nat.leb_le in H); - try lia). - all:(try apply gc_satisfies_singleton in H; cbn in H; try toProp H); try lia. - all: apply gc_satisfies_pair in H; destruct H as [H1 H2]; cbn in *; - repeat toProp; try lia. -Qed. - -Definition add_gc_of_constraint uc (S : option GoodUnivConstraintSet.t) - := S1 <- S ;; - S2 <- gc_of_constraint uc ;; - ret (GoodUnivConstraintSet.union S1 S2). - -Definition gc_of_constraints (ctrs : UnivConstraintSet.t) : option GoodUnivConstraintSet.t - := UnivConstraintSet.fold add_gc_of_constraint - ctrs (Some GoodUnivConstraintSet.empty). - - -Lemma gc_of_constraints_spec v ctrs : - satisfies v ctrs <-> on_Some (gc_satisfies v) (gc_of_constraints ctrs). -Proof using Type. - unfold gc_satisfies, satisfies, UnivConstraintSet.For_all, gc_of_constraints. - set (S := GoodUnivConstraintSet.empty). - rewrite UnivConstraintSet.fold_spec. - etransitivity. eapply iff_forall. - intro; eapply imp_iff_compat_r. eapply ConstraintSetFact.elements_iff. - set (l := UnivConstraintSet.elements ctrs). simpl. - transitivity ((forall uc, InA Logic.eq uc l -> satisfies0 v uc) /\ - (forall gc, GoodUnivConstraintSet.In gc S -> gc_satisfies0 v gc)). { - intuition. inversion H0. } - clearbody S; revert S; induction l; intro S; cbn. - - split. - + intro. apply GoodConstraintSetFact.for_all_1. - intros x y []; reflexivity. - intro; apply H. - + intros HS. split. intros ux H; inversion H. - apply GoodConstraintSetFact.for_all_2. - intros x y []; reflexivity. - assumption. - - split. - + intros [H1 H2]. - assert (HH : on_Some (gc_satisfies v) (gc_of_constraint a)). { - apply gc_of_constraint_spec, H1. now constructor. } - case_eq (gc_of_constraint a); [|intro e; rewrite e in HH; contradiction]. - intros X HX; rewrite HX in HH; cbn in HH. - apply IHl. split. - * intros uc H0. apply H1. now apply InA_cons_tl. - * intros gc H0. apply GoodConstraintSetFact.union_1 in H0. - induction H0. intuition. - apply GoodConstraintSetFact.for_all_2 in HH. - apply HH. assumption. - intros x y []; reflexivity. - + intros HH. - case_eq (gc_of_constraint a). - * intros X HX; rewrite HX in HH; cbn in HH. - destruct (proj2 (IHl _) HH) as [IH1 IH2]. clear IHl HH. - split. intuition. apply InA_cons in H. induction H. - subst. apply gc_of_constraint_spec. rewrite HX. - cbn. apply GoodConstraintSetFact.for_all_1. - intros x y []; reflexivity. - intros gc Hgc. apply IH2. - now apply GoodConstraintSetFact.union_3. - firstorder. - intros gc Hgc. apply IH2. - now apply GoodConstraintSetFact.union_2. - * intro HX; rewrite HX in HH. apply False_rect. revert HH; clear. - induction l. inversion 1. - assumption. -Qed. - -Lemma gc_consistent_iff ctrs : - consistent ctrs <-> on_Some gc_consistent (gc_of_constraints ctrs). -Proof using Type. - split. - - intros [v H]. apply gc_of_constraints_spec in H. - destruct (gc_of_constraints ctrs); cbn in *. - exists v. assumption. contradiction. - - case_eq (gc_of_constraints ctrs); cbn; [|contradiction]. - intros ctrs' e HC. destruct HC as [v Hv]. - exists v. apply gc_of_constraints_spec. now rewrite e; cbn. -Qed. - -Local Open Scope univ_scope. - -Definition gc_leq0_universe_n n ctrs (u u' : Universe.t) := - forall v, gc_satisfies v ctrs -> (Z.of_nat (val v u) <= Z.of_nat (val v u') - n)%Z. - -Definition gc_leq_universe_n n ctrs (u u' : Universe.t) := - if check_univs then gc_leq0_universe_n n ctrs u u' else True. - -Definition gc_eq0_universe φ (u u' : Universe.t) := - forall v, gc_satisfies v φ -> val v u = val v u'. - -Definition gc_eq_universe φ (u u' : Universe.t) := - if check_univs then gc_eq0_universe φ u u' else True. - -Definition gc_leq0_universe := gc_leq0_universe_n 0. -Definition gc_lt0_universe := gc_leq0_universe_n 1. -Definition gc_leq_universe := gc_leq_universe_n 0. -Definition gc_lt_universe := gc_leq_universe_n 1. - -Ltac unfold_univ_rel0 := - unfold eq0_universe, leq0_universe_n, - gc_eq0_universe, gc_leq0_universe, gc_lt0_universe, gc_leq0_universe_n in *; - intros v Hv; cbnr. - -Ltac unfold_univ_rel := - unfold eq_universe, leq_universe, lt_universe, leq_universe_n, - gc_eq_universe, gc_leq_universe, gc_lt_universe, gc_leq_universe_n in *; - destruct check_univs; [| trivial]. - -Lemma gc_leq0_universe_n_iff (n: Z) ctrs u u' : - leq0_universe_n n ctrs u u' - <-> on_Some_or_None (fun ctrs => gc_leq0_universe_n n ctrs u u') - (gc_of_constraints ctrs). -Proof. - split. - - intro H. case_eq (gc_of_constraints ctrs). - + intros ctrs' e. cbn. - unfold_univ_rel0. - apply H. apply gc_of_constraints_spec. - rewrite e. assumption. - + intro; exact I. - - case_eq (gc_of_constraints ctrs); cbn. - + intros ctrs' e H. - unfold_univ_rel0. apply H. - apply gc_of_constraints_spec in Hv. - rewrite e in Hv; assumption. - + intros e _. unfold_univ_rel0. - apply gc_of_constraints_spec in Hv. - rewrite e in Hv; contradiction. -Defined. - -Lemma gc_leq0_universe_iff ctrs u u': - leq0_universe_n 0 ctrs u u' - <-> on_Some_or_None (fun ctrs => gc_leq0_universe_n 0 ctrs u u') - (gc_of_constraints ctrs). -Proof using Type. - apply gc_leq0_universe_n_iff. -Qed. - - -Lemma gc_eq0_universe_iff ctrs u u' : - eq0_universe ctrs u u' - <-> on_Some_or_None (fun ctrs => gc_eq0_universe ctrs u u') - (gc_of_constraints ctrs). -Proof. - split. - - intro H. case_eq (gc_of_constraints ctrs). - + intros ctrs' e. cbn. - unfold_univ_rel0. apply H. apply gc_of_constraints_spec. - rewrite e. assumption. - + intro; exact I. - - case_eq (gc_of_constraints ctrs); cbn. - + intros ctrs' e H. - unfold_univ_rel0. apply H. - apply gc_of_constraints_spec in Hv. - rewrite e in Hv; assumption. - + intros e _. unfold_univ_rel0. - apply gc_of_constraints_spec in Hv. - rewrite e in Hv; contradiction. -Defined. - -Lemma gc_leq_universe_n_iff n ctrs u u' : - leq_universe_n n ctrs u u' - <-> on_Some_or_None (fun ctrs => gc_leq_universe_n n ctrs u u') - (gc_of_constraints ctrs). -Proof using Type. - unfold_univ_rel. - apply gc_leq0_universe_n_iff. - destruct (gc_of_constraints ctrs); reflexivity. -Qed. - -Lemma gc_leq_universe_iff ctrs u u' : - leq_universe ctrs u u' - <-> on_Some_or_None (fun ctrs => gc_leq_universe ctrs u u') - (gc_of_constraints ctrs). -Proof using Type. - unfold_univ_rel. - apply gc_leq0_universe_iff. - destruct (gc_of_constraints ctrs); reflexivity. -Qed. - -Lemma gc_eq_universe_iff ctrs u u' : - eq_universe ctrs u u' - <-> on_Some_or_None (fun ctrs => gc_eq_universe ctrs u u') - (gc_of_constraints ctrs). -Proof using Type. - unfold_univ_rel. - apply gc_eq0_universe_iff. - destruct (gc_of_constraints ctrs); reflexivity. -Qed. - -End GC. - -Module Import wGraph := WeightedGraph Level LevelSet. -Module VSet := LevelSet. -Local Notation lzero := Level.lzero. -(* vtn = variable to noprop *) -Local Notation vtn := VariableLevel.to_noprop. - -Definition universes_graph := t. -Definition init_graph : universes_graph - := (VSet.singleton lzero, EdgeSet.empty, lzero). - -Lemma init_graph_invariants : invariants init_graph. -Proof. - repeat split; cbn in *. - 1-2: inversion H. sets. - apply VSet.singleton_spec in H. subst. - exists (pathOf_refl _ _). simpl. sq. lia. -Defined. - -Definition declared : Level.t -> LevelSet.t -> Prop := LevelSet.In. +Definition universe_model := UnivLoopChecking.univ_model. +Definition init_graph : universe_model := UnivLoopChecking.init_model. Definition uctx_invariants (uctx : ContextSet.t) := UnivConstraintSet.For_all (declared_univ_cstr_levels uctx.1) uctx.2. @@ -681,359 +15,41 @@ Definition uctx_invariants (uctx : ContextSet.t) Definition global_uctx_invariants (uctx : ContextSet.t) := LevelSet.In Level.lzero uctx.1 /\ uctx_invariants uctx. -Definition global_gc_uctx_invariants (uctx : VSet.t * GoodUnivConstraintSet.t) - := VSet.In lzero uctx.1 /\ GoodUnivConstraintSet.For_all (fun gc => match gc with - | GoodConstraint.gc_le l z l' => VSet.In (vtn l) uctx.1 - /\ VSet.In (vtn l') uctx.1 - | GoodConstraint.gc_lt_set_level _ n - | GoodConstraint.gc_le_level_set n _ => VSet.In (Level.level n) uctx.1 - | GoodConstraint.gc_le_var_set n _ - | GoodConstraint.gc_le_set_var _ n => VSet.In (Level.lvar n) uctx.1 - end) uctx.2. - -Definition gc_of_uctx `{checker_flags} (uctx : ContextSet.t) - : option (VSet.t * GoodUnivConstraintSet.t) - := ctrs <- gc_of_constraints uctx.2 ;; - ret (uctx.1, ctrs). - -Lemma gc_of_uctx_of_constraints `{checker_flags} uctx gctx : - gc_of_uctx uctx = Some gctx -> - gc_of_constraints uctx.2 = Some gctx.2. -Proof. - rewrite/gc_of_uctx; case: (gc_of_constraints _)=> //= ? [=] <- //. -Qed. - -Lemma gc_of_constraints_of_uctx `{checker_flags} uctx gcstrs : - gc_of_constraints uctx.2 = Some gcstrs -> - gc_of_uctx uctx = Some (uctx.1, gcstrs). -Proof. rewrite /gc_of_uctx=> -> //=. Qed. - - -Lemma gc_of_constraint_iff `{cf:checker_flags} ctrs0 ctrs gc - (HH : gc_of_constraints ctrs0 = Some ctrs) -: GoodUnivConstraintSet.In gc ctrs - <-> UnivConstraintSet.Exists - (fun e => on_Some (GoodUnivConstraintSet.In gc) (gc_of_constraint e)) ctrs0. -Proof. - unfold gc_of_constraints in HH. rewrite UnivConstraintSet.fold_spec in HH. - transitivity ((exists ctr, In ctr (UnivConstraintSet.elements ctrs0) /\ - on_Some (GoodUnivConstraintSet.In gc) (gc_of_constraint ctr)) - \/ GoodUnivConstraintSet.In gc GoodUnivConstraintSet.empty). - 2:{ split. - - intros [[ctr [H1 H2]]|H]. exists ctr. split. - apply ConstraintSetFact.elements_iff, InA_In_eq; tas. tas. - now apply GoodConstraintSetFact.empty_iff in H. - - intros [ctr H]. left. exists ctr. split. - apply InA_In_eq, ConstraintSetFact.elements_1, H. apply H. } - revert HH; generalize GoodUnivConstraintSet.empty. - induction (UnivConstraintSet.elements ctrs0). - - cbn. intros X HH. apply some_inj in HH; subst. - firstorder. - - intros X HH. simpl in HH. unfold add_gc_of_constraint at 2 in HH. - simpl in HH. case_eq (gc_of_constraint a). - + intros Y HY. rewrite HY in HH. - apply IHl in HH. - etransitivity. exact HH. etransitivity. - apply or_iff_compat_l. apply GoodUnivConstraintSet.union_spec. - split. - * intros [[ctr H]|[H|H]]. left. exists ctr. intuition. intuition. - left. exists a. intuition. rewrite HY; tas. - * intros [[ctr [[H1|H1] H2]]|H]. subst a. right. right. - rewrite HY in H2; tas. - left. exists ctr. intuition. - right. left; tas. - + intro eq; rewrite eq in HH; simpl in HH. - apply False_rect. clear -HH. induction l. - * discriminate HH. - * simpl in HH. apply IHl. - apply HH. -Qed. - - - -Lemma gc_of_uctx_invariants `{cf:checker_flags} uctx uctx' - (H : gc_of_uctx uctx = Some uctx') - : global_uctx_invariants uctx -> global_gc_uctx_invariants uctx'. -Proof. - intros [Hi0 Hi]. - unfold gc_of_uctx in H. - case_eq (gc_of_constraints uctx.2); [|intro eq; rewrite eq in H; discriminate]. - intros ctrs eq; rewrite eq in H; apply some_inj in H. subst uctx'. - split; simpl. - - apply Hi0. - - red in Hi. - destruct uctx as [levels ctrs0]; cbn in *. - intros gc Hgc. - eapply gc_of_constraint_iff in Hgc; tea. - destruct Hgc as [e [He HH]]. - specialize (Hi e He); cbn in Hi. - clear -Hi HH. - destruct e as [[l ct] l']; simpl in Hi. - destruct l, ct, l'; cbn in HH; destruct prop_sub_type; cbn in HH. - change VSet.In with LevelSet.In. - all:repeat match goal with - | HH : context [ (?z ?= 0)%Z ] |- _ => - destruct (Z.compare_spec z 0); simpl in HH; auto - | HH : context [ (?z <=? 0)%Z ] |- _ => - destruct (Z.leb_spec z 0); simpl in HH; auto - | HH : False |- _ => contradiction HH - | HH : GoodUnivConstraintSet.In ?A GoodUnivConstraintSet.empty |- _ - => apply GoodConstraintSetFact.empty_iff in HH; contradiction HH - | HH : GoodUnivConstraintSet.In ?A (GoodUnivConstraintSet.singleton ?B) |- _ - => apply GoodConstraintSetFact.singleton_1 in HH; subst gc - | HH : GoodUnivConstraintSet.In ?A (GoodConstraintSet_pair ?B _) |- _ - => apply GoodConstraintSet_pair_In in HH; destruct HH as [HH|HH]; subst gc - end. - all: try split; try apply Hi; - try apply Hi. -Qed. - -Definition edge_of_level (l : VariableLevel.t) : EdgeSet.elt := - match l with - | VariableLevel.level l => (lzero, 1%Z, Level.level l) - | VariableLevel.lvar n => (lzero, 0%Z, Level.lvar n) +Section Push. + Import UnivLoopChecking. + +Equations push_uctx (g : universe_model) (uctx : ContextSet.t) : option universe_model := +push_uctx g uctx with UnivLoopChecking.declare_levels g uctx.1 := + | Some g' => enforce_constraints g' uctx.2 + | None => None. + +Lemma push_uctx_spec g uctx : + match push_uctx g uctx with + | None => + (* Either a universe was already declared *) + (exists l, LevelSet.In l uctx.1 /\ LevelSet.In l (UnivLoopChecking.levels g)) \/ + (* Or the constraints are not satisfiable *) + (~ exists v, satisfies v uctx.2) + | Some g' => + levels g' =_lset LevelSet.union uctx.1 (levels g) /\ + constraints g' =_ucset UnivConstraintSet.union uctx.2 (UnivConstraintSet.union (init_constraints_of_levels uctx.1) (constraints g)) end. - -Definition EdgeSet_pair x y - := EdgeSet.add y (EdgeSet.singleton x). -Definition EdgeSet_triple x y z - := EdgeSet.add z (EdgeSet_pair x y). - -Definition edge_of_constraint (gc : GoodConstraint.t) : EdgeSet.elt := - match gc with - | GoodConstraint.gc_le l z l' => (vtn l, z, vtn l') - | GoodConstraint.gc_lt_set_level k s => (lzero, Z.of_nat (S k), vtn (VariableLevel.level s)) - | GoodConstraint.gc_le_set_var k n => (lzero, Z.of_nat k, vtn (VariableLevel.lvar n)) - | GoodConstraint.gc_le_level_set s k => (vtn (VariableLevel.level s), (- Z.of_nat k)%Z, lzero) - | GoodConstraint.gc_le_var_set n k => (vtn (VariableLevel.lvar n), (- Z.of_nat k)%Z, lzero) - end. - -Lemma source_edge_of_level g : (edge_of_level g)..s = lzero. -Proof. - destruct g; reflexivity. -Qed. - -Lemma target_edge_of_level g : (edge_of_level g)..t = vtn g. -Proof. - destruct g; reflexivity. -Qed. - -Definition variable_of_level (l : Level.t) : option VariableLevel.t - := match l with - | Level.lzero => None - | Level.level s => Some (VariableLevel.level s) - | Level.lvar n => Some (VariableLevel.lvar n) - end. - -Definition option_edge_of_level l : option EdgeSet.elt := - match variable_of_level l with - | None => None - | Some ll => Some (edge_of_level ll) - end. - -Definition add_level_edges := - VSet.fold - (fun l E => - match variable_of_level l with - | None => E - | Some ll => EdgeSet.add (edge_of_level ll) E - end). - -Definition add_cstrs ctrs := - GoodUnivConstraintSet.fold (fun ctr => EdgeSet.add (edge_of_constraint ctr)) ctrs. - -Lemma add_cstrs_spec e x g : - EdgeSet.In e (add_cstrs x g) <-> - (exists c, edge_of_constraint c = e /\ GoodUnivConstraintSet.In c x) \/ EdgeSet.In e g. Proof. - rewrite /add_cstrs GoodUnivConstraintSet.fold_spec. - transitivity - ((exists c, edge_of_constraint c = e /\ In c (GoodUnivConstraintSet.elements x)) \/ EdgeSet.In e g). - - induction (GoodUnivConstraintSet.elements x) in g |- *; simpl. - intuition auto. now destruct H0 as [c [_ F]]. - rewrite IHl. - rewrite EdgeSet.add_spec. - split. - * intros [[c [eq inl]]|?]. - subst e. left. repeat eexists; tea. now right. - destruct H as [->|ing]; [left|right]; auto. - exists a; firstorder auto. - * intros [[c [eq [->|inl]]]|?]; auto. - left; exists c; auto. - - setoid_rewrite (GoodConstraintSetFact.elements_iff x). - now setoid_rewrite InA_In_eq. -Qed. - -#[global] Instance add_cstrs_proper : Proper (Logic.eq ==> EdgeSet.Equal ==> EdgeSet.Equal)%signature add_cstrs. -Proof. - intros s s' eq x y H. - intros e. - rewrite /add_cstrs. - rewrite !GoodUnivConstraintSet.fold_spec. subst s'. - induction (GoodUnivConstraintSet.elements s) in x, y, H, e |- *; cbn; auto. - apply IHl. now rewrite H. -Qed. - -#[global] Instance add_cstrs_proper' : Proper (GoodUnivConstraintSet.Equal ==> EdgeSet.Equal ==> EdgeSet.Equal)%signature add_cstrs. -Proof. - intros s s' eq x y H. - red in H. intros e. - rewrite !add_cstrs_spec. - rewrite H. firstorder auto. -Qed. + funelim (push_uctx g uctx). + destruct enforce_constraints eqn:ec. + - move/enforce_constraints_spec: ec => [] eql eqc. + have hs := declare_levels_spec g uctx.1. + rewrite Heq in hs. move: hs => [] hndecl hdecll hdeclc. + rewrite /levels in eql. rewrite -eql in hdecll. split => //. + now rewrite eqc hdeclc. + - move/enforce_constraints_None: ec. -(** This introduces both Set (exists l, VSet.In (vtn l) uctx.1 /\ e = edge_of_level l) - \/ (GoodUnivConstraintSet.Exists (fun gc => e = edge_of_constraint gc) uctx.2). -Proof. - unfold make_graph. unfold wGraph.E. - simpl. - assert (XX: forall E, EdgeSet.In e (GoodUnivConstraintSet.fold - (fun ctr => EdgeSet.add (edge_of_constraint ctr)) uctx.2 E) - <-> (exists gc, In gc (GoodUnivConstraintSet.elements uctx.2) /\ e = edge_of_constraint gc) - \/ EdgeSet.In e E). { - intro E. rewrite GoodUnivConstraintSet.fold_spec. - induction (GoodUnivConstraintSet.elements uctx.2) in E |- *. - - cbn. firstorder. - - simpl. etransitivity. apply IHl. clear IHl. split. - + intros [[gc H]|H]. left. exists gc. intuition. - apply EdgeSet.add_spec in H. destruct H as [H|H]. - left. exists a. intuition. right; tas. - + intros [[gc [[H1|H1] H2]]|H]. - right. apply EdgeSet.add_spec. left; now subst. - left. exists gc. split; tas. - right. apply EdgeSet.add_spec. right; tas. } - etransitivity. apply XX. clear XX. - etransitivity. apply or_comm. - etransitivity. apply or_iff_compat_l. - 2: apply or_iff_compat_r. - - apply iff_ex; intro gc. apply and_iff_compat_r. - symmetry. etransitivity. - apply GoodConstraintSetFact.elements_iff. apply InA_In_eq. - - transitivity ((exists l, In (vtn l) (VSet.elements uctx.1) /\ e = edge_of_level l) - \/ EdgeSet.In e EdgeSet.empty). - 2:{ split. intros [[l [H1 H2]]|H]. exists l. split; tas. - apply InA_In_eq, VSetFact.elements_iff in H1; tas. - now apply EdgeSetFact.empty_iff in H. - intros [l [H1 H2]]. left. exists l. split. - apply InA_In_eq, VSetFact.elements_1; tas. tas. } - unfold add_level_edges; rewrite VSet.fold_spec. generalize EdgeSet.empty. - induction (VSet.elements uctx.1). - + cbn. intro E; firstorder. - + intro E. etransitivity. apply IHl. split. - * intro HH. - destruct HH as [[l' Hl]|HH]. left. exists l'. intuition. - destruct a as [|l'|l']. right; tas. - all: apply EdgeSet.add_spec in HH; destruct HH; - [left|right; tas]. - exists (VariableLevel.level l'); intuition. exists (VariableLevel.lvar l'); intuition. - * intros [[l' [[H1|H1] H2]]|H]. - right. subst a. destruct l'; apply EdgeSet.add_spec; left; tas. - destruct l'; left; [exists (VariableLevel.level t0)|exists (VariableLevel.lvar n)]; intuition. - right. destruct a; tas; apply EdgeSet.add_spec; right; tas. -Qed. - - -Global Instance make_graph_invariants uctx (Hi : global_gc_uctx_invariants uctx) - : invariants (make_graph uctx). -Proof. - split. - - intros e He. apply make_graph_E in He. - destruct He as [[l [Hl He]]|[gc [Hgc He]]]. - + subst e. split. rewrite source_edge_of_level. apply Hi. - rewrite target_edge_of_level; tas. - + subst e. split. destruct gc; try apply (Hi.p2 _ Hgc). apply Hi. - simpl. apply Hi. - destruct gc; try apply (Hi.p2 _ Hgc). apply Hi. - simpl. apply Hi. - - apply Hi. - - cbn. intros l Hl. sq. destruct l as [|s|n]. - exists (pathOf_refl _ _). sq. simpl. reflexivity. - assert (He: EdgeSet.In (edge_of_level (VariableLevel.level s)) (wGraph.E (make_graph uctx))). { - apply make_graph_E. left. exists (VariableLevel.level s). intuition. } - unshelve eexists _. - econstructor. 2: constructor. - eexists; exact He. simpl. sq; lia. - assert (He: EdgeSet.In (edge_of_level (VariableLevel.lvar n)) (wGraph.E (make_graph uctx))). { - apply make_graph_E. left. exists (VariableLevel.lvar n). intuition. } - unshelve eexists _. - econstructor. 2: constructor. - eexists; exact He. simpl. sq; auto. lia. -Qed. - -Ltac sets_iff := - match goal with - | |- (_ /\ _) <-> _ - => eapply and_iff_compat_l; sets_iff - | |- (_ /\ _) <-> _ - => eapply and_iff_compat_l; sets_iff - | |- (_ \/ _) <-> _ - => eapply or_iff_compat_l; sets_iff - | |- (_ \/ _) <-> _ - => eapply or_iff_compat_l; sets_iff - | |- VSet.In _ (VSet.add _ _) <-> _ - => etransitivity; [eapply VSet.add_spec|sets_iff] - | |- EdgeSet.In _ (EdgeSet.add _ _) <-> _ - => etransitivity; [eapply EdgeSet.add_spec|sets_iff] - | |- VSet.In _ (VSet.singleton _) <-> _ - => etransitivity; [eapply VSet.singleton_spec|sets_iff] - | |- EdgeSet.In _ (EdgeSet.singleton _) <-> _ - => etransitivity; [eapply EdgeSet.singleton_spec|sets_iff] - | _ => reflexivity - end. - -Ltac simplify_sets := - repeat match goal with - | |- VSet.In ?A (VSet.add ?B ?C) - => let X := fresh in - simple refine (let X : VSet.In A (VSet.add B C) <-> _ := _ in _); - [|sets_iff|apply (proj2 X); clear X] - | |- EdgeSet.In ?A (EdgeSet.add ?B ?C) - => let X := fresh in - simple refine (let X : EdgeSet.In A (EdgeSet.add B C) <-> _ := _ in _); - [|sets_iff|apply (proj2 X); clear X] - | H : VSet.In ?A (VSet.add ?B ?C) |- _ - => let X := fresh in - simple refine (let X : VSet.In A (VSet.add B C) <-> _ := _ in _); - [|sets_iff|apply (proj1 X) in H; clear X] - | H : EdgeSet.In ?A (EdgeSet.add ?B ?C) |- _ - => let X := fresh in - simple refine (let X : EdgeSet.In A (EdgeSet.add B C) <-> _ := _ in _); - [|sets_iff|apply (proj1 X) in H; clear X] - | H : VSet.In ?A (VSet.singleton ?B) |- _ - => let X := fresh in - simple refine (let X : VSet.In A (VSet.singleton B) <-> _ := _ in _); - [|sets_iff|apply (proj1 X) in H; clear X] - | H : EdgeSet.In ?A (EdgeSet.singleton ?B) |- _ - => let X := fresh in - simple refine (let X : EdgeSet.In A (EdgeSet.singleton B) <-> _ := _ in _); - [|sets_iff|apply (proj1 X) in H; clear X] - | H : EdgeSet.In ?A EdgeSet.empty |- _ - => apply EdgeSetFact.empty_iff in H; contradiction - end. -Definition labelling_of_valuation (v : valuation) : labelling - := fun x => match x with - | lzero => 0 - | Level.level l => Pos.to_nat (v.(valuation_mono) l) - | Level.lvar n => (v.(valuation_poly) n) - end. -Definition valuation_of_labelling (l : labelling) : valuation - := {| valuation_mono := fun s => Pos.of_nat (l (vtn (VariableLevel.level s))); - valuation_poly := fun n => l (vtn (VariableLevel.lvar n)) |}. Section MakeGraph. - Context uctx (Huctx : global_gc_uctx_invariants uctx). + Context uctx (Huctx : global_uctx_invariants uctx). Let ctrs := uctx.2. Let G : universes_graph := make_graph uctx. diff --git a/utils/_RocqProject b/utils/_RocqProject index 0f7cde7fa..ed95eff7c 100644 --- a/utils/_RocqProject +++ b/utils/_RocqProject @@ -25,7 +25,7 @@ theories/MRPred.v theories/MRRelations.v theories/MRSquash.v theories/MRString.v -theories/wGraph.v +# theories/wGraph.v theories/MRUtils.v theories/MR_ExtrOCamlInt63.v theories/MR_ExtrOCamlZPosInt.v From 142b2bd55bbeec397b91f3aacece7a774b4cc0cf Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 30 Sep 2025 10:12:15 +0200 Subject: [PATCH 080/164] Adapt Universe.v to substitution into universe instances --- .../theories/LoopChecking/UnivLoopChecking.v | 16 +- common/theories/Universes.v | 457 +++++++++++++++--- common/theories/uGraph.v | 275 +++-------- 3 files changed, 478 insertions(+), 270 deletions(-) diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 273323b9f..5faf09f07 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -763,6 +763,14 @@ End ZUnivConstraint. - move: H. now rewrite ClausesFact.empty_iff. Qed. + Definition levels m := LoopCheck.levels m.(model). + + Lemma init_model_levels : levels init_model = LevelSet.singleton (Level.zero). + Proof. now cbn. Qed. + + Lemma init_model_constraints : constraints init_model = UnivConstraintSet.empty. + Proof. now cbn. Qed. + Local Obligation Tactic := idtac. Equations? enforce m (c : UnivConstraint.t) : option _ := @@ -806,7 +814,7 @@ End ZUnivConstraint. Qed. Definition constraint_levels (c : LoopCheck.constraint) := - LevelSet.union (levels c.1.1) (levels c.2). + LevelSet.union (NES.levels c.1.1) (NES.levels c.2). Lemma in_constraint_levels_to_constraint c : forall l, LevelSet.In l (constraint_levels (to_constraint c)) <-> @@ -870,8 +878,6 @@ End ZUnivConstraint. rewrite -LoopCheck.enforce_not_None eq. split => //. congruence. Qed. - Definition levels m := LoopCheck.levels m.(model). - Lemma enforce_model m c m' : enforce m c = Some (inl m') -> levels m = levels m' /\ UnivConstraintSet.Equal (UnivConstraintSet.add c (constraints m)) (constraints m'). @@ -1202,7 +1208,7 @@ End ZUnivConstraint. Lemma init_constraints_of_levels_spec_inv ls : forall c, UnivConstraintSet.In c (init_constraints_of_levels ls) -> - exists l c, LevelSet.In l ls /\ init_constraint_of_level l = Some c. + exists l, LevelSet.In l ls /\ init_constraint_of_level l = Some c. Proof. Admitted. Instance init_constraints_of_levels_proper : Proper (LevelSet.Equal ==> UnivConstraintSet.Equal) (init_constraints_of_levels). @@ -1231,7 +1237,7 @@ End ZUnivConstraint. - move=> s' he. destruct og => //. exists u. split => //. split. lsets. split => //. lsets. intros c. rsets. split; auto. intros []; auto. - apply init_constraints_of_levels_spec_inv in H as [l [c' [he' _]]]; lsets. + apply init_constraints_of_levels_spec_inv in H as [l [he' _]]; lsets. now left. - move=> x a s' s'' hin hnin hadd. destruct a. diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 6d5f6ccd6..2912eae95 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -2,7 +2,7 @@ From Stdlib Require Import OrdersAlt Structures.OrdersEx MSetList MSetAVL MSetFa From Equations Require Import Equations. From MetaRocq.Utils Require Import utils MRMSets MRFSets NonEmptyLevelExprSet MRClasses. From MetaRocq.Common Require Import BasicAst config UnivConstraintType. -From Stdlib Require Import ssreflect. +From Stdlib Require Import ssreflect ssrfun. Local Open Scope nat_scope. Local Open Scope string_scope2. @@ -409,6 +409,8 @@ Module Universe. #[global] Instance eq_dec_univ0 : EqDec t := eq_dec. + Definition eqb : t -> t -> bool := eqb. + Definition make (e: LevelExpr.t) : t := singleton e. Definition make' (l: Level.t) : t := singleton (LevelExpr.make l). @@ -434,13 +436,17 @@ Module Universe. Definition is_level (u : t) : bool := (LevelExprSet.cardinal u =? 1)%nat && is_levels u. + Definition zero := make' Level.lzero. + Definition succ : t -> t := map LevelExpr.succ. + Definition plus (n : nat) : t -> t := map (LevelExpr.add n). + Definition from_kernel_repr (e : Level.t * nat) (es : list (Level.t * nat)) : t := add_list es (Universe.make e). (** The l.u.b. of 2 non-prop universe sets *) - Definition sup : t -> t -> t := non_empty_union. + Definition sup : t -> t -> t := union. Definition get_is_level (u : t) : option Level.t := match LevelExprSet.elements u with @@ -465,6 +471,117 @@ Module Universe. { intros ??? H1 H2; etransitivity; tea. } Qed. + Definition fold_union (f : LevelExpr.t -> t) (u : t) := + let '(hd, tl) := to_nonempty_list u in + List.fold_right (fun r u => sup (f r) u) (f hd) tl. + + Instance proper_fold_union f : Proper (NES.eq ==> NES.eq) (fold_union f). + Proof. + intros x y ?. apply NES.equal_exprsets. apply NES.equal_exprsets in H. subst x. + reflexivity. + Qed. + + Definition fold_union_singleton {f le} : + fold_union f (singleton le) = f le. + Proof. + now cbn. + Qed. + + Lemma in_fold_sup acc l : + forall le, LevelExprSet.In le (fold_right sup acc l) <-> + LevelExprSet.In le acc \/ (exists le', In le' l /\ LevelExprSet.In le le'). + Proof. + induction l; cbn. + - intros le. firstorder. + - intros le. rewrite LevelExprSet.union_spec. + rewrite IHl. split. + * intros [H|[H|H]]. + right. exists a. split => //. now left. + now left. + right. destruct H as [le' []]. exists le'; split => //. now right. + * intros [H|[le' H]]. + right. now left. + destruct H. destruct H. subst. + now left. + right. right. exists le'. split => //. + Qed. + + Lemma in_map {le} {f} {u : NES.t} : In le (ListDef.map f (LevelExprSet.elements u)) <-> LevelExprSet.In le (map f u). + Proof. + rewrite map_spec. + split. + - intros hin. rewrite in_map_iff in hin. destruct hin as [x [<- hin]]. + exists x; split => //. now rewrite -LevelExprSet.elements_spec1 InA_In_eq. + - intros [x [hin ->]]. rewrite in_map_iff. exists x. split => //. + now rewrite -LevelExprSet.elements_spec1 InA_In_eq in hin. + Qed. + + Definition fold_union_add {f le u} : + fold_union f (add le u) = sup (f le) (fold_union f u). + Proof. + rewrite /fold_union. + have hs := to_nonempty_list_spec (add le u). + have hs' := to_nonempty_list_spec u. + destruct to_nonempty_list. + destruct to_nonempty_list. + rewrite fold_right_map (fold_right_map _ _ (f p0)). + apply equal_exprsets. intros le'. + rewrite LevelExprSet.union_spec. + rewrite !in_fold_sup. + eapply (f_equal (List.map f)) in hs. + eapply (f_equal (List.map f)) in hs'. + cbn [List.map ListDef.map] in hs, hs'. + have equ : + LevelExprSet.In le' (f p) \/ (exists le'0 : t, In le'0 (ListDef.map f l) /\ LevelExprSet.In le' le'0) <-> + exists le, In le (f p :: ListDef.map f l) /\ LevelExprSet.In le' le. + { firstorder. subst x. now left. } + rewrite equ. + have equ' : + LevelExprSet.In le' (f p0) \/ (exists le'0 : t, In le'0 (ListDef.map f l0) /\ LevelExprSet.In le' le'0) <-> + exists le, In le (f p0 :: ListDef.map f l0) /\ LevelExprSet.In le' le. + { firstorder. subst x. now left. } + rewrite equ'. rewrite hs. rewrite hs'. + split. + - move=> [] lk. rewrite !in_map_iff. + move=> [] [x] [] hfx /In_elements; rewrite add_spec => inadd inlk. + subst lk. + destruct inadd. subst x. now left. right. + exists (f x). split => //. rewrite in_map_iff. exists x. split => //. + now apply In_elements. + - move=> [] fle. + * exists (f le). split => //. + rewrite in_map_iff. exists le. split => //. + apply In_elements. apply LevelExprSet.add_spec; now left. + * destruct fle as [le2 [hin hin']]. + exists le2. split => //. + rewrite in_map_iff in hin. destruct hin as [x [hfx hin]]. subst le2. + apply In_elements in hin. rewrite in_map_iff. exists x. split => //. + rewrite -In_elements. apply LevelExprSet.add_spec; now right. + Qed. + + Lemma fold_union_spec {f u} : + forall le, LevelExprSet.In le (fold_union f u) <-> + exists le', LevelExprSet.In le' u /\ LevelExprSet.In le (f le'). + Proof. + intros le. + move: u le. clear; apply: elim. + - intros le' u. cbn. split. + * exists le'. split => //. now apply singleton_spec. + * now move=> [] le [] /LevelExprSet.singleton_spec ->. + - move=> le' x hin hnin inm. + rewrite fold_union_add /sup union_spec hin. + setoid_rewrite add_spec. firstorder. + subst. now left. + Qed. + + Definition concat_map := fold_union. + + Definition concat_map_singleton {f le} : + concat_map f (singleton le) = f le. + Proof. + now cbn. + Qed. + End Universe. #[export] Existing Instance Universe.reflect_eq. @@ -763,11 +880,11 @@ Qed. (** {6 Sort instances} *) -Module Instance. +Module LevelInstance. (** A universe instance represents a vector of argument concrete_sort to a polymorphic definition (constant, inductive or constructor). *) - Definition t : Set := list Level.t. + Definition t := list Level.t. Definition empty : t := []. Definition is_empty (i : t) : bool := @@ -779,22 +896,38 @@ Module Instance. Definition eqb (i j : t) := forallb2 Level.eqb i j. - Definition equal_upto (f : Level.t -> Level.t -> bool) (i j : t) := - forallb2 f i j. +End LevelInstance. + +Module Instance. + + (** A universe instance represents a vector of argument concrete_sort + to a polymorphic definition (constant, inductive or constructor). *) + Definition t := list Universe.t. + + Definition empty : t := []. + Definition is_empty (i : t) : bool := + match i with + | [] => true + | _ => false + end. + + Definition eqb (i j : t) := + forallb2 Universe.eqb i j. + End Instance. Module UContext. - Definition t := list name × (Instance.t × UnivConstraintSet.t). + Definition t := list name × (LevelInstance.t × UnivConstraintSet.t). - Definition make' : Instance.t -> UnivConstraintSet.t -> Instance.t × UnivConstraintSet.t := pair. - Definition make (ids : list name) (inst_ctrs : Instance.t × UnivConstraintSet.t) : t := (ids, inst_ctrs). + Definition make' : LevelInstance.t -> UnivConstraintSet.t -> LevelInstance.t × UnivConstraintSet.t := pair. + Definition make (ids : list name) (inst_ctrs : LevelInstance.t × UnivConstraintSet.t) : t := (ids, inst_ctrs). - Definition empty : t := ([], (Instance.empty, UnivConstraintSet.empty)). + Definition empty : t := ([], (LevelInstance.empty, UnivConstraintSet.empty)). - Definition instance : t -> Instance.t := fun x => fst (snd x). + Definition instance : t -> LevelInstance.t := fun x => fst (snd x). Definition constraints : t -> UnivConstraintSet.t := fun x => snd (snd x). - Definition dest : t -> list name * (Instance.t * UnivConstraintSet.t) := fun x => x. + Definition dest : t -> list name * (LevelInstance.t * UnivConstraintSet.t) := fun x => x. End UContext. Module AUContext. @@ -2335,18 +2468,26 @@ Definition fresh_universe : Universe.t := Universe.make' fresh_level. (** Substitutable type *) +Class UnivLevelSubst A := subst_level_instance : LevelInstance.t -> A -> A. + +Notation "x @@[ u ]" := (subst_level_instance u x) (at level 3, + format "x @@[ u ]"). + Class UnivSubst A := subst_instance : Instance.t -> A -> A. Notation "x @[ u ]" := (subst_instance u x) (at level 3, format "x @[ u ]"). -#[global] Instance subst_instance_level : UnivSubst Level.t := +#[global] Instance subst_level_instance_level : UnivLevelSubst Level.t := fun u l => match l with Level.lzero | Level.level _ => l | Level.lvar n => List.nth n u Level.lzero end. -#[global] Instance subst_instance_level_expr : UnivSubst LevelExpr.t := +#[global] Instance subst_level_instance_level_instance : UnivLevelSubst LevelInstance.t := + fun u l => map (subst_level_instance_level u) l. + +#[global] Instance subst_level_instance_level_expr : UnivLevelSubst LevelExpr.t := fun u e => match e with | (Level.lzero, _) | (Level.level _, _) => e @@ -2357,31 +2498,66 @@ fun u e => match e with end end. +Definition subst_instance_level_expr (u : Instance.t) (l : LevelExpr.t) : Universe.t := + match l with + | (Level.lzero, _) + | (Level.level _, _) => Universe.make l + | (Level.lvar n, k) => + match nth_error u n with + | Some l => Universe.plus k l + | None => Universe.zero + end + end. + +#[global] Instance subst_level_instance_universe : UnivLevelSubst Universe.t := + fun u => Universe.map (subst_level_instance_level_expr u). + #[global] Instance subst_instance_universe : UnivSubst Universe.t := - fun u => Universe.map (subst_instance_level_expr u). + fun u => Universe.concat_map (subst_instance_level_expr u). + +#[global] Instance subst_level_instance_univ_cstr : UnivLevelSubst UnivConstraint.t := + fun u c => (c.1.1@@[u], c.1.2, c.2@@[u]). #[global] Instance subst_instance_univ_cstr : UnivSubst UnivConstraint.t := - fun u c => (subst_instance u c.1.1, c.1.2, subst_instance u c.2). + fun u c => (c.1.1@[u], c.1.2, c.2@[u]). + +#[global] Instance subst_level_instance_cstrs : UnivLevelSubst UnivConstraintSet.t := + fun u ctrs => UnivConstraintSet.fold (fun c => UnivConstraintSet.add (subst_level_instance_univ_cstr u c)) + ctrs UnivConstraintSet.empty. #[global] Instance subst_instance_cstrs : UnivSubst UnivConstraintSet.t := fun u ctrs => UnivConstraintSet.fold (fun c => UnivConstraintSet.add (subst_instance_univ_cstr u c)) ctrs UnivConstraintSet.empty. +#[global] Instance subst_level_instance_sort : UnivLevelSubst Sort.t := + fun u e => match e with + | sProp | sSProp => e + | sType u' => sType u'@@[u] + end. + #[global] Instance subst_instance_sort : UnivSubst Sort.t := fun u e => match e with | sProp | sSProp => e - | sType u' => sType (subst_instance u u') + | sType u' => sType u'@[u] end. +Lemma subst_level_instance_to_family s u : + Sort.to_family s@@[u] = Sort.to_family s. +Proof. + destruct s => //. +Qed. + Lemma subst_instance_to_family s u : Sort.to_family s@[u] = Sort.to_family s. Proof. destruct s => //. Qed. -#[global] Instance subst_instance_instance : UnivSubst Instance.t := - fun u u' => List.map (subst_instance_level u) u'. +#[global] Instance subst_level_instance_instance : UnivLevelSubst Instance.t := + fun u u' => List.map (subst_level_instance_universe u) u'. +#[global] Instance subst_instance_instance : UnivSubst Instance.t := + fun u u' => List.map (subst_instance_universe u) u'. Theorem relevance_subst_eq u s : relevance_of_sort (subst_instance_sort u s) = relevance_of_sort s. Proof. @@ -2423,77 +2599,154 @@ Section Closedu. | sType l => closedu_universe l end. - Definition closedu_instance (u : Instance.t) := + Definition closedu_level_instance (u : LevelInstance.t) := forallb closedu_level u. + + Definition closedu_instance (u : Instance.t) := + forallb closedu_universe u. + End Closedu. (** Universe-closed terms are unaffected by universe substitution. *) Section UniverseClosedSubst. - Lemma closedu_subst_instance_level u l - : closedu_level 0 l -> subst_instance_level u l = l. + + Lemma closedu_subst_level_instance_level u l + : closedu_level 0 l -> subst_level_instance_level u l = l. Proof. destruct l; cbnr. discriminate. Qed. + Lemma closedu_subst_level_instance_level_expr u e + : closedu_level_expr 0 e -> subst_level_instance_level_expr u e = e. + Proof. + intros. + destruct e as [t b]. destruct t;cbnr. discriminate. + Qed. + Lemma closedu_subst_instance_level_expr u e - : closedu_level_expr 0 e -> subst_instance_level_expr u e = e. + : closedu_level_expr 0 e -> subst_instance_level_expr u e = Universe.make e. Proof. intros. destruct e as [t b]. destruct t;cbnr. discriminate. Qed. + Lemma closedu_subst_level_instance_universe u e + : closedu_universe 0 e -> subst_level_instance_universe u e = e. + Proof. + Import Universe. + intros. + rewrite /subst_level_instance_universe. + apply Universe.equal_exprsets => l. + rewrite Universe.map_spec. + apply LevelExprSet.for_all_spec in H. + split. + - intros [le' [hin heq]]. rewrite closedu_subst_level_instance_level_expr in heq. + unfold closedu_universe in H. + now specialize (H le' hin). tc. now subst le'. + - intros hin. exists l. split => //. + rewrite closedu_subst_level_instance_level_expr. + now apply H. reflexivity. + - tc. + Qed. + + Lemma closedu_subst_instance_universe u e + : closedu_universe 0 e -> subst_instance_universe u e = e. + Proof. + Import Universe. + intros. + rewrite /subst_instance_universe. + apply Universe.equal_exprsets => l. + rewrite /Universe.concat_map Universe.fold_union_spec. + apply LevelExprSet.for_all_spec in H. + split. + - intros [le' [hin heq]]. rewrite closedu_subst_instance_level_expr in heq. + unfold closedu_universe in H. + now specialize (H le' hin). tc. + apply LevelExprSet.singleton_spec in heq. now subst le'. + - intros hin. exists l. split => //. + rewrite closedu_subst_instance_level_expr. + now apply H. now apply LevelExprSet.singleton_spec. + - tc. + Qed. + + Lemma closedu_subst_level_instance_univ u s + : closedu_sort 0 s -> subst_level_instance_sort u s = s. + Proof. + intro H. + destruct s as [| | t]; cbnr. + apply f_equal. unfold subst_level_instance. + now rewrite closedu_subst_level_instance_universe. + Qed. + Lemma closedu_subst_instance_univ u s : closedu_sort 0 s -> subst_instance_sort u s = s. Proof. intro H. destruct s as [| | t]; cbnr. - apply f_equal. apply Universe.equal_exprsets. - destruct t as [ts H1]. - unfold closedu_sort, closedu_universe in *;cbn in *. - intro e; split; intro He. - - apply Universe.map_levelexprset_spec in He as [e' [He' X]]. - subst e. - rewrite closedu_subst_instance_level_expr. - apply LevelExprSet.for_all_spec in H; proper. - exact (H _ He'). - now subst. - - apply Universe.map_levelexprset_spec. exists e; split; tas. - symmetry; apply closedu_subst_instance_level_expr. - apply LevelExprSet.for_all_spec in H; proper. now apply H. + apply f_equal. unfold subst_instance. + now rewrite closedu_subst_instance_universe. Qed. - Lemma closedu_subst_instance u t + Lemma closedu_subst_level_instance_level_instance u t + : closedu_level_instance 0 t -> subst_level_instance u t = t. + Proof. + intro H. apply forall_map_id_spec. + apply Forall_forall; intros l Hl. + apply closedu_subst_level_instance_level. + eapply forallb_forall in H; eassumption. + Qed. + + Lemma closedu_subst_level_instance_instance u t + : closedu_instance 0 t -> subst_level_instance u t = t. + Proof. + intro H. apply forall_map_id_spec. + apply Forall_forall; intros l Hl. + apply closedu_subst_level_instance_universe. + eapply forallb_forall in H; eassumption. + Qed. + + Lemma closedu_subst_instance_instance u t : closedu_instance 0 t -> subst_instance u t = t. Proof. intro H. apply forall_map_id_spec. apply Forall_forall; intros l Hl. - apply closedu_subst_instance_level. + apply closedu_subst_instance_universe. eapply forallb_forall in H; eassumption. Qed. End UniverseClosedSubst. #[global] -Hint Resolve closedu_subst_instance_level closedu_subst_instance_level_expr - closedu_subst_instance_univ closedu_subst_instance : substu. +Hint Resolve + closedu_subst_level_instance_level + closedu_subst_level_instance_level_instance + closedu_subst_level_instance_level_expr + closedu_subst_level_instance_universe + closedu_subst_level_instance_instance + closedu_subst_level_instance_univ + closedu_subst_instance_level_expr + closedu_subst_instance_universe + closedu_subst_instance_instance + closedu_subst_instance_univ + : substu. (** Substitution of a universe-closed instance of the right size produces a universe-closed term. *) -Section SubstInstanceClosed. - Context (u : Instance.t) (Hcl : closedu_instance 0 u). +Section SubstLevelInstanceClosed. + Context (u : LevelInstance.t) (Hcl : closedu_level_instance 0 u). - Lemma subst_instance_level_closedu l - : closedu_level #|u| l -> closedu_level 0 (subst_instance_level u l). + Lemma subst_level_instance_level_closedu l + : closedu_level #|u| l -> closedu_level 0 (subst_level_instance_level u l). Proof using Hcl. destruct l; cbnr. - unfold closedu_instance in Hcl. + unfold closedu_level_instance in Hcl. destruct (nth_in_or_default n u Level.lzero). - intros _. eapply forallb_forall in Hcl; tea. - rewrite e; reflexivity. Qed. - Lemma subst_instance_level_expr_closedu e : - closedu_level_expr #|u| e -> closedu_level_expr 0 (subst_instance_level_expr u e). + Lemma subst_level_instance_level_expr_closedu e : + closedu_level_expr #|u| e -> closedu_level_expr 0 (subst_level_instance_level_expr u e). Proof using Hcl. destruct e as [l b]. destruct l;cbnr. case_eq (nth_error u n); cbnr. intros [] Hl X; cbnr. @@ -2502,33 +2755,121 @@ Section SubstInstanceClosed. discriminate. Qed. - Lemma subst_instance_univ_closedu s - : closedu_sort #|u| s -> closedu_sort 0 (subst_instance_sort u s). + Lemma subst_level_instance_universe_closedu s + : closedu_universe #|u| s -> closedu_universe 0 (subst_level_instance_universe u s). Proof using Hcl. intro H. - destruct s as [| |t]; cbnr. - destruct t as [l Hl]. apply LevelExprSet.for_all_spec; proper. intros e He. eapply Universe.map_levelexprset_spec in He. destruct He as [e' [He' X]]; subst. - apply subst_instance_level_expr_closedu. + apply subst_level_instance_level_expr_closedu. apply LevelExprSet.for_all_spec in H; proper. now apply H. Qed. + Lemma subst_level_instance_univ_closedu s + : closedu_sort #|u| s -> closedu_sort 0 (subst_level_instance_sort u s). + Proof using Hcl. + intro H. + destruct s as [| |t]; cbnr. + destruct t as [l Hl]. + now apply subst_level_instance_universe_closedu. + Qed. + + Lemma subst_level_instance_level_instance_closedu t : + closedu_level_instance #|u| t -> closedu_level_instance 0 (subst_level_instance_level_instance u t). + Proof using Hcl. + intro H. etransitivity. eapply forallb_map. + eapply forallb_impl; tea. + intros l Hl; cbn. apply subst_level_instance_level_closedu. + Qed. + + Lemma subst_level_instance_instance_closedu t : + closedu_instance #|u| t -> closedu_instance 0 (subst_level_instance_instance u t). + Proof using Hcl. + intro H. etransitivity. eapply forallb_map. + eapply forallb_impl; tea. + intros l Hl; cbn. apply subst_level_instance_universe_closedu. + Qed. + +End SubstLevelInstanceClosed. + +#[global] +Hint Resolve subst_level_instance_level_closedu subst_level_instance_level_expr_closedu + subst_level_instance_universe_closedu + subst_level_instance_univ_closedu + subst_level_instance_instance_closedu + subst_level_instance_level_instance_closedu : substu. + +Lemma eqb_iff {b b' : bool} : b = true <-> b' = true -> b = b'. +Proof. intros []; destruct b, b'; auto. elim (H eq_refl). reflexivity. Qed. + +Lemma closedu_universe_plus {u k n} : closedu_universe k u = closedu_universe k (Universe.plus n u). +Proof. + apply eqb_iff. + rewrite /closedu_universe /Universe.plus. + rewrite !LevelExprSet.for_all_spec /LevelExprSet.For_all. + setoid_rewrite Universe.map_spec. firstorder. + - subst x. rewrite /closedu_level_expr. cbn. now apply H. + - specialize (H (LevelExpr.add n x)). forward H. exists x. split => //. + now unfold closedu_level_expr in *; destruct x; cbn in *. +Qed. + +(** Substitution of a universe-closed instance of the right size + produces a universe-closed term. *) +Section SubstInstanceClosed. + Context (u : Instance.t) (Hcl : closedu_instance 0 u). + + Lemma subst_instance_level_expr_closedu e : + closedu_level_expr #|u| e -> closedu_universe 0 (subst_instance_level_expr u e). + Proof using Hcl. + destruct e as [l b]. destruct l;cbnr. + case_eq (nth_error u n); cbnr. intros u' Hl; cbnr. + apply nth_error_In in Hl. cbn in Hl. + intros hn. + unfold closedu_instance in Hcl. + red in Hcl; rewrite -> forallb_forall in Hcl. specialize (Hcl _ Hl). + now rewrite -closedu_universe_plus. + Qed. + + Lemma subst_instance_universe_closedu s + : closedu_universe #|u| s -> closedu_universe 0 (subst_instance_universe u s). + Proof using Hcl. + intro H. + apply LevelExprSet.for_all_spec; proper. + intros e He. rewrite /subst_instance_universe in He. + eapply Universe.fold_union_spec in He. + apply LevelExprSet.for_all_spec in H. + destruct He as [le [hin hin']]. + have := subst_instance_level_expr_closedu le; + move => /fwd. now apply H. + now move/LevelExprSet.for_all_spec/(_ e hin'). + tc. + Qed. + + Lemma subst_instance_univ_closedu s + : closedu_sort #|u| s -> closedu_sort 0 (subst_instance_sort u s). + Proof using Hcl. + intro H. + destruct s as [| |t]; cbnr. + destruct t as [l Hl]. + now apply subst_instance_universe_closedu. + Qed. + Lemma subst_instance_closedu t : closedu_instance #|u| t -> closedu_instance 0 (subst_instance u t). Proof using Hcl. intro H. etransitivity. eapply forallb_map. eapply forallb_impl; tea. - intros l Hl; cbn. apply subst_instance_level_closedu. + intros l Hl; cbn. apply subst_instance_universe_closedu. Qed. End SubstInstanceClosed. #[global] -Hint Resolve subst_instance_level_closedu subst_instance_level_expr_closedu - subst_instance_univ_closedu subst_instance_closedu : substu. - +Hint Resolve subst_instance_level_expr_closedu + subst_instance_universe_closedu + subst_instance_univ_closedu + subst_instance_closedu : substu. Definition string_of_level (l : Level.t) : string := match l with @@ -2566,13 +2907,13 @@ Definition universes_entry_of_decl (u : universes_decl) : universes_entry := Definition polymorphic_instance uctx := match uctx with - | Monomorphic_ctx => Instance.empty + | Monomorphic_ctx => LevelInstance.empty | Polymorphic_ctx c => fst (snd (AUContext.repr c)) end. (* TODO: duplicate of polymorphic_instance *) Definition abstract_instance decl := match decl with - | Monomorphic_ctx => Instance.empty + | Monomorphic_ctx => LevelInstance.empty | Polymorphic_ctx auctx => UContext.instance (AUContext.repr auctx) end. diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index 89385de59..86df1a60a 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -5,15 +5,16 @@ From MetaRocq.Common Require Import config UnivConstraintType Universes UnivLoop From Equations.Prop Require Import DepElim. From Equations Require Import Equations. Import ConstraintType. +Set Equations Transparent. Definition universe_model := UnivLoopChecking.univ_model. -Definition init_graph : universe_model := UnivLoopChecking.init_model. +Definition init_model : universe_model := UnivLoopChecking.init_model. Definition uctx_invariants (uctx : ContextSet.t) := UnivConstraintSet.For_all (declared_univ_cstr_levels uctx.1) uctx.2. Definition global_uctx_invariants (uctx : ContextSet.t) - := LevelSet.In Level.lzero uctx.1 /\ uctx_invariants uctx. + := ~ LevelSet.In Level.lzero uctx.1 /\ uctx_invariants uctx. Section Push. Import UnivLoopChecking. @@ -23,16 +24,28 @@ push_uctx g uctx with UnivLoopChecking.declare_levels g uctx.1 := | Some g' => enforce_constraints g' uctx.2 | None => None. +Instance declared_univ_cstrs_levels_proper : Proper (LevelSet.Equal ==> UnivConstraintSet.Equal ==> iff) + declared_univ_cstrs_levels. +Proof. Admitted. + +Definition push_uctx_precond g uctx := + let allcstrs := UnivConstraintSet.union uctx.2 (UnivConstraintSet.union (init_constraints_of_levels uctx.1) (constraints g)) in + ~ (exists l, LevelSet.In l uctx.1 /\ LevelSet.In l (UnivLoopChecking.levels g)) /\ + declared_univ_cstrs_levels (LevelSet.union (levels g) uctx.1) uctx.2. + Lemma push_uctx_spec g uctx : + let allcstrs := UnivConstraintSet.union uctx.2 (UnivConstraintSet.union (init_constraints_of_levels uctx.1) (constraints g)) in match push_uctx g uctx with | None => (* Either a universe was already declared *) (exists l, LevelSet.In l uctx.1 /\ LevelSet.In l (UnivLoopChecking.levels g)) \/ + (* Or a universe from the constraints is unbound *) + ~ (declared_univ_cstrs_levels (LevelSet.union (levels g) uctx.1) uctx.2) \/ (* Or the constraints are not satisfiable *) - (~ exists v, satisfies v uctx.2) + (~ exists v, satisfies v allcstrs) | Some g' => levels g' =_lset LevelSet.union uctx.1 (levels g) /\ - constraints g' =_ucset UnivConstraintSet.union uctx.2 (UnivConstraintSet.union (init_constraints_of_levels uctx.1) (constraints g)) + constraints g' =_ucset allcstrs end. Proof. funelim (push_uctx g uctx). @@ -43,231 +56,79 @@ Proof. rewrite /levels in eql. rewrite -eql in hdecll. split => //. now rewrite eqc hdeclc. - move/enforce_constraints_None: ec. - - - - - -Section MakeGraph. - Context uctx (Huctx : global_uctx_invariants uctx). - Let ctrs := uctx.2. - Let G : universes_graph := make_graph uctx. - - Lemma valuation_labelling_eq l (Hl : correct_labelling G l) - : forall x, VSet.In x uctx.1 - -> labelling_of_valuation (valuation_of_labelling l) x = l x. - Proof using Type. - destruct x as [|s|n]; cbnr. - - intros _. now apply proj1 in Hl; cbn in Hl. - - intro Hs. apply Nat2Pos.id. - assert (HH: EdgeSet.In (lzero, Z.of_nat 1, vtn (VariableLevel.level s)) (wGraph.E G)). { - subst G. apply make_graph_E. left. - exists (VariableLevel.level s). intuition. } - apply (proj2 Hl) in HH; cbn in HH. lia. - Qed. - - Lemma make_graph_spec v : - gc_satisfies v uctx.2 <-> correct_labelling G (labelling_of_valuation v). - Proof using Type. - unfold gc_satisfies, correct_labelling. split; intro H. - - split. reflexivity. - intros e He. cbn in He. - apply make_graph_E in He. - destruct He as [[l [Hl He]]|[ctr [Hc He]]]; cbn. - + subst e; cbn. destruct l; cbn; lia. - + subst e. - apply GoodUnivConstraintSet.for_all_spec in H. - 2: intros x y []; reflexivity. - specialize (H _ Hc). cbn in *. - destruct ctr as [[] z []|[] []| |n|n]; cbn in *; toProp H; try lia. - all:try destruct t0; cbn in *; try lia. - - apply GoodUnivConstraintSet.for_all_spec. - intros x y []; reflexivity. - intros gc Hgc. - pose proof (XX := proj2 (make_graph_E uctx (edge_of_constraint gc))). - forward XX. { right. now exists gc. } - specialize (H.p2 _ XX). - destruct gc as [[] z []|k ?| |n|n]; intro HH; cbn in *; toProp; try lia. - Qed. - - Corollary make_graph_spec' l : - (* gc_satisfies (valuation_of_labelling l) uctx.2 <-> correct_labelling G l. *) - correct_labelling G l -> gc_satisfies (valuation_of_labelling l) uctx.2. - Proof using Huctx. - intro H. apply (make_graph_spec (valuation_of_labelling l)). - unfold correct_labelling. intuition. - rewrite !valuation_labelling_eq; tas. 3:now apply H. - all: now apply make_graph_invariants. - Qed. - - Corollary make_graph_spec2 : - gc_consistent uctx.2 <-> exists l, correct_labelling G l. - Proof. - split. - - intros [v H]. exists (labelling_of_valuation v). - apply make_graph_spec. assumption. - - intros [l Hl]. exists (valuation_of_labelling l). - apply make_graph_spec'. assumption. - Defined. - - Global Instance consistent_no_loop : gc_consistent ctrs -> acyclic_no_loop G. - Proof. - intro. apply acyclic_caract1, make_graph_spec2. - now apply make_graph_invariants. assumption. - Defined. -End MakeGraph. - -Existing Class gc_consistent. -Existing Class global_gc_uctx_invariants. -Existing Class global_uctx_invariants. -Global Existing Instance gc_of_uctx_invariants. - -(** ** Check of consistency ** *) - -Definition is_consistent `{checker_flags} uctx := - match gc_of_uctx uctx with - | Some uctx => is_acyclic (make_graph uctx) - | None => false - end. - -Lemma is_consistent_spec `{checker_flags} uctx (Huctx : global_uctx_invariants uctx) - : is_consistent uctx <-> consistent uctx.2. -Proof. - etransitivity. 2: symmetry; apply gc_consistent_iff. - unfold is_consistent; cbn. - case_eq (gc_of_constraints uctx.2); cbn. - 2: intro; split; [discriminate|inversion 1]. - intros ctrs Hctrs. - pose proof (gc_of_uctx_invariants uctx (uctx.1, ctrs)) as XX. - cbn in XX; rewrite Hctrs in XX; specialize (XX Logic.eq_refl Huctx). - etransitivity. apply make_graph_invariants in XX. - etransitivity. apply is_acyclic_spec; tas. - apply acyclic_caract1; tas. - symmetry; apply (make_graph_spec2 (uctx.1, ctrs)); tas. + have := declare_levels_spec g uctx.1. + rewrite Heq. + move=> [] hfresh hunion hcstrs []. + + move=> ndecl. right. left. + rewrite [levels _]hunion in ndecl. + now rewrite LevelSetProp.union_sym. + + move=> incon. right. right => -[v he]. apply incon. + exists v. now rewrite hcstrs. + - left. have := declare_levels_spec g uctx.1. + now rewrite Heq. Qed. -Definition Equal_graph := - fun G G' : universes_graph => - LevelSet.Equal G.1.1 G'.1.1 /\ - wGraph.EdgeSet.Equal G.1.2 G'.1.2 /\ Level.eq G.2 G'.2. - -Notation "'(=_g)'" := Equal_graph (at level 30). -Infix "=_g" := Equal_graph (at level 30). - -Global Instance: RelationClasses.RewriteRelation ((=_g)) := {}. - -Global Instance equal_graph_equiv : RelationClasses.Equivalence ((=_g)). -Proof. split; unfold Equal_graph. - - intros [[vs es] s]; cbn. intuition reflexivity. - - intros [[vs es] s] [[vs' es'] s']; cbn. - intuition now symmetry. - - intros [[vs es] s] [[vs' es'] s'] [[vs'' es''] s'']; cbn. - intuition etransitivity; eauto. -Qed. - -Lemma PathOf_proper {g g' x y} : g =_g g' -> PathOf g x y -> PathOf g' x y. -Proof. - intros eq; induction 1; econstructor; eauto. - destruct e as [n ine]. apply eq in ine. now exists n. -Defined. - -Lemma PathOf_proper_weight {g g' x y} (eq: g =_g g') (p : PathOf g x y) : weight (PathOf_proper eq p) = weight p. -Proof. - induction p; cbn; auto. destruct e; cbn. - now rewrite IHp. -Qed. +(** ** Check of consistency ** *) -Global Instance invariants_proper : Proper ((=_g) ==> impl) invariants. -Proof. - intros [[vs es] s] [[vs' es'] s']; cbn in *. - intros eq [ev sv sp]; constructor; eauto; cbn in *; intros. - - firstorder eauto. - - destruct eq as [? []]; cbn in *. rewrite -H1. now apply H. - - specialize (sp x). apply eq in H. specialize (sp H). - destruct sp as [[p hp]]. - pose proof (hs := proj2 (proj2 eq)); cbn in hs. - rewrite -{2 4 6}hs. - split; exists (PathOf_proper eq p). cbn. - sq. now rewrite (PathOf_proper_weight eq). -Qed. +Equations is_consistent (uctx : ContextSet.t) : bool := +is_consistent uctx := isSome (push_uctx init_model uctx). -Global Instance invariants_proper_iff : Proper ((=_g) ==> iff) invariants. +Lemma satisfies_init v ls : satisfies v (init_constraints_of_levels ls). Proof. - intros g g' eq. split. now rewrite eq. - now rewrite eq. + move=> c /init_constraints_of_levels_spec_inv [l [inz eq]]. + destruct l; noconf eq. + constructor; cbn. lia. + constructor; cbn. lia. Qed. -Global Instance acyclic_no_loop_proper : Proper ((=_g) ==> iff) acyclic_no_loop. +Lemma is_consistent_spec `{checker_flags} uctx (Huctx : global_uctx_invariants uctx) + : is_consistent uctx <-> consistent uctx.2. Proof. - intros g g' eq. split. - - intros ac x p. - rewrite -(PathOf_proper_weight (symmetry eq) p). - apply ac. - - intros ac x p. - rewrite -(PathOf_proper_weight eq p). - apply ac. + rewrite /is_consistent. + have he := push_uctx_spec init_model uctx. + destruct push_uctx => //. + - cbn. split => // _. + have hs := model_satisfies u. exists (to_valuation (LoopCheck.valuation u)). + destruct he as [hl hcs]. rewrite hcs in hs. + now eapply satisfies_union in hs as []. + - split => //= hc. + destruct Huctx as [hs ho]. + destruct he as [[l [inctx init]] | [h | h ]]. + { cbn in init. apply LevelSet.singleton_spec in init. subst l. contradiction. } + { elim h. red in ho. move=> c /ho. + rewrite declared_univ_cstr_levels_spec. intros cdecl. + rewrite declared_univ_cstr_levels_spec. + lsets. } + { elim h. destruct hc as [v hv]. + exists v. eapply satisfies_union. split => //. + eapply satisfies_union; split => //. + 2:{ cbn. intros c. ucsets. } + apply satisfies_init. } Qed. Section CheckLeqProcedure. Context {cf:checker_flags}. - Context (leqb_level_n : Z -> Level.t -> Level.t -> bool). - - (* this is function [check_smaller_expr] of kernel/uGraph.ml *) - Definition leqb_expr_n_gen lt (e1 e2 : LevelExpr.t) := - match e1, e2 with - | (l1, k), (l2, k') => - (* l1 + k < n = l2 + k' <-> l1 < n + (k - k') = l2 *) - leqb_level_n (lt + (Z.of_nat k - Z.of_nat k'))%Z l1 l2 - end. - (* this is function [exists_bigger] of kernel/uGraph.ml *) - Definition leqb_expr_univ_n_gen lt (e1 : LevelExpr.t) (u : Universe.t) := - (* CHECKME:SPROP: should we use [prop_sub_type] here somehow? *) - (* if LevelExpr.is_prop e1 && (n =? 0) then *) - (* prop_sub_type || Sort.is_prop u *) - (* else *) - let '(e2, u) := Universe.exprs u in - List.fold_left (fun b e2 => leqb_expr_n_gen lt e1 e2 || b) - u (leqb_expr_n_gen lt e1 e2). - - (* this is function [real_check_leq] of kernel/uGraph.ml *) - Definition leqb_universe_n_gen lt (l1 l2 : Universe.t) := - let '(e1, u1) := Universe.exprs l1 in - List.fold_left (fun b e1 => leqb_expr_univ_n_gen ⎩ lt ⎭ e1 l2 && b) - u1 (leqb_expr_univ_n_gen ⎩ lt ⎭ e1 l2). - - Definition check_leqb_universe_gen (u1 u2 : Universe.t) := + Context (model : universe_model). + + Definition check_cstr := check model. + + Definition check_leqb_universe (u1 u2 : Universe.t) := ~~ check_univs || (u1 == u2) - || leqb_universe_n_gen false u1 u2. + || check_cstr (u1, Le, u2). - Definition check_eqb_universe_gen (u1 u2 : Universe.t) := + Definition check_eqb_universe (u1 u2 : Universe.t) := ~~ check_univs || (u1 == u2) - || (leqb_universe_n_gen false u1 u2 && leqb_universe_n_gen false u2 u1). - - Definition check_gc_constraint_gen (gc : GoodConstraint.t) := - ~~ check_univs || - match gc with - | GoodConstraint.gc_le l z l' => leqb_level_n z l l' - | GoodConstraint.gc_lt_set_level k l => leqb_level_n (Z.of_nat (S k)) lzero (Level.level l) - | GoodConstraint.gc_le_set_var k n => leqb_level_n (Z.of_nat k) lzero (Level.lvar n) - | GoodConstraint.gc_le_level_set l k => leqb_level_n (- Z.of_nat k)%Z (Level.level l) lzero - | GoodConstraint.gc_le_var_set n k => leqb_level_n (- Z.of_nat k)%Z (Level.lvar n) lzero - end. - - Definition check_gc_constraints_gen := - GoodUnivConstraintSet.for_all check_gc_constraint_gen. + || check_cstr (u1, Eq, u2). - Definition check_constraints_gen ctrs := - match gc_of_constraints ctrs with - | Some ctrs => check_gc_constraints_gen ctrs - | None => false - end. + Definition check_constraint (c : UnivConstraint.t) := + ~~ check_univs || check_cstr c. Definition eqb_univ_instance_gen (u1 u2 : Instance.t) : bool := - forallb2 (fun l1 l2 => check_eqb_universe_gen + forallb2 (fun l1 l2 => check_eqb_universe (Universe.make' l1) (Universe.make' l2)) u1 u2. Definition leqb_sort_gen (s1 s2 : Sort.t) := From d195cf620ba5383c70f2e27bdec857c35a9ff4ea Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 30 Sep 2025 23:28:07 +0200 Subject: [PATCH 081/164] Models are closed by intersection --- common/theories/LoopChecking/Model.v | 117 +++++++++++++++++++++++++++ 1 file changed, 117 insertions(+) diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 84359bb00..63d7e40e2 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -3098,4 +3098,121 @@ Module Model (LS : LevelSets). exact: valid_clause_elim IHentails _ hadd. Qed. + Definition model_inter (m m' : model) : model := + LevelMap.fold (fun l k acc => + match LevelMap.find l m' with + | None => acc + | Some k' => LevelMap.add l (option_map2 Z.min k k') acc + end) + m (LevelMap.empty _). + + Lemma model_inter_spec {m m'} l k : + LevelMap.MapsTo l k (model_inter m m') -> + exists k0 k1, LevelMap.MapsTo l k0 m /\ LevelMap.MapsTo l k1 m' /\ k = option_map2 Z.min k0 k1. + Proof. + rewrite /model_inter. + move: l k. + eapply LevelMapFact.fold_rec. + - move=> m0 he l k; now rewrite LevelMapFact.F.empty_mapsto_iff. + - move=> e a m0 m1 m2 hm hnin hadd ih l k h. + destruct (find_spec e m'). + * rewrite LevelMapFact.F.add_mapsto_iff in h. + apply levelmap_add_spec in hadd. + destruct h as [[h h']|[h h']]. + { subst k. red in h; subst e. exists a, k0; split => //. + rewrite hadd. rewrite LevelMapFact.F.add_mapsto_iff. now left. } + apply ih in h' as [? [? []]]; do 2 eexists; split; tea. + rewrite hadd. rewrite LevelMapFact.F.add_mapsto_iff. now right. + * specialize (ih _ _ h) as [? [? [? []]]]. + exists x, x0. split; auto. + apply levelmap_add_spec in hadd. rewrite hadd. + rewrite LevelMapFact.F.add_mapsto_iff. right; split => //. + intros eq; red in eq; subst e. apply H. now eexists. + Qed. + + Lemma model_inter_spec_inv {m m'} l : + forall k0 k1, LevelMap.MapsTo l k0 m -> LevelMap.MapsTo l k1 m' -> + LevelMap.MapsTo l (option_map2 Z.min k0 k1) (model_inter m m'). + Proof. + rewrite /model_inter. + move: l. + eapply LevelMapFact.fold_rec. + - move=> m0 he l k0 k1 hm hm'; rewrite LevelMapFact.F.empty_mapsto_iff. firstorder. + - move=> e a m0 m1 m2 hm hnin hadd ih l k0 k1 hm0 hm1. + destruct (find_spec e m'). + * rewrite LevelMapFact.F.add_mapsto_iff. + apply levelmap_add_spec in hadd. rewrite hadd in hm0. + rewrite LevelMapFact.F.add_mapsto_iff in hm0; destruct hm0 as [[? ?]|[? ?]]; try congruence. + subst a. left; split => //. red in H0; subst e. + eapply LevelMapFact.F.MapsTo_fun in hm1; tea. now subst k. + right. split => //. apply ih => //. + * apply levelmap_add_spec in hadd. rewrite hadd in hm0. + rewrite LevelMapFact.F.add_mapsto_iff in hm0. + destruct hm0 as [[? ?]|[? ?]]; try congruence. subst a. red in H0; subst e. + elim H. now eexists. apply ih => //. + Qed. + + Lemma min_atom_value_mapsto {l k v m} : LevelMap.MapsTo l (Some v) m -> min_atom_value m (l,k) = Some (v - k). + Proof. + rewrite /min_atom_value //=. + now move/level_value_MapsTo => ->. + Qed. + + Lemma model_inter_ext m m' : model_inter m m' ⩽ m /\ model_inter m m' ⩽ m'. + Proof. + split. + - move=> l k /model_inter_spec => -[k0 [k1 [m0 [m1 ->]]]]. + exists k0. split => //. destruct k0, k1; constructor; lia. + - move=> l k /model_inter_spec => -[k0 [k1 [m0 [m1 ->]]]]. + exists k1. split => //. destruct k0, k1; constructor; lia. + Qed. + + Lemma min_premise_model_inter {m m'} prems k : + min_premise (model_inter m m') prems = Some k -> + exists k0 k1, min_premise m prems = Some k0 /\ min_premise m' prems = Some k1 /\ + k <= Z.min k0 k1. + Proof. + have [hminps [[mini minik] [inmini eqmini]]] := min_premise_spec (model_inter m m') prems. + rewrite eqmini => eqmin. rewrite eqmin in eqmini. + have [fs exs] := min_premise_spec m prems. + have [fs' exs'] := min_premise_spec m' prems. + unfold min_atom_value in eqmin. + move: eqmin; case: level_valueP => // k0 /[dup] heq /model_inter_spec [k1 [k2 [mk1 [mk2 eq]]]]. + destruct k0 => // [=] eq'. subst k. destruct k1, k2; noconf eq. + specialize (fs _ inmini). specialize (fs' _ inmini). + rewrite (min_atom_value_mapsto mk1) in fs. + rewrite (min_atom_value_mapsto mk2) in fs'. + have [lem lem'] := model_inter_ext m m'. + have minp0 := min_premise_pres prems lem. + have minp1 := min_premise_pres prems lem'. + rewrite eqmini in minp0, minp1. depelim minp0; depelim minp1. + exists y, y0. split; auto; split => //. rewrite H0 in fs; rewrite H2 in fs'. + depelim fs; depelim fs'. lia. + Qed. + + Lemma model_intersection {m m' cls} : is_model cls m -> is_model cls m' -> is_model cls (model_inter m m'). + Proof. + move/is_modelP => m0 /is_modelP m1. + apply/is_modelP => cl hin. + move: (m0 _ hin). move: (m1 _ hin). + destruct cl as [prems [concl k]]. + move/valid_clause_elim => h1 /valid_clause_elim => h2. + apply valid_clause_intro => z hmin. + have [fmins [[minp mink] [inmins eqmins]]] := min_premise_spec (model_inter m m') prems. + rewrite hmin in eqmins. + rewrite /min_atom_value in eqmins. + destruct (level_value _ minp) eqn:hl => //. + eapply level_value_MapsTo' in hl. + eapply model_inter_spec in hl as [k0 [k1 [mk0 [mk1 eqk]]]]. + destruct k0, k1; noconf eqk. + rewrite -hmin in eqmins. + have [mink0 [mink1 [eqmin0 [eqmin1 eqmini]]]] := min_premise_model_inter prems _ eqmins. + specialize (h1 _ eqmin1). specialize (h2 _ eqmin0). + depelim h1. depelim h2. + apply level_value_MapsTo' in H0, H2. + have minv := model_inter_spec_inv concl _ _ H2 H0. + cbn in minv. eapply level_value_MapsTo in minv. rewrite minv. constructor. + rewrite hmin in eqmins. noconf eqmins. lia. + Qed. + End Model. From 9cb932f5078e4784264557a91ba487f00ed9118f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 1 Oct 2025 02:08:10 +0200 Subject: [PATCH 082/164] WIP on the "right" completeness lemma --- common/theories/LoopChecking/Deciders.v | 256 +++++- .../theories/LoopChecking/UnivLoopChecking.v | 47 ++ common/theories/uGraph.v | 782 +++--------------- 3 files changed, 411 insertions(+), 674 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 40ed0d5a2..19f64c047 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -435,14 +435,14 @@ Proof. Qed. *) Theorem check_invalid {cls cl} : - check cls cl = Invalid -> ~ entails cls cl. + check cls cl = Invalid -> exists m, [/\ is_model cls m, enabled_clause m cl & ~ valid_clause m cl]. Proof. funelim (check cls cl) => //. set (V := (clause_levels cl ∪ clauses_levels cls)%levels) in *. destruct cl as [prems [concl k]]. rename val into conclval_v => _. clear H Heq0 Heqcall prf. cbn in he. move: (check_atom_value_spec (Some k) conclval_v). rewrite Heq. - intros r; depelim r. rename H into nent. intros H. + intros r; depelim r. rename H into nent. have vmupd := model_updates v. have vmok := model_ok v. set (pm := premises_model_map _ _) in *. @@ -453,18 +453,20 @@ Proof. have nev : defined_map (model_model v). by apply (is_update_of_defined_map nepm vmupd). move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. - move/entails_model_valid/(_ _ vmok): H. - have [z minp] : enabled_clause (model_model v) cl. + exists (model_model v). + have en : enabled_clause (model_model v) cl. { apply (@enabled_clause_ext pm). exact: is_update_of_ext (model_updates v). red; cbn. have hcl : Clauses.In cl (Clauses.singleton cl). { now eapply Clauses.singleton_spec. } have hs:= @premises_model_map_min_premise_inv V _ _ hcl. firstorder. } + split => //. + destruct en as [z minp]. move/valid_clause_elim/(_ z minp). cbn in minp. rewrite /level_value he => h; depelim h. apply nent. - constructor. + constructor. cbn -[check_atom_value] in Heq. have posz : 0 <= z. { have hsu := model_updates v. eapply is_update_of_ext in hsu. @@ -477,6 +479,13 @@ Proof. lia. Qed. +Lemma check_invalid_entails {cls cl} : + check cls cl = Invalid -> ~ entails cls cl. +Proof. + move/check_invalid => [m [ism en nv]]. + now move/entails_model_valid/(_ m ism). +Qed. + Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) (prf : clauses_levels cls ⊂_lset V /\ clauses_levels cls' ⊂_lset V /\ only_model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m m _. @@ -639,7 +648,7 @@ Module CorrectModel. Proof. intros hl. have ha : forall l, (level_value (model_of x) l ≤ level_value (model_of x) Level.zero)%opt. - { admit. } + { todo "semi". } have hmax := model_max_spec. have hmax' := model_max_spec2. Print model_max. @@ -770,7 +779,6 @@ Module CorrectModel. exists z. apply (level_value_MapsTo' hl). Qed. - Definition clause_sem {S} {SL : Semilattice S Q.t} (V : Level.t -> S) (cl : clause) : Prop := let '(prems, concl) := cl in le (interp_expr V concl) (interp_prems V prems). @@ -834,6 +842,116 @@ Module CorrectModel. depelim maxs. lia. Qed. + Section interp_semi. + Obligation Tactic := idtac. + Import Semilattice (Semilattice, eq, add, join). + + Equations? opt_semi : Semilattice (option Z) Z := + opt_semi := {| + eq x y := R_opt Logic.eq x y; + eq_equiv := _; + add n x := option_map (Z.add n) x; + join := option_map2 Z.max |}. + Proof. + all: intros. + - split; red. + * intros x. destruct x => //. + * intros [x|] [y|]; cbn; auto. + * intros [x|] [y|] [z|]; cbn; auto. lia. + - destruct x => //=. lia. + - destruct x, y; cbn in *; lia. + - destruct x => //=. + - destruct x, y, z => //=. lia. + - destruct x, y => //=. lia. + - destruct x, x', y; cbn in *; lia. + - destruct x => //=. lia. + - destruct x => //=. lia. + - destruct x, y; cbn in *; lia. + - destruct x, y; cbn in *; lia. + Defined. + + Existing Instance opt_semi. + Lemma opt_semi_le_spec {x y} : x ≤ y -> (y = None) \/ (exists x' y', x = Some x' /\ y = Some y' /\ x' <= y'). + Proof. + rewrite /le. cbn. destruct x, y => //=. + - intros <-. right. exists z, (Z.max z z0). split => //. split => //. lia. + - intros _. now left. + - intros _. now left. + Qed. + + End interp_semi. + + Existing Instance opt_semi. + + Definition opt_valuation_of_model (m : LevelMap.t (option Z)) l := + let max := model_max m in + let min := model_min m in + match LevelMap.find l m with + | Some (Some n) => Some (max - n - min) + | _ => None + end. + + Lemma valid_clause_model_opt model cl : + valid_clause model cl -> + clause_sem (opt_valuation_of_model model) cl. + Proof. + unfold valid_clause. + destruct min_premise eqn:hmin => //= => //. + 2:{ move/min_premise_spec_aux: hmin => [hf [[min mink] [inmin hmin]]]. + move=> _. destruct cl as [prems concl]. cbn. + rewrite /min_atom_value in hmin. + set (v := opt_valuation_of_model _). + set (ip := interp_prems _ _). + have -> : ip = None. + { subst ip. move/(interp_prems_ge v): inmin; tea. + have -> : interp_expr v (min, mink) = None. + { cbn. subst v. unfold opt_valuation_of_model. + move: hmin; rewrite /level_value; case: find_spec => //. + move=> k hm. destruct k => //. } + move/opt_semi_le_spec. intros [] => //. + destruct H as [? [? []]]. congruence. } + destruct interp_expr => //=. } + destruct cl as [prems [concl k]]. cbn -[le]. + unfold level_value_above. + destruct level_value eqn:hl => //. + unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. + move/Z.leb_le => hrel. + eapply LevelMap.find_2 in hfind. + have conclm := valuation_of_model_spec _ _ _ hfind. + set (v := (model_max _ - _)) in *. + cbn in conclm. + eapply LevelMap.find_1 in conclm. + subst v. + pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. + rewrite hmin in premeq. + eapply transitivity. 2:{ eapply interp_prems_ge; tea. } + unfold interp_expr. destruct prem as [prem k']. + symmetry in premeq. + move: premeq. unfold min_atom_value. + unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. + destruct o => //. + intros [= <-]. + eapply LevelMap.find_2 in findp. + have premm := valuation_of_model_spec _ _ _ findp. + eapply LevelMap.find_1 in premm. + assert (z1 - k' <= z0 - k). lia. + have [z0min z0max] := valuation_range hfind. + have [z1min z1max] := valuation_range findp. + assert (0 <= model_max model)%Z by apply model_max_spec2. + assert (model_min model <= 0)%Z by apply model_min_spec2. + rewrite /opt_valuation_of_model. rewrite (LevelMap.find_1 findp) (LevelMap.find_1 hfind). + cbn. lia. + Qed. + + Lemma valid_clauses_model_opt model cls : + is_model cls model -> + clauses_sem (opt_valuation_of_model model) cls. + Proof. + move=> ism cl hin. + apply valid_clause_model_opt. + now move/Clauses.for_all_spec: ism; apply. + Qed. + (** Enabled and valid clauses are satisfied by valuation. *) Lemma valid_clause_model model cl : @@ -1602,7 +1720,7 @@ Module Abstract. destruct check eqn:hc => //. * exfalso; eapply check_entails_looping in hc; tea. now apply model_entails_succ in hc. - * move/check_invalid: hc => he. + * move/check_invalid_entails: hc => he. exfalso. elim he. now apply hv. Qed. @@ -1625,6 +1743,128 @@ Module Abstract. now rewrite //= !interp_rels_clauses_sem. Qed. + Definition valid_semilattice_entailment {S} {SL : Semilattice S Q.t} cls cl := + (forall (v : Level.t -> S), clauses_sem v cls -> clause_sem v cl). + + Definition valid_semilattice_entailments {S} {SL : Semilattice S Q.t} cls cls' := + (forall (v : Level.t -> S), clauses_sem v cls -> clauses_sem v cls'). + + Infix "⊩Z" := valid_entailments (at level 70, no associativity). + + Lemma opt_valuation_of_model_equiv m l : + option_get 0%Z (opt_valuation_of_model m l) = to_Z_val (to_val (valuation_of_model m)) l. + Proof. + rewrite /opt_valuation_of_model /to_Z_val /to_val. + case: find_spec. + * move=> k hm. + destruct k => //. + have he := valuation_of_model_spec m l _ hm. + apply LevelMap.find_1 in he. rewrite he. todo "bounds". + apply LevelMap.find_1 in hm. cbn. todo "zero". + * move=> hnin. cbn. todo "zero". + Qed. + + Lemma check_clauses_Z_complete m cls : + check_clauses m cls <-> valid_semilattice_entailments (clauses m) cls. + Proof. + split. + - rewrite check_clauses_spec. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -completeness_all. + move=> vr v. + red in vr. + move: (vr (option Z) opt_semi v). + rewrite !interp_rels_clauses_sem //. + - intros sem. unfold check_clauses, Deciders.check_clauses. + eapply Clauses.for_all_spec. tc. + move=> cl /sem => semcl. + destruct check eqn:hc => //. + * move/check_looping: hc. intros ne. elim ne. + exists (model_of m). split. red. admit. + apply m.(model_valid). + * move/check_invalid: hc. + move=> [m' [ism en inval]]. + have vc := valid_clauses_model_opt m' (clauses m) ism. + specialize (semcl (opt_valuation_of_model m') vc). + destruct cl as [prems [concl k]]. + cbn -[le] in semcl. + destruct en as [minp mineq]. cbn in mineq. + unfold valid_clause in inval. rewrite mineq in inval. cbn in inval. + elim inval. clear inval. + cbn -[le] in semcl. + apply opt_semi_le_spec in semcl. destruct semcl. + { todo "premises not activated: impossible". } + destruct H as [y' [z' [eq [eq' le]]]]. + move: eq. + + rewrite /opt_valuation_of_model /level_value_above /level_value. + destruct LevelMap.find eqn:hl => //. + destruct o; cbn. + + intros [= <-]. apply Z.leb_le. + move: prems z' le eq' mineq. + apply: NES.elim. + { intros [l lk]. rewrite interp_prems_singleton min_premise_singleton //=. + rewrite /opt_valuation_of_model /level_value. + destruct (LevelMap.find l m') eqn:hl' => //=. destruct o => //. + cbn. intros z' le. intros [= <-]. intros [= <-]. lia. } + { intros le' x hi hnin z' le hadd. + have ha := (NES.interp_prems_add (SL := opt_semi) (opt_valuation_of_model m') le' x). + rewrite hadd in ha. cbn in ha. + destruct (interp_prems _ x); cbn in ha => //. + specialize (hi z' le). destruct (interp_expr) eqn:he; cbn in ha => //. + subst z'. rewrite min_premise_add. + destruct le'. move: he; cbn. rewrite /opt_valuation_of_model /level_value. + destruct (LevelMap.find t0 m') => //. destruct o => //. cbn. + intros [= <-]. destruct (min_premise m' x) eqn:hm'. intros [= <-]. + cbn in ha. in hadd. + } + + + have [exm [[minl mink] [hin fmin]]] := min_premise_spec_aux _ _ _ mineq. + have hi := interp_prems_ge (SL := opt_semi) (opt_valuation_of_model m') _ _ hin. + rewrite eq' in hi. cbn in hi. + rewrite /opt_valuation_of_model in hi. + rewrite /min_atom_value /level_value in fmin. + move: hi fmin. + + destruct o; cbn. intros eqmax. move=> [=]. intros ->. + destruct (LevelMap.find concl _) eqn:hl' => //. + destruct o; cbn. intros [= <-]. + rewrite -eqmax in le. + move: le. + + constructor. + specialize (exm _ hin). depelim exm. rewrite /level_value hl in H0. noconf H0. + have hpos : 0 <= (Model.model_max m' - z0 - model_min m'). admit. + have hmin : model_min m' <= z0. admit. + have hmax : z0 <= Model.model_max m'. admit. + have hmin' : model_min m' <= z. admit. + have hmax' : z <= Model.model_max m'. admit. + lia. + + destruct (LevelMap.find minp m'). destruct o. + + + rewrite entails_L_rels_entails_L_clauses. + rewrite entails_L_entails_ℋ_equiv. + rewrite -completeness_all. + red. + intros ve. + eapply Forall_forall. intros [l r] hin. + apply relations_of_clauses_spec in hin as [prems [concl []]]. + noconf H0. red in ve. + have mv := model_valuation m. specialize (ve _ mv). + apply ve in H. cbn in H. + + specialize (ve (prems, concl)). apply ve in H. + apply syntax_model. + red. red. cbn. red in ve. + have hi := @interp_triv (relations_of_clauses (clauses m)) l. + red in hi. cbn in hi. + rewrite hi. + Qed. + + End Abstract. End Deciders. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 5faf09f07..1a97bfc28 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -1792,6 +1792,48 @@ End ZUnivConstraint. exact hv. Qed. + + Definition valid_Z_model m c := + (forall (v : Level.t -> Z), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + + Infix "⊩Z" := valid_Z_model (at level 70, no associativity). + + Definition valid_Z_entailments p r := + (forall (v : Level.t -> Z), interp_rels v p -> interp_rels v r). +(* + Lemma valid_Z_entails_L {p r} : + valid_Z_entailments p r -> p ⊩ℒ r. + Proof. + rewrite /valid_Z_entailments. + intros ha. + have ha' := entails_L_entails_ℋ_equiv. + Search entails. + + + apply syntax_model. + destruct r as [l r]. cbn. + Print ids. + change (eq (Semilattice := init_model p) (interp_prems (SL := init_model p) (ids p) l) (interp_prems (SL := init_model p) (ids p) r)). + specialize (ha _ (init_model p) (ids p) (interp_rels_init p)). + now cbn in ha. + Qed. *) + + + Theorem check_completeness {m c} : + check m c <-> m ⊩Z c. + Proof. + rewrite LoopCheck.check_complete /LoopCheck.valid_entailments /valid_model. + setoid_rewrite interp_cstrs_clauses_sem. + split. + - intros hv S s v hp. + move: (hv S s v hp). + now rewrite interp_cstr_clauses_sem. + - intros hs S SL V hsem. + move: (hs S SL V) => /fwd //. + now rewrite interp_cstr_clauses_sem. + Qed. + + Definition valid_model m c := (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). @@ -1869,5 +1911,10 @@ End ZUnivConstraint. exact hp. destruct c as [[l d] r]; cbn. split; lsets. Qed. +(* + Theorem check_invalid_nat {m c} : + check m c = false -> (forall (v : Level.t -> nat), wf_valuation (levels m ∪ univ_constraint_levels c) v -> interp_cstrs v (constraints m) -> interp_nat_cstr v c -> False). + Proof. + *) End UnivLoopChecking. diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index 86df1a60a..788407bd6 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -109,30 +109,26 @@ Qed. Section CheckLeqProcedure. Context {cf:checker_flags}. + Context (check_cstr : UnivConstraint.t -> bool). - Context (model : universe_model). - - Definition check_cstr := check model. - - Definition check_leqb_universe (u1 u2 : Universe.t) := + Definition check_leqb_universe_gen (u1 u2 : Universe.t) := ~~ check_univs || (u1 == u2) || check_cstr (u1, Le, u2). - Definition check_eqb_universe (u1 u2 : Universe.t) := + Definition check_eqb_universe_gen (u1 u2 : Universe.t) := ~~ check_univs || (u1 == u2) || check_cstr (u1, Eq, u2). - Definition check_constraint (c : UnivConstraint.t) := + Definition check_constraint_gen (c : UnivConstraint.t) := ~~ check_univs || check_cstr c. Definition eqb_univ_instance_gen (u1 u2 : Instance.t) : bool := - forallb2 (fun l1 l2 => check_eqb_universe - (Universe.make' l1) (Universe.make' l2)) u1 u2. + forallb2 check_eqb_universe_gen u1 u2. Definition leqb_sort_gen (s1 s2 : Sort.t) := - leqb_sort_n_ (fun _ => check_leqb_universe_gen) false s1 s2. + leqb_sort_ (fun _ => check_leqb_universe_gen) false s1 s2. Definition check_leqb_sort_gen (s1 s2 : Sort.t) := (s1 == s2) @@ -144,702 +140,156 @@ Section CheckLeqProcedure. End CheckLeqProcedure. -(* This section: specif in term of gc_uctx *) -Section CheckLeq. - Context {cf:checker_flags}. +Definition model_of_uctx (m : universe_model) uctx := + LevelSet.Equal (levels m) (LevelSet.add Level.lzero uctx.1) /\ + UnivConstraintSet.Equal (constraints m) (UnivConstraintSet.union (init_constraints_of_levels uctx.1) uctx.2). - Context (G : universes_graph) - uctx (Huctx: global_gc_uctx_invariants uctx) (HC : gc_consistent uctx.2) - (HG : Equal_graph G (make_graph uctx)). +Definition leq0_universe ctrs (u u' : Universe.t) := + forall v, satisfies v ctrs -> val v u <= val v u'. - Definition on_inl {A B : Type} (P : A -> Prop) (x : A + B) := - match x with - | inl x0 => P x0 - | inr _ => True - end. +Definition leq_universe {cf : checker_flags} ctrs (u u' : Universe.t) := + if check_univs then leq0_universe ctrs u u' else True. +Definition eq0_universe φ (u u' : Universe.t) := + forall v, satisfies v φ -> val v u = val v u'. - Definition gc_level_declared l - := VSet.In l uctx.1. +Definition eq_universe {cf : checker_flags} φ (u u' : Universe.t) := + if check_univs then eq0_universe φ u u' else True. - Lemma gc_level_declared_make_graph (l : Level.t) : - gc_level_declared l -> VSet.In l (wGraph.V G). - Proof using HG. - intros Hl;subst. now apply HG. - Qed. +Definition valid0_cstr φ (c : UnivConstraint.t) := + forall v, satisfies v φ -> satisfies0 v c. - Definition gc_expr_declared e - := on_Some_or_None (fun l => VSet.In l uctx.1) (LevelExpr.get_noprop e). +Definition valid_cstr {cf : checker_flags} φ (c : UnivConstraint.t) := + if check_univs then valid0_cstr φ c else True. - Definition gc_levels_declared (u : Universe.t) - := LevelExprSet.For_all gc_expr_declared u. +Definition valid0_cstrs φ (c : UnivConstraintSet.t) := + forall v, satisfies v φ -> satisfies v c. - Definition gc_levels_declared_sort (s : Sort.t) - := Sort.on_sort gc_levels_declared True s. - - Lemma val_level_of_variable_level v (l : VariableLevel.t) - : val v (l : Level.t) = val v l. - Proof using Type. - destruct l; cbn; lia. - Qed. - - Local Open Scope univ_scope. - - Lemma val_labelling_of_valuation v (l : Level.t) - : val v l = labelling_of_valuation v l. - Proof using Type. - destruct l; cbnr. - Qed. - - Lemma val_labelling_of_valuation' v (l : Level.t) n : - val v (Universe.make (l, n)) - = n + labelling_of_valuation v l. - Proof using Type. - reflexivity. - Qed. - - Lemma val_valuation_of_labelling' L (l : Level.t) n - (e := (l, n)) : - gc_level_declared l -> - correct_labelling G L -> - val (valuation_of_labelling L) e = (n + (L l))%nat. - Proof using HG. - intros Hl [HG1 HG2]. rewrite [wGraph.s _](proj2 (proj2 HG)) in HG1. simpl in HG1. - destruct l as [|l|l]; rewrite ?HG1; cbnr. - pose proof (make_graph_E uctx (edge_of_level (VariableLevel.level l))).p2 as H. - forward H. { - left. eexists; split; try reflexivity; tas. } - apply HG in H. - specialize (HG2 _ H); cbn in HG2. rewrite HG1 in HG2; cbn in HG2. - f_equal. clear -HG2. set (L (Level.level l)) in *; clearbody n. - destruct n; try lia. - Qed. +Definition valid_cstrs {cf : checker_flags} φ (c : UnivConstraintSet.t) := + if check_univs then valid0_cstrs φ c else True. - Lemma val_valuation_of_labelling L (l : Level.t) : - gc_level_declared l -> - correct_labelling G L -> - val (valuation_of_labelling L) l = (L l). - Proof using HG. - intros Hl HL. - exact (val_valuation_of_labelling' L l 0 Hl HL). - Qed. +(* This section: specif in term of gc_uctx *) +Section CheckLeq. + Context {cf:checker_flags}. - Instance correct_labelling_proper : Proper ((=_g) ==> Logic.eq ==> iff) correct_labelling. - Proof using Type. - intros g g' eq x ? ->. - unfold correct_labelling. - rewrite [wGraph.s _](proj2 (proj2 eq)). - now setoid_rewrite (proj1 (proj2 eq)). - Qed. + Context (m : universe_model) + uctx (Huctx: global_uctx_invariants uctx) + (HG : model_of_uctx m uctx). - (** ** Check of leq ** *) + Definition on_inl {A B : Type} (P : A -> Prop) (x : A + B) := + match x with + | inl x0 => P x0 + | inr _ => True + end. - Ltac unfold_univ_rel0 := - unfold eq0_universe, leq0_universe_n, leq_vertices, - gc_eq0_universe, gc_leq0_universe, gc_lt0_universe, gc_leq0_universe_n in *; - intros v Hv; cbnr. + Definition level_declared l := LevelSet.In l uctx.1. - Lemma leq_universe_vertices0 n (l l' : Level.t) - : leq_vertices G n l l' - -> gc_leq0_universe_n n uctx.2 (Universe.make' l) (Universe.make' l'). + Lemma level_declared_model (l : Level.t) : + level_declared l -> LevelSet.In l (levels m). Proof using HG. - intros H. unfold_univ_rel0. - apply make_graph_spec in Hv; tas. - eapply correct_labelling_proper in Hv; tea. 2:reflexivity. - red in Hv. - specialize (H _ Hv). - rewrite !val_labelling_of_valuation; lia. + intros Hl;subst. apply HG. clear cf. + red in Hl; lsets. Qed. - Lemma leq_universe_vertices1 n (l l' : Level.t) - (Hl : VSet.In l (wGraph.V G)) (Hl' : VSet.In l' (wGraph.V G)) - : gc_leq0_universe_n n uctx.2 (Universe.make' l) (Universe.make' l') - -> leq_vertices G n l l'. - Proof using HG Huctx. - intros H. unfold_univ_rel0. - eapply correct_labelling_proper in Hv. 2:symmetry; tea. 2:reflexivity. - specialize (H _ (make_graph_spec' _ Huctx _ Hv)) as HH. - eapply HG in Hl, Hl'. - rewrite !Universe.val_make' in HH. - rewrite <- (valuation_labelling_eq _ _ Hv l Hl). - rewrite <- (valuation_labelling_eq _ _ Hv l' Hl'). - pose proof (val_labelling_of_valuation (valuation_of_labelling v) l). - pose proof (val_labelling_of_valuation (valuation_of_labelling v) l'). - rewrite H0 H1 in HH. lia. - Qed. - - Lemma leq_universe_vertices n (l l' : Level.t) - (Hl : VSet.In l (wGraph.V G)) (Hl' : VSet.In l' (wGraph.V G)) - : gc_leq0_universe_n n uctx.2 (Universe.make' l) (Universe.make' l') - <-> leq_vertices G n l l'. - Proof using HG Huctx. - split. - - intros H. unfold_univ_rel0. apply leq_universe_vertices1; tas. - - apply leq_universe_vertices0. - Qed. + Definition expr_declared (e : LevelExpr.t) + := LevelSet.In e.1 uctx.1. - Definition leqb_level_n n (l l' : Level.t) - := leqb_vertices G n l l'. + Definition levels_declared (u : Universe.t) + := LevelExprSet.For_all expr_declared u. - Definition leqb_level_n_spec_gen (leqb_level_n : Z -> Level.t -> Level.t -> bool) := - forall n (l l' : Level.t) - (Hl : VSet.In l uctx.1) (Hl' : VSet.In l' uctx.1), leqb_level_n n l l' - <-> gc_leq0_universe_n n uctx.2 (Universe.make' l) (Universe.make' l'). - - Lemma leqb_level_n_spec : leqb_level_n_spec_gen leqb_level_n. - Proof using HC HG Huctx. - unfold leqb_level_n_spec_gen; intros; - symmetry. etransitivity. apply leq_universe_vertices; now apply HG. - etransitivity. apply leqb_vertices_correct; try exact _. 1-2:now rewrite HG; exact _. - now unfold leqb_level_n. - Qed. - - Definition leqb_expr_n := (leqb_expr_n_gen leqb_level_n). - - Lemma leqb_expr_n_spec0_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - lt e e' - : gc_expr_declared e -> - gc_expr_declared e' -> - leqb_expr_n_gen leqb_level_n_gen lt e e' -> - gc_leq0_universe_n lt uctx.2 (Universe.make e) (Universe.make e'). - Proof using Type. - unfold leqb_expr_n. - destruct e as [l k], e' as [l' k']; - try (cbn in *; discriminate); - intros He He' H v Hv; cbn; - eapply leqb_correct in H; eauto; - specialize (H v Hv); cbn in H;lia. - Qed. - - Definition leqb_expr_n_spec0 := leqb_expr_n_spec0_gen _ leqb_level_n_spec. - - Lemma andb_is_true (b b' : bool) : b /\ b' -> b && b'. - Proof using Type. destruct b, b'; cbnr; intuition 0. Qed. - - Lemma leqb_expr_n_spec_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) n e e' - (HHl : gc_expr_declared e) - (HHl' : gc_expr_declared e') - : leqb_expr_n_gen leqb_level_n_gen ⎩ n ⎭ e e' - <-> gc_leq0_universe_n ⎩ n ⎭ uctx.2 (Universe.make e) (Universe.make e'). - Proof using HC. - split; [apply (leqb_expr_n_spec0_gen _ leqb_correct)|]; try assumption. - destruct e as [l k] eqn:eqe, e' as [l' k'] eqn:eqe'; cbn; intro H; - destruct HC as [v0 Hv0]; pose proof (H v0 Hv0) as H0; cbn in H0. - simpl in H0 |- *. - apply leqb_correct; tas. - unfold_univ_rel0. - specialize (H v Hv). simpl in H. cbn in H. - lia. - Qed. + Definition levels_declared_sort (s : Sort.t) + := Sort.on_sort levels_declared True s. - Definition leqb_expr_n_spec := leqb_expr_n_spec_gen _ leqb_level_n_spec. + Definition leqb_universe u u' := check m (u, Le, u'). + Definition eqb_universe u u' := check m (u, Eq, u'). - Import NonEmptySetFacts. + Definition checkb := check m. - Definition leqb_expr_univ_n := (leqb_expr_univ_n_gen leqb_level_n). + Definition check_spec (check: UnivConstraint.t -> bool) := + forall c, declared_univ_cstr_levels uctx.1 c -> + check c <-> valid0_cstr uctx.2 c. - Lemma leqb_expr_univ_n_spec0_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - n e1 u - : gc_expr_declared e1 -> gc_levels_declared u -> leqb_expr_univ_n_gen leqb_level_n_gen n e1 u - -> gc_leq0_universe_n n uctx.2 (Universe.make e1) u. - Proof using Type. - unfold leqb_expr_univ_n_gen; intros He1 Hu H. - unfold_univ_rel0. - rewrite val_fold_right. - destruct (Universe.exprs u) as [e u'] eqn:ee;cbn in *. - rewrite <- !fold_left_rev_right in H; cbn in *. - red in Hu. - assert (Hu': gc_expr_declared e /\ Forall gc_expr_declared u'). { - split. apply Hu. apply In_to_nonempty_list. fold Universe.exprs. left. now rewrite ee. - apply Forall_forall. intros e' He'. apply Hu. - apply In_to_nonempty_list. fold Universe.exprs. right. now rewrite ee. } - destruct Hu' as [He Hu']. - apply Forall_rev in Hu'. revert Hu'. - induction (List.rev u'); cbn in *; intros. - - eapply leqb_expr_n_spec0_gen; eauto; tas. - - apply orb_true_iff in H. destruct H as [H|H]. - + eapply leqb_expr_n_spec0_gen in H; eauto. specialize (H v Hv); cbn in *. - lia. now inversion Hu'. - + apply IHl in H; clear IHl. lia. now inversion Hu'. + Lemma contra_prop_bool (P : Prop) (b : bool) : + (~~ b -> ~ P) -> (P -> b). + Proof. + destruct b => //. + intros f p. elim f. reflexivity. + exact p. Qed. - Definition leqb_expr_univ_n_spec0 := leqb_expr_univ_n_spec0_gen _ leqb_level_n_spec. - - Import Nbar Datatypes. - - Lemma val_le_caract' (u : Universe.t) v k : - (exists e, LevelExprSet.In e u /\ Z.of_nat k <= Z.of_nat (val v e))%Z <-> (Z.of_nat k <= Z.of_nat (val v u))%Z. - Proof using Type. - epose proof (val_le_caract u v k). - intuition auto. - apply inj_le, H0. - destruct H as [e [? ?]]. exists e; split; auto. - lia. - assert (k <= val v u)%nat. lia. - destruct (H1 H2) as [e [? ?]]. exists e; split; auto. - lia. - Qed. + Lemma checkb_spec : check_spec checkb. + Proof. + intros c decl. + rewrite /checkb. + split. + - rewrite check_completeness. + intros mc. intros v sat. + apply clauses_sem_satisfies0_equiv. + (* apply clauses_sem_satisfies_equiv in sat. *) + red in mc. + setoid_rewrite interp_cstrs_clauses_sem in mc. + specialize (mc Z _ (valuation_to_Z v)). + eapply interp_cstr_clauses_sem. apply mc. + apply satisfies_clauses_sem_to_Z. + destruct HG as [hlev hcstrs]. + rewrite hcstrs. eapply satisfies_union. split => //. + eapply satisfies_init. + - intros hv. red in hv. + have hi := interp_cstrs_of_m m. + destruct HG as [hlev hcstrs]. + rewrite hcstrs in hi. - Lemma val_ge_caract' (u : Universe.t) v k : - (forall e, LevelExprSet.In e u -> (Z.of_nat (val v e) <= Z.of_nat k)%Z) <-> (Z.of_nat (val v u) <= Z.of_nat k)%Z. - Proof using Type. - epose proof (val_ge_caract u v k). - intuition auto. - apply inj_le, H0. - intros e hin. specialize (H e hin). lia. - assert (val v u <= k)%nat. lia. - specialize (H1 H3 e H2). lia. - Qed. + (* setoid_rewrite <- clauses_sem_satisfies0_equiv in hv. *) + setoid_rewrite <- clauses_sem_satisfies_equiv in hv. + destruct HG as [hlev hcstrs]. + rewrite hcstrs in hcls. - Lemma Z_of_nat_bool_to_nat x b : (Z.of_nat x + ⎩ b ⎭)%Z = Z.of_nat (x + if b then 1%nat else 0%nat). - Proof using Type. destruct b; simpl; lia. Qed. - Lemma Z_of_nat_inj_bool (x : bool) : Z.of_nat (if x then 1%nat else 0%nat) = ⎩ x ⎭. - Proof using Type. destruct x; simpl; auto. Qed. + (* rewrite interp_univ_cstrs_nat + setoid_rewrite interp_cstrs_clauses_sem in hcls. + rewrite interp_cstr_clauses_sem. *) - Definition neg_forall p u := - LevelExprSet.for_all p u = false. - Lemma exists_neg_forall p u : neg_forall p u <-> LevelExprSet.exists_ (fun x => ~~ (p x)) u. - Proof using Type. - unfold neg_forall. - split. intros nf. - now apply LevelExprSet_for_all_false in nf. - intros ex. - apply not_true_iff_false; intro HH. - eapply LevelExprSet.for_all_spec in HH. 2:proper. - red in ex. - eapply LevelExprSet.exists_spec in ex as [x [inx npx]]. 2:proper. - specialize (HH _ inx). simpl in HH. rewrite HH in npx. simpl in npx. congruence. - Qed. - Definition lsp_expr G l (ei : LevelExpr.t) : Nbar.t := - let '(li, bi) := ei in (lsp G l li + Some (Z.of_nat bi))%nbar. - Local Open Scope Z_scope. + Search LoopCheck.Impl.CorrectModel.clauses_sem. + specialize (HG c). - Definition is_lt (x y : Nbar.t) : bool := - ~~ le_lt_dec y x. - Lemma is_lt_spec x y : is_lt x y -> (x < y)%nbar. - Proof using Type. - unfold is_lt. destruct le_lt_dec. simpl. discriminate. simpl. - auto. - Qed. - - (* Non trivial lemma *) - (* l + n <= max (l1, ... ln) -> exists i, l+n <= li *) - Lemma gc_leq0_universe_n_sup lt (l : Level.t) b (u : Universe.t) - (e := (l, b)) : - gc_level_declared l -> - gc_levels_declared u -> - gc_leq0_universe_n ⎩ lt ⎭ uctx.2 (Universe.make e) u -> - exists (e' : LevelExpr.t), LevelExprSet.In e' u - /\ gc_leq0_universe_n ⎩ lt ⎭ uctx.2 (Universe.make e) (Universe.make e'). - Proof using HC HG Huctx. - intros Hl Hu H. - assert (HG1 : invariants G) by (rewrite HG; exact _). - assert (HG2 : acyclic_no_loop G) by (rewrite HG; exact _). - assert (Hs : wGraph.s G = lzero) by apply (proj2 (proj2 HG)). - assert (Vs : VSet.In lzero (wGraph.V G)). - { rewrite <-Hs. now apply source_vertex. } - case_eq (lsp G l lzero). - (* case where there is a path from l to Set, so l <= Set+ (-m). - This implies that -m + b <= val v u. - *) - - intros lset Hlset. red in H. - (** Needs to strengthen the argument using a valuations of l with - m *) - assert (Hinl : VSet.In l (wGraph.V G)). { - red in Hl; cbn in Hl. now apply HG. } - epose proof (lsp_to_s G Hinl). - rewrite Hs in H0. specialize (H0 Hlset). - pose proof (lsp_s G _ Hinl) as [sl [lspsl slpos]]. - assert (Hl' : forall v, gc_satisfies v uctx.2 -> (val v l <= Z.to_nat (- lset))%nat). { - intros v Hv. apply make_graph_spec in Hv. - rewrite <- HG in Hv. - eapply correct_labelling_lsp in Hlset; tea. - cbn in Hlset. - change (labelling_of_valuation v l) with (val v l) in Hlset. lia. } - assert (Hl'' : forall v, gc_satisfies v uctx.2 -> (Z.to_nat sl <= val v l)%nat). { - intros v Hv. apply make_graph_spec in Hv. - rewrite <- HG in Hv. rewrite Hs in lspsl. - eapply correct_labelling_lsp in lspsl; tea. - cbn in lspsl. - change (labelling_of_valuation v l) with (val v l) in lspsl. lia. } - assert (LevelExprSet.for_all - (fun ei => is_lt (lsp_expr G l ei - Some (Z.of_nat b))%nbar (Some ⎩ lt ⎭))%Z - u = false) as HH. { - apply not_true_iff_false; intro HH. - apply LevelExprSet.for_all_spec in HH; proper. - set (G' := wGraph.Subgraph1.G' G lzero l lset) in *. - assert (HG'1 : invariants G'). { - subst G'; apply Subgraph1.HI'; tas. } - assert (HG'2 : acyclic_no_loop G'). { - subst G'; apply Subgraph1.HG'; tas. } - eapply (Subgraph1.correct_labelling_lsp_G' G) in Hlset as Hlab; tas. - fold G' in Hlab; cbn in Hlab. - set (lab := fun x => to_label (lsp G' (wGraph.s G) x)) in *. - pose proof (make_graph_spec' _ Huctx lab) as Hv. - forward Hv; [now rewrite <- HG|]. - specialize (H _ Hv). specialize (Hl' _ Hv). - specialize (Hl'' _ Hv). - rewrite Universe.val_make in H. - rewrite (val_valuation_of_labelling' _ l b) in H; tas. - apply switch_minus in H. - subst e. - rewrite Z_of_nat_bool_to_nat in H. - eapply val_le_caract' in H. - destruct H as [ei [Hei H]]. specialize (HH ei Hei); cbn in HH. - specialize (Hu ei Hei). - destruct ei as [li bi]; cbn in *. - assert (Vli : VSet.In li (wGraph.V G)). - { now apply HG. } - - simpl in H. unfold is_lt in HH. - match goal with - | H : ~~ is_left ?X = true |- _ => - destruct X as [HH'|Hlt]; [discriminate|]; clear H - end. - rewrite val_valuation_of_labelling in H; tas. - rewrite !Nat2Z.inj_add in H. - rewrite Z_of_nat_inj_bool in H. - assert (Z.of_nat (lab l) = - lset). - { unfold lab. - epose proof (Subgraph1.lsp_G'_spec_left G _ _ Hinl Vs _ Hlset l). - fold G' in H1. rewrite Hs H1. clear H1. - rewrite lsp_xx. - pose proof (lsp_sym _ Hlset). - destruct (lsp_s G l Hinl) as [sl' [lspsl' w]]. - rewrite Hs in lspsl'. rewrite lspsl' in H1 |- *. - simpl in H1. cbn -[to_label]. - rewrite Z_of_to_label_pos //; lia. } - rewrite H1 in H. - destruct (lsp_s G' li) as [ni [Hni nipos]]. - { cbn. now apply HG. } - generalize (Subgraph1.lsp_G'_spec_left G lzero l Hinl Vs _ Hlset li). - fold G'. simpl in Hni. - rewrite <-Hs, Hni. - destruct (lsp_s G li Vli) as [sli [lspsli wsli]]. - rewrite lspsli. rewrite Hs in Hni, lspsli, lspsl. - assert (⎩ lt ⎭ <= - Z.of_nat b + lset + Z.of_nat bi + Z.of_nat (lab li)) by lia. - destruct (lsp G l li) as [lli|] eqn:elli. - 2:{ exfalso. - generalize (lsp_codistance G l lzero li). - now rewrite elli Hlset lspsli. } - simpl in Hlt. - assert (lli + Z.of_nat bi - Z.of_nat b < - Z.of_nat b + lset + Z.of_nat bi + Z.of_nat (lab li)) by lia. - assert (lli < lset + Z.of_nat (lab li)) by lia. - unfold lab in H. rewrite Hs in H. - rewrite Hni in H. - rewrite Z_of_to_label_pos in H; try lia. - intros hmax. - symmetry in hmax. - apply eq_max in hmax as [[= eq]|eq]. subst ni. - unfold lab in H4. rewrite Hs Hni in H4. - rewrite Z_of_to_label_pos in H4; try lia. - pose proof (lsp_codistance G l lzero li). rewrite Hlset lspsli elli in H5. - simpl in H5. lia. - simpl in eq. noconf eq. - lia. } - apply LevelExprSet_for_all_false in HH. - apply LevelExprSet.exists_spec in HH; proper. - unfold LevelExprSet.Exists in *. - destruct HH as [[li bi] [He' HH]]. unfold is_lt in HH. - rewrite negb_involutive in HH. - eexists; split; tea. - match goal with - | H : ssrbool.is_left ?X = true |- _ => - destruct X as [HH'|HH']; try discriminate; clear H - end. - cbn in HH'. - rewrite Hs in lspsl. - case_eq (lsp G l li). - 2: intros X; rewrite X in HH'; destruct bi, b; contradiction. - intros nl Hnl v Hv; rewrite Hnl in HH'. - simpl in HH'. - rewrite (val_labelling_of_valuation' v li bi); cbn. - specialize (Hl' _ Hv). - specialize (Hl'' _ Hv). - pose proof Hv as Hv'. - apply make_graph_spec in Hv; tas. rewrite <- HG in Hv. - apply (correct_labelling_lsp _ Hnl) in Hv. cbn in Hv. - apply switch_minus. - rewrite !Nat2Z.inj_add. - enough (Z.of_nat b + Z.of_nat (val v l) + ⎩ lt ⎭ - Z.of_nat bi <= Z.of_nat (labelling_of_valuation v li)) by lia. - etransitivity; [|eassumption]. - assert (Z.of_nat (val v l) = Z.of_nat (labelling_of_valuation v l)). - reflexivity. rewrite H1. lia. - - (* case where there is no path from l to Set *) - - intros HlSet. subst e. - assert (Hl' : VSet.In l (wGraph.V G)). { - red in Hl; cbn in Hl; now apply HG. } - - assert (LevelExprSet.for_all - (fun ei => match ei with - | (li, bi) => - le_lt_dec (Some (Z.of_nat bi) - + Some (match b with 0%nat => 1%Z | _ => (- (Z.pred (Z.of_nat b)))%Z end) - + lsp G l li) - (Some ⎩ lt ⎭)%Z - end)%nbar - u = false) as HH. { - apply not_true_iff_false; intro HH. - destruct (lsp_s G _ Hl') as [nl [Hnl nlpos]]; cbn in Hnl. - - assert (exists K : Z, (nl <= K)%Z /\ - LevelExprSet.For_all - (fun ei => match ei with - | (li, bi) => - match lsp G (wGraph.s G) li with - | None => True - | Some ni => ((Z.of_nat bi) + ni < K)%Z - end - end) u) as XX. { - exists (LevelExprSet.fold - (fun ei K => match ei with - | (li, bi) => - match lsp G (wGraph.s G) li with - | None => K - | Some ni => Z.max K (Z.succ (Z.of_nat bi) + ni) - end - end) u nl). - clear -Hu HG HG1 HG2. split. - - rewrite LevelExprSet.fold_spec. rewrite <- fold_left_rev_right. - induction (List.rev (LevelExprSet.elements u)). reflexivity. - cbn. destruct a as [li bi]; tas. - destruct (lsp G (wGraph.s G) li); tas; lia. - - intros [li bi] Hei; trivial. - specialize (Hu _ Hei); cbn in Hu. - destruct (lsp_s G li) as [ni' [Hni' ni'pos]]. - { now apply HG. } - rewrite Hni'. - rewrite LevelExprSet.fold_spec. rewrite <- fold_left_rev_right. - apply LevelExprSetFact.elements_1, InA_In_eq, in_rev in Hei. - change (In (li, bi) - (@List.rev LevelExprSet.elt (LevelExprSet.elements u))) in Hei. - induction (List.rev (LevelExprSet.elements u)); inv Hei. - + subst a; cbn. rewrite Hni'. lia. - + specialize (IHl H). cbn. destruct a as [li' bi']. - destruct (lsp G (wGraph.s G) li'); lia. } - destruct XX as [K [HK1 HK2]]. - assert (Hs' : VSet.In lzero (wGraph.V G)). { - rewrite <- Hs; apply HG1. } - set (G' := wGraph.G' G lzero l K) in *. - assert (lsG : l <> wGraph.s G). intros eq. - { rewrite eq in HlSet, Hnl. - congruence. } - assert (HG'1 : invariants G'). { - subst G'; apply HI'; tas. } - assert (HG'2 : acyclic_no_loop G'). { - subst G'; apply HG'; tas. } - apply correct_labelling_lsp_G' with (K:=K) in HlSet as Hlab; tas. - fold G' in Hlab; cbn in Hlab. - set (lab := fun x => to_label (lsp G' (wGraph.s G) x)) in *. - pose proof (make_graph_spec' _ Huctx lab) as Hv. - forward Hv; [now rewrite <- HG|]. - specialize (H _ Hv); clear Hv. - rewrite Universe.val_make in H. - rewrite val_valuation_of_labelling' in H; tas. - - apply switch_minus in H. - rewrite Z_of_nat_bool_to_nat in H. - apply val_le_caract' in H. - destruct H as [ei [Hei H]]. - apply LevelExprSet.for_all_spec in HH; proper. - specialize (HH _ Hei); cbn in HH. - specialize (Hu _ Hei). - destruct ei as [li bi]; cbn in H. - rewrite val_valuation_of_labelling in H; tas. - match goal with - | H : is_left ?X = true |- _ => - destruct X as [HH'|HH']; try discriminate; clear H - end. - assert (lab l = to_label (Some K)) as XX. { - subst lab; cbn. subst G'. rewrite -> Hs in *. - rewrite lsp_G'_spec_left; tas. rewrite Hnl. - unfold lsp. rewrite acyclic_lsp0_xx; tas. - simpl. assert (Z.max nl (K + 0) = K). lia. now rewrite H0. } - rewrite XX in H. - destruct (lsp_s G li) as [ni [Hni nipos]]. - { now apply HG. } - specialize (HK2 _ Hei); cbn in HK2. rewrite Hni in HK2. - - case_eq (lsp G l li). - - intros ki Hki. rewrite Hki in HH'; cbn in HH'. - destruct (Z.leb_spec ni (K + ki)). - assert (lab li = to_label (Some (K + ki)%Z)) as XX'. { - subst lab; cbn. subst G'. rewrite -> Hs in *. - rewrite lsp_G'_spec_left; tas. rewrite Hki. - rewrite Hni; cbn. - assert (Z.max ni (K + ki) = K + ki)%Z as ->. lia. - reflexivity. } - rewrite XX' in H. - rewrite !Nat2Z.inj_add in H. - rewrite !Z_of_to_label in H. - destruct (Z.leb_spec 0 K); [|lia]. - destruct (Z.leb_spec 0 (K + ki)); [|]. - rewrite Z_of_nat_inj_bool in H. - destruct b; cbn in *; lia. - destruct b, lt; cbn in *; lia. - assert (lab li = to_label (Some ni)) as XX'. { - subst lab; cbn. subst G'. rewrite -> Hs in *. - rewrite lsp_G'_spec_left; tas. rewrite Hki Hni; simpl. - enough (Z.max ni (K + ki) = ni)%Z as ->; auto. lia. } - rewrite XX' in H. - rewrite !Nat2Z.inj_add !Z_of_to_label Z_of_nat_inj_bool in H. - destruct (Z.leb_spec 0 K); [|lia]. - destruct (Z.leb_spec 0 ni); [|lia]. - destruct b, lt; cbn in *; lia. - - - intro Hki. - assert (lab li = to_label (Some ni)) as XX'. { - subst lab; cbn. subst G'. rewrite -> Hs in *. - rewrite lsp_G'_spec_left; tas. now rewrite Hki Hni. } - rewrite XX' in H. - rewrite !Nat2Z.inj_add !Z_of_to_label Z_of_nat_inj_bool in H. - destruct (Z.leb_spec 0 K); [|lia]. - destruct (Z.leb_spec 0 ni); [|lia]. - destruct b, lt; cbn in *; lia. } - - apply LevelExprSet_for_all_false in HH. - apply LevelExprSet.exists_spec in HH; proper. - destruct HH as [[li bi] [He' HH]]. - eexists; split; tea. - match goal with - | H : ~~ is_left ?X = true |- _ => - destruct X as [HH'|HH']; try discriminate; clear H - end. - cbn in HH'. case_eq (lsp G l li). - 2: intros X; rewrite X in HH'; destruct bi, b; contradiction. - intros nl Hnl v Hv; rewrite Hnl in HH'. - apply make_graph_spec in Hv; tas. rewrite <- HG in Hv. - apply (correct_labelling_lsp _ Hnl) in Hv. - rewrite !val_labelling_of_valuation'. - destruct b, lt; cbn in *; lia. - Qed. - - Lemma leqb_expr_univ_n_spec_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - lt e1 (u : Universe.t) - (He1 : gc_expr_declared e1) - (Hu : gc_levels_declared u) - : leqb_expr_univ_n_gen leqb_level_n_gen ⎩ lt ⎭ e1 u - <-> gc_leq0_universe_n ⎩ lt ⎭ uctx.2 (Universe.make e1) u. - Proof using HC HG Huctx. - split; [eapply leqb_expr_univ_n_spec0_gen; eauto|]. - unfold leqb_expr_univ_n_gen; intro HH. - case_eq (Universe.exprs u). intros e u' ee. - assert (Hu': gc_expr_declared e /\ Forall gc_expr_declared u'). { - split. apply Hu. apply In_to_nonempty_list. fold Universe.exprs. left. now rewrite ee. - apply Forall_forall. intros e' He'. apply Hu. - apply In_to_nonempty_list. fold Universe.exprs. right. now rewrite ee. } - destruct e1 as [l1 b1]. - apply gc_leq0_universe_n_sup in HH; tas. - destruct HH as [e' [He' HH]]. eapply leqb_expr_n_spec_gen in HH; eauto; tas. - apply In_to_nonempty_list in He'. fold Universe.exprs in He'; rewrite ee in He'; cbn in He'. - rewrite <- !fold_left_rev_right. - clear -He' HH. destruct He' as [H|H]; [subst|]. - * induction (List.rev u'); tas;cbn -[leqb_expr_n]. - now rewrite IHl orb_true_r. - * apply In_rev in H. - induction (List.rev u'); cbn -[leqb_expr_n]; invs H. - unfold leqb_expr_n_gen in HH. now rewrite HH. now rewrite IHl; auto; rewrite orb_true_r. - Qed. - - Definition leqb_expr_univ_n_spec := leqb_expr_univ_n_spec_gen _ leqb_level_n_spec. - - Definition leqb_universe_n := (leqb_universe_n_gen leqb_level_n). Lemma fold_right_xpred0 {A} (l : list A) : fold_right (fun _ => xpred0) false l = false. Proof using Type. induction l; simpl; auto. Qed. - Lemma leqb_universe_n_spec0_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - lt (u1 u2 : Universe.t) - (Hu1 : gc_levels_declared u1) - (Hu2 : gc_levels_declared u2) -: leqb_universe_n_gen leqb_level_n_gen lt u1 u2 -> gc_leq0_universe_n ⎩ lt ⎭ uctx.2 u1 u2. - Proof using Type. - unfold leqb_universe_n_gen. intros H. - unfold_univ_rel0. - unfold val, Universe.Evaluable. - destruct (Universe.exprs u1) as [e1 u1'] eqn:Hu1'. - rewrite <- fold_left_rev_right in *; cbn in *. - assert (Hu': gc_expr_declared e1 /\ Forall gc_expr_declared u1'). { - split. apply Hu1. apply In_to_nonempty_list. fold Universe.exprs. left. now rewrite Hu1'. - apply Forall_forall. intros e' He'. apply Hu1. - apply In_to_nonempty_list. fold Universe.exprs. right. now rewrite Hu1'. } - destruct Hu' as [? Hu']. apply Forall_rev in Hu'. revert Hu'. - induction (List.rev u1'); cbn in *; intros. - + eapply leqb_expr_univ_n_spec0_gen in H; eauto. - specialize (H v Hv); cbn in H. assumption. - + set (z := (fold_right (fun e x => Nat.max (val v e) x) (val v e1) l)) in *. - toProp as [H HH]. - eapply leqb_expr_univ_n_spec0_gen in H; eauto. specialize (H v Hv). cbn in H. - destruct (Nat.max_dec (val v a) z) as [ee|ee]; rewrite ee. - * assumption. - * apply IHl; tas. now inversion Hu'. - * now inversion Hu'. - Qed. - - Definition leqb_universe_n_spec0 := leqb_universe_n_spec0_gen _ leqb_level_n_spec. + Definition check_leqb_universe := (check_leqb_universe_gen checkb). + Definition check_eqb_universe := (check_eqb_universe_gen checkb). - Lemma leqb_universe_n_spec_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - lt (l1 l2 : Universe.t) - (Hu1 : gc_levels_declared l1) - (Hu2 : gc_levels_declared l2) - : leqb_universe_n_gen leqb_level_n_gen lt l1 l2 - <-> gc_leq0_universe_n ⎩ lt ⎭ uctx.2 l1 l2. - Proof using HC HG Huctx. - split; [eapply leqb_universe_n_spec0_gen; eauto |]. - unfold leqb_universe_n_gen; intro HH. - unfold Universe.exprs. - case_eq (to_nonempty_list l1); intros e1 uu1 Huu1. - rewrite (fold_left_andb_forallb (fun e => _)). - pose proof (to_nonempty_list_spec' l1) as X; rewrite Huu1 in X; cbn in X. - rewrite X. apply forallb_Forall. apply Forall_forall. - intros ei Hei. - apply InA_In_eq, LevelExprSetFact.elements_2 in Hei. - specialize (Hu1 _ Hei). - eapply leqb_expr_univ_n_spec_gen; eauto; tas. - intros v Hv. specialize (HH v Hv). - simpl in HH |- *. - transitivity (Z.of_nat (val v l1)); eauto. - eapply (val_ge_caract' l1 v (val v l1)).p2. lia. auto. - Qed. - - Definition leqb_universe_n_spec := leqb_universe_n_spec_gen _ leqb_level_n_spec. - - Definition check_leqb_universe := (check_leqb_universe_gen leqb_level_n). - - Lemma check_leqb_universe_spec_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - (u1 u2 : Universe.t) - (Hu1 : gc_levels_declared u1) - (Hu2 : gc_levels_declared u2) - : check_leqb_universe_gen leqb_level_n_gen u1 u2 <-> gc_leq_universe uctx.2 u1 u2. - Proof using HC HG Huctx. - unfold check_leqb_universe_gen, - gc_leq_universe, gc_leq_universe_n, - leqb_universe_n_gen, gc_leq0_universe_n. - destruct check_univs; [|split; trivial]. - split; cbn. - - move/orP => [|]. - + rewrite univ_expr_eqb_true_iff. - intros <- v Hv. lia. - + now eapply (leqb_universe_n_spec0_gen _ _ false). - - intros H; eapply (leqb_universe_n_spec_gen _ _ false) in H; tas. - unfold leqb_universe_n_gen in H. rewrite H. - now rewrite orb_true_r. - Unshelve. all:eauto. + Lemma check_leqb_universe_spec_gen check + (check_correct : check_spec check) + (l l' : Universe.t) + (Hu1 : declared_univ_cstr_levels uctx.1 (l, Le, l')) + : check_leqb_universe_gen check l l' <-> valid_cstr uctx.2 (l, Le, l'). + Proof using HG Huctx. + specialize (check_correct _ Hu1). + rewrite /check_leqb_universe_gen /valid_cstr. destruct check_univs => //=. + destruct (eqb_spec l l'). + - subst l' => //=. split => // _. red. intros. constructor. lia. + - cbn. apply check_correct. + Qed. + + Lemma check_eqb_universe_spec_gen check + (check_correct : check_spec check) + (l l' : Universe.t) + (Hu1 : declared_univ_cstr_levels uctx.1 (l, Eq, l')) + : check_eqb_universe_gen check l l' <-> valid_cstr uctx.2 (l, Eq, l'). + Proof using HG Huctx. + specialize (check_correct _ Hu1). + rewrite /check_eqb_universe_gen /valid_cstr. destruct check_univs => //=. + destruct (eqb_spec l l'). + - subst l' => //=. split => // _. red. intros. constructor. lia. + - cbn. apply check_correct. Qed. - Definition check_leqb_universe_spec := check_leqb_universe_spec_gen _ leqb_level_n_spec. + Definition check_leqb_universe_spec := check_leqb_universe_spec_gen _ check_spec. Definition check_eqb_universe := (check_eqb_universe_gen leqb_level_n). From c5c6f4bb4b347ebbe6ea8d58e919add01febdfca Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 1 Oct 2025 12:21:38 +0200 Subject: [PATCH 083/164] Proven real completeness result for opt_semilattice entailment --- common/theories/LoopChecking/Deciders.v | 192 ++++++++++++++---------- 1 file changed, 116 insertions(+), 76 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 19f64c047..f8d780fee 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -883,11 +883,14 @@ Module CorrectModel. Existing Instance opt_semi. - Definition opt_valuation_of_model (m : LevelMap.t (option Z)) l := + Definition valuation_of_value m n := let max := model_max m in let min := model_min m in + max - n - min. + + Definition opt_valuation_of_model (m : LevelMap.t (option Z)) l := match LevelMap.find l m with - | Some (Some n) => Some (max - n - min) + | Some (Some n) => Some (valuation_of_value m n) | _ => None end. @@ -940,7 +943,7 @@ Module CorrectModel. assert (0 <= model_max model)%Z by apply model_max_spec2. assert (model_min model <= 0)%Z by apply model_min_spec2. rewrite /opt_valuation_of_model. rewrite (LevelMap.find_1 findp) (LevelMap.find_1 hfind). - cbn. lia. + cbn. rewrite /valuation_of_value. lia. Qed. Lemma valid_clauses_model_opt model cls : @@ -1751,6 +1754,24 @@ Module Abstract. Infix "⊩Z" := valid_entailments (at level 70, no associativity). + Lemma opt_valuation_of_model_inv {m l k} : + opt_valuation_of_model m l = Some k -> + exists k', LevelMap.MapsTo l (Some k') m /\ k = valuation_of_value m k'. + Proof. + rewrite /opt_valuation_of_model. + destruct (find_spec l m) => //. + destruct k0 => //; intros [= <-]. + exists z. split => //. + Qed. + + Lemma mapsto_opt_valuation_of_model {m l k} : + LevelMap.MapsTo l (Some k) m -> + opt_valuation_of_model m l = Some (valuation_of_value m k). + Proof. + rewrite /opt_valuation_of_model => hm; apply LevelMap.find_1 in hm. + now rewrite hm. + Qed. + Lemma opt_valuation_of_model_equiv m l : option_get 0%Z (opt_valuation_of_model m l) = to_Z_val (to_val (valuation_of_model m)) l. Proof. @@ -1764,6 +1785,68 @@ Module Abstract. * move=> hnin. cbn. todo "zero". Qed. + Lemma min_atom_value_mapsto {m le k} : min_atom_value m le = Some k -> + LevelMap.MapsTo le.1 (Some (k + le.2)) m. + Proof. + rewrite /min_atom_value. + destruct le. case: (@level_valueP m t0) => // -[k'|] // hm [=] <-. + cbn. now have -> : k' - z + z = k' by lia. + Qed. + + Lemma min_premise_interp_prems_ex {m u minp} : + min_premise m u = Some minp -> + exists z, interp_prems (opt_valuation_of_model m) u = Some z /\ + (exists maxx maxk, LevelExprSet.In maxx u /\ LevelMap.MapsTo maxx.1 (Some maxk) m /\ z = valuation_of_value m maxk + maxx.2) /\ + forall x, LevelExprSet.In x u -> exists k, LevelMap.MapsTo x.1 (Some k) m /\ + valuation_of_value m k + x.2 <= z /\ minp <= k - x.2. + Proof. + move: u minp. + apply: NES.elim. + { intros [l lk]. rewrite interp_prems_singleton min_premise_singleton //= => minp. + case: (@level_valueP m l) => // -[] // vl hm [=] <-. + rewrite (mapsto_opt_valuation_of_model hm) //=. + eexists; split => //. + setoid_rewrite LevelExprSet.singleton_spec. split. + do 2 eexists; split; trea. split; tea. cbn. lia. + intros x ->. eexists; split => //. exact hm. split => //. cbn. lia. cbn. lia. } + { intros [l k] u. + intros h nin minp. + rewrite min_premise_add. + destruct min_atom_value eqn:hmin => //. + 2:{ now move/min_opt_None_left. } + destruct (min_premise m u) => //. + specialize (h _ eq_refl) as [z1 [? [[maxx [maxk [inmax [mmax maxle]]]]]]]. + cbn. intros [= <-]. + have ha := (NES.interp_prems_add (SL := opt_semi) (opt_valuation_of_model m) (l, k) u). + rewrite H in ha. + have hminv := min_atom_value_mapsto hmin. cbn in hminv. + cbn [interp_expr] in ha. + rewrite (mapsto_opt_valuation_of_model hminv) in ha. + cbn [eq opt_semi] in ha. + destruct (interp_prems _ (NES.add _ _)); cbn in ha => //. + subst z2. eexists; split; trea. + split. + destruct (Z.max_spec (k + valuation_of_value m (z + k)) z1) as [[hle heq]|[hle heq]]. + * do 2 eexists; split => //. eapply LevelExprSet.add_spec. now right. + split; tea. now subst z1. + * do 2 eexists; split => //. eapply LevelExprSet.add_spec. left; trea. + split. exact hminv. cbn in *. lia. + * intros x; rewrite LevelExprSet.add_spec => -[]. + + intros ->. eexists; split; tea. cbn. lia. + + move/H0 => [k' [hm [hle hle']]]. eexists; split; tea. lia. } + Qed. + + Lemma interp_expr_inv {m le k} : + interp_expr (opt_valuation_of_model m) le = Some k -> + exists k', LevelMap.MapsTo le.1 (Some k') m /\ k = le.2 + valuation_of_value m k'. + Proof. + destruct le as [l k']. + rewrite /interp_expr /opt_valuation_of_model. + destruct (find_spec l m) => //. + destruct k0 => //; intros [= <-]. + exists z. split => //. + Qed. + Lemma check_clauses_Z_complete m cls : check_clauses m cls <-> valid_semilattice_entailments (clauses m) cls. Proof. @@ -1780,9 +1863,17 @@ Module Abstract. eapply Clauses.for_all_spec. tc. move=> cl /sem => semcl. destruct check eqn:hc => //. - * move/check_looping: hc. intros ne. elim ne. - exists (model_of m). split. red. admit. - apply m.(model_valid). + * move/check_entails_looping : hc. + rewrite -to_entails_all. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -ISL.completeness_all. + move/(_ Z _ (Z_valuation_of_model m)). + rewrite -interp_rels_clauses_sem. + move/(_ (model_valuation m)). + rewrite -interp_rels_clauses_sem. + rewrite clauses_sem_leq. cbn. + rewrite interp_add_prems //=. lia. * move/check_invalid: hc. move=> [m' [ism en inval]]. have vc := valid_clauses_model_opt m' (clauses m) ism. @@ -1793,77 +1884,26 @@ Module Abstract. unfold valid_clause in inval. rewrite mineq in inval. cbn in inval. elim inval. clear inval. cbn -[le] in semcl. - apply opt_semi_le_spec in semcl. destruct semcl. - { todo "premises not activated: impossible". } - destruct H as [y' [z' [eq [eq' le]]]]. - move: eq. - - rewrite /opt_valuation_of_model /level_value_above /level_value. - destruct LevelMap.find eqn:hl => //. - destruct o; cbn. - + intros [= <-]. apply Z.leb_le. - move: prems z' le eq' mineq. - apply: NES.elim. - { intros [l lk]. rewrite interp_prems_singleton min_premise_singleton //=. - rewrite /opt_valuation_of_model /level_value. - destruct (LevelMap.find l m') eqn:hl' => //=. destruct o => //. - cbn. intros z' le. intros [= <-]. intros [= <-]. lia. } - { intros le' x hi hnin z' le hadd. - have ha := (NES.interp_prems_add (SL := opt_semi) (opt_valuation_of_model m') le' x). - rewrite hadd in ha. cbn in ha. - destruct (interp_prems _ x); cbn in ha => //. - specialize (hi z' le). destruct (interp_expr) eqn:he; cbn in ha => //. - subst z'. rewrite min_premise_add. - destruct le'. move: he; cbn. rewrite /opt_valuation_of_model /level_value. - destruct (LevelMap.find t0 m') => //. destruct o => //. cbn. - intros [= <-]. destruct (min_premise m' x) eqn:hm'. intros [= <-]. - cbn in ha. in hadd. - } - - + have [iprems [eqiprems [[maxl [maxk [inmax [hmax eqmax]]]] hleprems]]] := min_premise_interp_prems_ex mineq. + rewrite eqiprems in semcl. subst iprems. + apply opt_semi_le_spec in semcl. destruct semcl => //. + destruct H as [y' [z' [eq [eq' le]]]]. noconf eq'. + destruct opt_valuation_of_model eqn:evconcl; noconf eq. + rename z into vconcl. + move/opt_valuation_of_model_inv: evconcl => [mconcl [hmconcl eq]]. + subst vconcl. + rewrite /level_value_above. + rewrite (level_value_MapsTo hmconcl). apply Z.leb_le. have [exm [[minl mink] [hin fmin]]] := min_premise_spec_aux _ _ _ mineq. - have hi := interp_prems_ge (SL := opt_semi) (opt_valuation_of_model m') _ _ hin. - rewrite eq' in hi. cbn in hi. - rewrite /opt_valuation_of_model in hi. - rewrite /min_atom_value /level_value in fmin. - move: hi fmin. - + destruct o; cbn. intros eqmax. move=> [=]. intros ->. - destruct (LevelMap.find concl _) eqn:hl' => //. - destruct o; cbn. intros [= <-]. - rewrite -eqmax in le. - move: le. - - constructor. - specialize (exm _ hin). depelim exm. rewrite /level_value hl in H0. noconf H0. - have hpos : 0 <= (Model.model_max m' - z0 - model_min m'). admit. - have hmin : model_min m' <= z0. admit. - have hmax : z0 <= Model.model_max m'. admit. - have hmin' : model_min m' <= z. admit. - have hmax' : z <= Model.model_max m'. admit. - lia. - - destruct (LevelMap.find minp m'). destruct o. - - - rewrite entails_L_rels_entails_L_clauses. - rewrite entails_L_entails_ℋ_equiv. - rewrite -completeness_all. - red. - intros ve. - eapply Forall_forall. intros [l r] hin. - apply relations_of_clauses_spec in hin as [prems [concl []]]. - noconf H0. red in ve. - have mv := model_valuation m. specialize (ve _ mv). - apply ve in H. cbn in H. - - specialize (ve (prems, concl)). apply ve in H. - apply syntax_model. - red. red. cbn. red in ve. - have hi := @interp_triv (relations_of_clauses (clauses m)) l. - red in hi. cbn in hi. - rewrite hi. - Qed. - + specialize (hleprems _ inmax). cbn in hleprems. + destruct hleprems as [minv [hminv [lei ge]]]. + eapply LevelMapFact.F.MapsTo_fun in hmax; tea. noconf hmax. + have exm' := (exm _ hin). depelim exm'. + rewrite /min_atom_value in fmin. destruct (level_value m' minl) eqn:hminl => //. + noconf fmin. noconf H0. + move: lei ge le0. + rewrite /valuation_of_value. lia. + Qed. End Abstract. End Deciders. From e377d187a132d008458faf5ab86501d7102a2a14 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 1 Oct 2025 17:40:34 +0200 Subject: [PATCH 084/164] Proven invariance by shifting --- common/theories/LoopChecking/Deciders.v | 292 ++++++++++++++++-- .../theories/LoopChecking/UnivLoopChecking.v | 130 +++++--- common/theories/uGraph.v | 17 +- 3 files changed, 347 insertions(+), 92 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index f8d780fee..4c267a72f 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -888,12 +888,75 @@ Module CorrectModel. let min := model_min m in max - n - min. + Lemma valuation_of_value_pos {l m n} : + model_min m = 0 -> + LevelMap.MapsTo l (Some n) m -> valuation_of_value m n >= 0. + Proof. + rewrite /valuation_of_value => hmin0 hm. + have hmax := model_max_spec m _ _ hm. + have hmin := model_min_spec m _ _ hm. + depelim hmax. lia. + Qed. + Definition opt_valuation_of_model (m : LevelMap.t (option Z)) l := match LevelMap.find l m with | Some (Some n) => Some (valuation_of_value m n) | _ => None end. + Lemma opt_valuation_of_model_pos {m l} : + model_min m = 0 -> forall k, opt_valuation_of_model m l = Some k -> k >= 0. + Proof. + rewrite /opt_valuation_of_model. + case: (find_spec l m) => //. + move=> [k|] hm min0 // k0 [=] <-. + now eapply valuation_of_value_pos. + Qed. + + Definition shift_model n (m : model) := + LevelMap.map (fun k => option_map (fun k => k + n) k) m. + + Lemma level_value_shift_model {n m l} : level_value (shift_model n m) l = option_map (fun v => v + n) (level_value m l). + Proof. + rewrite /shift_model /level_value LevelMapFact.F.map_o. + case: (find_spec l m) => //. + Qed. + + Lemma min_premise_shift {n m k u} : + min_premise (shift_model n m) u = Some k -> + min_premise m u = Some (k - n). + Proof. + move/min_premise_spec_aux => [hf [[minl mink] [hin heq]]]. + rewrite /min_atom_value level_value_shift_model in heq. + have [hf' [[minl' mink'] [hin' heq']]] := min_premise_spec m u. + rewrite /min_atom_value in heq'. + destruct (level_value m minl) eqn:hl => //. + cbn in heq. noconf heq. + specialize (hf' _ hin). + specialize (hf _ hin'). + rewrite /min_atom_value in hf'. + rewrite /min_atom_value level_value_shift_model in hf. + destruct (level_value m minl') eqn:hl'; cbn in *. + - rewrite heq'; f_equal. rewrite heq' in hf'. + rewrite hl in hf'. depelim hf. depelim hf'. lia. + - depelim hf. + Qed. + + Lemma shift_model_invariant {n m cls} : + is_model cls m -> + is_model cls (shift_model n m). + Proof. + rewrite /is_model. + move/Clauses.for_all_spec => ha. + apply Clauses.for_all_spec; tc. + move=> [prems [concl k]] /ha. clear. + move/valid_clause_elim => hz. + apply valid_clause_intro => z. + move/min_premise_shift /hz. + rewrite level_value_shift_model. + intros hle; depelim hle. rewrite H0 //=. constructor. lia. + Qed. + Lemma valid_clause_model_opt model cl : valid_clause model cl -> clause_sem (opt_valuation_of_model model) cl. @@ -1746,13 +1809,13 @@ Module Abstract. now rewrite //= !interp_rels_clauses_sem. Qed. - Definition valid_semilattice_entailment {S} {SL : Semilattice S Q.t} cls cl := + Definition valid_semilattice_entailment {S} (SL : Semilattice S Q.t) cls cl := (forall (v : Level.t -> S), clauses_sem v cls -> clause_sem v cl). - Definition valid_semilattice_entailments {S} {SL : Semilattice S Q.t} cls cls' := + Definition valid_semilattice_entailments {S} (SL : Semilattice S Q.t) cls cls' := (forall (v : Level.t -> S), clauses_sem v cls -> clauses_sem v cls'). - Infix "⊩Z" := valid_entailments (at level 70, no associativity). + Infix "⊩Z" := (valid_semilattice_entailments Zsemilattice) (at level 70, no associativity). Lemma opt_valuation_of_model_inv {m l k} : opt_valuation_of_model m l = Some k -> @@ -1847,8 +1910,48 @@ Module Abstract. exists z. split => //. Qed. + Definition enables_clause val cl := + exists k, interp_prems val (premise cl) = Some k. + + Definition enables_clauses val cls := Clauses.For_all (enables_clause val) cls. + + Theorem check_invalid_valuation {cls cl} : + check cls cl = Invalid -> + exists v : Level.t -> option Z, + clauses_sem v cls /\ ~ clause_sem v cl. + Proof. + move/check_invalid=> [m' [ism en inval]]. + have semcls := valid_clauses_model_opt _ _ ism. + exists (opt_valuation_of_model m'). split => // => semcl. + destruct cl as [prems [concl k]]. + cbn -[le] in semcl. + destruct en as [minp mineq]. cbn in mineq. + unfold valid_clause in inval. rewrite mineq in inval. cbn in inval. + elim inval. clear inval. + cbn -[le] in semcl. + have [iprems [eqiprems [[maxl [maxk [inmax [hmax eqmax]]]] hleprems]]] := min_premise_interp_prems_ex mineq. + rewrite eqiprems in semcl. subst iprems. + apply opt_semi_le_spec in semcl. destruct semcl => //. + destruct H as [y' [z' [eq [eq' le]]]]. noconf eq'. + destruct opt_valuation_of_model eqn:evconcl; noconf eq. + rename z into vconcl. + move/opt_valuation_of_model_inv: evconcl => [mconcl [hmconcl eq]]. + subst vconcl. + rewrite /level_value_above. + rewrite (level_value_MapsTo hmconcl). apply Z.leb_le. + have [exm [[minl mink] [hin fmin]]] := min_premise_spec_aux _ _ _ mineq. + specialize (hleprems _ inmax). cbn in hleprems. + destruct hleprems as [minv [hminv [lei ge]]]. + eapply LevelMapFact.F.MapsTo_fun in hmax; tea. noconf hmax. + have exm' := (exm _ hin). depelim exm'. + rewrite /min_atom_value in fmin. destruct (level_value m' minl) eqn:hminl => //. + noconf fmin. noconf H0. + move: lei ge le0. + rewrite /valuation_of_value. lia. + Qed. + Lemma check_clauses_Z_complete m cls : - check_clauses m cls <-> valid_semilattice_entailments (clauses m) cls. + check_clauses m cls <-> valid_semilattice_entailments opt_semi (clauses m) cls. Proof. split. - rewrite check_clauses_spec. @@ -1874,37 +1977,110 @@ Module Abstract. rewrite -interp_rels_clauses_sem. rewrite clauses_sem_leq. cbn. rewrite interp_add_prems //=. lia. - * move/check_invalid: hc. - move=> [m' [ism en inval]]. - have vc := valid_clauses_model_opt m' (clauses m) ism. - specialize (semcl (opt_valuation_of_model m') vc). - destruct cl as [prems [concl k]]. - cbn -[le] in semcl. - destruct en as [minp mineq]. cbn in mineq. - unfold valid_clause in inval. rewrite mineq in inval. cbn in inval. - elim inval. clear inval. - cbn -[le] in semcl. - have [iprems [eqiprems [[maxl [maxk [inmax [hmax eqmax]]]] hleprems]]] := min_premise_interp_prems_ex mineq. - rewrite eqiprems in semcl. subst iprems. - apply opt_semi_le_spec in semcl. destruct semcl => //. - destruct H as [y' [z' [eq [eq' le]]]]. noconf eq'. - destruct opt_valuation_of_model eqn:evconcl; noconf eq. - rename z into vconcl. - move/opt_valuation_of_model_inv: evconcl => [mconcl [hmconcl eq]]. - subst vconcl. - rewrite /level_value_above. - rewrite (level_value_MapsTo hmconcl). apply Z.leb_le. - have [exm [[minl mink] [hin fmin]]] := min_premise_spec_aux _ _ _ mineq. - specialize (hleprems _ inmax). cbn in hleprems. - destruct hleprems as [minv [hminv [lei ge]]]. - eapply LevelMapFact.F.MapsTo_fun in hmax; tea. noconf hmax. - have exm' := (exm _ hin). depelim exm'. - rewrite /min_atom_value in fmin. destruct (level_value m' minl) eqn:hminl => //. - noconf fmin. noconf H0. - move: lei ge le0. - rewrite /valuation_of_value. lia. + * move/check_invalid_valuation: hc. + move=> [v [semcls ncl]]. specialize (semcl v). elim ncl; now apply semcl. + Qed. + + Definition opt_val_of_Z_val (v : Level.t -> Z) : Level.t -> option Z := fun l => Some (v l). + + Definition Z_val_of_opt_val (v : Level.t -> option Z) : Level.t -> Z := fun l => option_get 0 (v l). + + Lemma interp_expr_opt {v e} : + interp_expr (opt_val_of_Z_val v) e = Some (interp_expr (SL := Zsemilattice) v e). + Proof. + destruct e; cbn; congruence. + Qed. + + Lemma interp_expr_opt_inv {v e z} : + interp_expr (SL := opt_semi) v e = Some z -> + interp_expr (Z_val_of_opt_val v) e = z. + Proof. + destruct e; cbn. rewrite /Z_val_of_opt_val. destruct (v t0) eqn:vt0 => //=. congruence. + Qed. + + Lemma interp_prems_add_Z {v le u} : NES.interp_prems (SL := Zsemilattice) v (NES.add le u) = + Z.max (interp_expr v le) (interp_prems v u). + Proof. + now rewrite interp_prems_add. Qed. + Lemma R_optP (x y : option Z) : reflectProp (R_opt eq x y) (eqb x y). + Proof. + destruct (eqb_spec x y); constructor. + - destruct x, y; cbn; try congruence. now noconf H. + - intros hr. destruct x, y; cbn; depelim hr; try congruence. + Qed. + + Lemma interp_prems_add_opt_Z {v le u} : NES.interp_prems (SL := opt_semi) v (NES.add le u) = + option_map2 Z.max (interp_expr v le) (interp_prems (SL := opt_semi) v u). + Proof. + have ha := interp_prems_add (SL := opt_semi) v le u. + move/R_optP: ha. move/(eqb_eq _ _). auto. + Qed. + + Lemma interp_prems_opt {v e} : + interp_prems (opt_val_of_Z_val v) e = Some (interp_prems v e). + Proof. + move: e; apply elim. + - intros []. now rewrite !interp_prems_singleton interp_expr_opt. + - intros le x h nin. + rewrite interp_prems_add_opt_Z interp_expr_opt h //=. + f_equal. now rewrite interp_prems_add. + Qed. + + Lemma interp_prems_opt_inv {v} {e z} : + interp_prems v e = Some z -> + interp_prems (Z_val_of_opt_val v) e = z. + Proof. + move: e z; apply: NES.elim. + - intros le z. rewrite !interp_prems_singleton. + now move/interp_expr_opt_inv. + - intros le x h nin z. + rewrite interp_prems_add_opt_Z interp_prems_add. + case he : interp_expr => //. 2:{ cbn. destruct interp_prems => //. } + move/interp_expr_opt_inv: he => ->. + case he' : interp_prems => //=. + move/h: he'. intros ->. congruence. + Qed. + + Lemma clause_sem_opt {v cl} : + clause_sem (opt_val_of_Z_val v) cl <-> clause_sem v cl. + Proof. + destruct cl as [prems concl]; rewrite /clause_sem interp_expr_opt interp_prems_opt. + now cbn. + Qed. + + Lemma clauses_sem_opt {v cls} : + clauses_sem (opt_val_of_Z_val v) cls <-> clauses_sem v cls. + Proof. + now split; move => h cl /h; rewrite clause_sem_opt. + Qed. + + (* Definition full_valuation V v := + forall l, LevelSet.In l V -> exists z, v l = Some z /\ + if l == Level.zero then z = 0 + else if Level.is_global l then z > 0 + else z >= 0. + + Definition valid_Z_semilattice_entailments cls cls' := + (forall (v : Level.t -> option Z), full_valuation (clauses_levels cls ∪ clauses_levels cls') v -> + clauses_sem v cls -> clauses_sem v cls'). + + + Lemma valid_entail_equiv {cls cls'} : + valid_semilattice_entailments opt_semi cls cls' <-> + valid_semilattice_entailments Zsemilattice cls cls'. + Proof. + split. + - intros ent v cs. + specialize (ent (opt_val_of_Z_val v)). + now rewrite !clauses_sem_opt in ent. + - move=> ent v cs. specialize (ent (Z_val_of_opt_val v)). + forward ent. move=> cl /cs. + destruct cl as [prems concl] => //=. + intros hm. rewrite interp_expr_opt interp_prems_opt //=. + move=> cl /ent. destruct cl as [prems concl] => //=. + Qed.*) End Abstract. End Deciders. @@ -2031,19 +2207,26 @@ Module LoopChecking (LS : LevelSets). Definition check m c := Impl.check_clauses m.(Impl.Abstract.clauses) (to_clauses c). + (* Checking corresponds to entailment in the free semilattice *) Lemma check_spec {m c} : check m c <-> entails_clauses (clauses m) (to_clauses c). Proof. apply check_clauses_spec. Qed. + (* Checking corresponds to validity in *all* semilattices, including degenerate ones. *) Lemma check_complete m c : check m c <-> valid_entailments (clauses m) (to_clauses c). Proof. apply check_clauses_complete. Qed. + (* Checking corresponds to validity in the lifted Z semilattice. *) + Lemma check_Z_complete m c : + check m c <-> valid_semilattice_entailments opt_semi (clauses m) (to_clauses c). + Proof. apply check_clauses_Z_complete. Qed. (* Returns the valuation of the model: a minimal assignement from levels to constraints that make the enforced clauses valid. *) Definition valuation m := to_val (Model.valuation_of_model (model m)). + (** This is a valuation in Z, which defaults to 0 for undefined universes. It enables all clauses. *) Definition model_valuation m : clauses_sem (to_Z_val (valuation m)) (clauses m). Proof. destruct m as [levels clauses []]; cbn. @@ -2053,6 +2236,49 @@ Module LoopChecking (LS : LevelSets). - apply model_valid. Qed. + Definition opt_valuation (m : t) := opt_valuation_of_model (model m). + + (** This is a valuation in Z⊥ *) + Definition model_opt_Z_valuation m : clauses_sem (opt_valuation m) (clauses m). + Proof. + apply valid_clauses_model_opt; tea; cbn. + apply model_valid. + Qed. + + Definition consistent_val val (cls : Clauses.t) := + enables_clauses val cls /\ clauses_sem val cls. + + Definition consistent cls := exists val : Level.t -> option Z, consistent_val val cls. + + Lemma opt_valuation_enables m : enables_clauses (opt_valuation m) (clauses m). + Proof. + have hen := enabled_model m. + have hupd := model_updates m.(model_valid). + eapply is_update_of_ext in hupd. + eapply enabled_clauses_ext in hen; tea. + move: hen. rewrite /clauses. + cbn. rewrite /opt_valuation /model /Impl.Abstract.model. + unfold Impl.CorrectModel.model_of. + generalize (model_model (model_valid m)). + generalize (Impl.Abstract.clauses m). + clear; intros cls m en. + move=> cl /en; clear. + destruct cl as [prems concl]; rewrite /enabled_clause /enables_clause; cbn. + intros [k hmin]. + move/min_premise_interp_prems_ex: hmin => [z [eq rest]]. now exists z. + Qed. + + Lemma clauses_consistent_val m : consistent_val (opt_valuation m) (clauses m). + Proof. + split. apply opt_valuation_enables. + apply model_opt_Z_valuation. + Qed. + + Lemma clauses_consistent m : consistent (clauses m). + Proof. + eexists; eapply clauses_consistent_val. + Qed. + Lemma zero_declared m : Impl.CorrectModel.zero_declared (model m). Proof. eapply zero_declared. Qed. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 1a97bfc28..38d1a3a3d 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -233,7 +233,6 @@ Module UnivLoopChecking. rewrite Universes.LevelExprSet.add_spec. now right. Qed. - Program Definition from_atoms (u : NES.t) : Universe.t := {| Universe.t_set := from_levelexprzset (NES.t_set u) |}. Next Obligation. @@ -243,6 +242,33 @@ Module UnivLoopChecking. apply from_levelexprzset_spec in hin. now apply he in hin. Qed. + Definition from_atom (le : LevelExprZ.t) := (le.1, Z.to_nat le.2). + + Lemma from_atoms_singleton l k : from_atoms (singleton (l, k)) = Universe.singleton (l, Z.to_nat k). + Proof. + apply Universe.equal_exprsets. + rewrite /from_atoms //=. + Qed. + + Lemma from_atoms_add le u : from_atoms (NES.add le u) = Universe.add (from_atom le) (from_atoms u). + Proof. apply Universe.equal_exprsets => //=. + move=> [l k]. + rewrite Universes.LevelExprSet.add_spec. + split. + - move/from_levelexprzset_spec_2 => [] z. + rewrite LevelExprZSet.add_spec => -[[<-|hin] eq]. subst k. + * left. cbn. lia_f_equal. rewrite /from_atom. now cbn. + * right. subst. + now apply from_levelexprzset_spec in hin. + - move=> [eq|hin]. + * destruct le; noconf eq. + apply from_levelexprzset_spec. cbn. + apply LevelExprZSet.add_spec. + now left. + * apply from_levelexprzset_spec_2 in hin as [hin [pos eq]]. subst k. + apply from_levelexprzset_spec. + apply LevelExprZSet.add_spec. now right. + Qed. Module ZUnivConstraint. Definition t : Type := NES.t * ConstraintType.t * NES.t. @@ -889,29 +915,32 @@ End ZUnivConstraint. - clear H Heqcall. reflexivity. Qed. - Definition valuation_to_Z (v : Universes.valuation) : Level.t -> Z := - fun l => Z.of_nat (val v l). + Definition valuation_to_Z (v : Universes.valuation) : Level.t -> option Z := + fun l => Some (Z.of_nat (val v l)). - Lemma interp_prems_valuation_to_Z v u : - interp_prems (valuation_to_Z v) (to_atoms u) = Z.of_nat (Universes.val v u). + Import LoopCheck.Impl.CorrectModel (opt_semi). + Existing Instance opt_semi. + + Lemma interp_prems_valuation_to_Z_to_atoms v u : + interp_prems (valuation_to_Z v) (to_atoms u) = Some (Z.of_nat (Universes.val v u)). Proof. move: u. apply: Universe.elim. - intros [l k]; rewrite to_atoms_singleton interp_prems_singleton //= val_singleton //=. - rewrite /valuation_to_Z. cbn. lia. + cbn; lia_f_equal. - intros [l k] x hx hnin. - rewrite to_atoms_add !interp_prems_add //= val_add //= /valuation_to_Z hx; cbn. - lia. + rewrite to_atoms_add !interp_prems_add_opt_Z //= val_add //= hx; cbn. + lia_f_equal. Qed. Lemma clauses_sem_satisfies0_equiv v cstr : clauses_sem (valuation_to_Z v) (LoopCheck.to_clauses (to_constraint cstr)) <-> satisfies0 v cstr. Proof. destruct cstr as [[l []] r]; cbn. - - rewrite clauses_sem_leq !interp_prems_valuation_to_Z. + - rewrite clauses_sem_leq !interp_prems_valuation_to_Z_to_atoms. split; cbn. * constructor; lia. * intros s; depelim s. lia. - - rewrite clauses_sem_eq !interp_prems_valuation_to_Z. + - rewrite clauses_sem_eq !interp_prems_valuation_to_Z_to_atoms. split; cbn. * constructor. lia. * intros s; depelim s. lia. @@ -946,13 +975,24 @@ End ZUnivConstraint. red in sat. now move/sat. Qed. + Lemma interp_prems_valuation_to_Z v u : + interp_prems (valuation_to_Z v) u <> None. + Proof. + move: u. + apply: NES.elim. + - intros [l k]. rewrite interp_prems_singleton //= val_singleton //=. + - intros [l k] x hx hnin. + rewrite !interp_prems_add_opt_Z //=. + destruct interp_prems => //. + Qed. + Lemma enforce_inconsistent m (c : UnivConstraint.t) u : UnivLoopChecking.enforce m c = Some (inr u) -> ~ exists v, satisfies v (UnivConstraintSet.add c (constraints m)). Proof. funelim (UnivLoopChecking.enforce m c) => //=. move=> [=]; intros <-; cbn. clear H Heqcall. intros [v sat]. - have he := LoopCheck.enforce_inconsistent eq0 Z Zsemilattice (valuation_to_Z v). + have he := LoopCheck.enforce_inconsistent eq0 (option Z) opt_semi (valuation_to_Z v). rewrite clauses_sem_union clauses_sem_satisfies0_equiv in he. rewrite UnivConstraintSetProp.add_union_singleton satisfies_union in sat. destruct sat as [satc satcs]. @@ -960,7 +1000,9 @@ End ZUnivConstraint. forward he. { split => //. now apply satisfies_clauses_sem_to_Z. } destruct loop0 as [u hu]. cbn in he. - apply clauses_sem_eq in he. rewrite interp_add_prems in he. cbn -[Z.add] in he. lia. + apply clauses_sem_eq in he. rewrite interp_add_prems in he. cbn -[Z.add] in he. + have hid := interp_prems_valuation_to_Z v u. + destruct interp_prems => //. cbn -[Z.add] in he. lia. Qed. Definition enforce_constraints_aux (g : option univ_model) (cstrs : UnivConstraintSet.t) : option univ_model := @@ -1675,6 +1717,8 @@ End ZUnivConstraint. Definition model_val (m : univ_model) := (LoopCheck.valuation m). + Definition model_opt_val (m : univ_model) := (LoopCheck.opt_valuation m). + Definition model_Z_val (m : univ_model) := (to_Z_val (LoopCheck.valuation m)). Lemma interp_rels_of_m m : interp_rels (model_Z_val m) (relations_of_constraints (to_z_cstrs (constraints m))). @@ -1699,7 +1743,7 @@ End ZUnivConstraint. Qed. (** The constraints in the model are already valid. *) - Lemma interp_univ_cstrs_of_m m : + Lemma interp_univ_cstrs_of_m_Z m : interp_univ_cstrs (model_Z_val m) (constraints m). Proof. intros uc hin. red. @@ -1770,7 +1814,7 @@ End ZUnivConstraint. Lemma interp_cstrs_of_m m : interp_cstrs (model_val m) (constraints m). Proof. - have ha := interp_univ_cstrs_of_m m. + have ha := interp_univ_cstrs_of_m_Z m. eapply interp_univ_cstrs_nat. - eapply wf_model_valuation. - move=> cstr /repr_constraints => hincl. @@ -1792,54 +1836,44 @@ End ZUnivConstraint. exact hv. Qed. + Existing Instance Impl.CorrectModel.opt_semi. Definition valid_Z_model m c := - (forall (v : Level.t -> Z), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + (forall (v : Level.t -> option Z), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). Infix "⊩Z" := valid_Z_model (at level 70, no associativity). Definition valid_Z_entailments p r := (forall (v : Level.t -> Z), interp_rels v p -> interp_rels v r). -(* - Lemma valid_Z_entails_L {p r} : - valid_Z_entailments p r -> p ⊩ℒ r. - Proof. - rewrite /valid_Z_entailments. - intros ha. - have ha' := entails_L_entails_ℋ_equiv. - Search entails. - - - apply syntax_model. - destruct r as [l r]. cbn. - Print ids. - change (eq (Semilattice := init_model p) (interp_prems (SL := init_model p) (ids p) l) (interp_prems (SL := init_model p) (ids p) r)). - specialize (ha _ (init_model p) (ids p) (interp_rels_init p)). - now cbn in ha. - Qed. *) - Theorem check_completeness {m c} : check m c <-> m ⊩Z c. Proof. - rewrite LoopCheck.check_complete /LoopCheck.valid_entailments /valid_model. - setoid_rewrite interp_cstrs_clauses_sem. - split. - - intros hv S s v hp. - move: (hv S s v hp). - now rewrite interp_cstr_clauses_sem. - - intros hs S SL V hsem. - move: (hs S SL V) => /fwd //. - now rewrite interp_cstr_clauses_sem. + rewrite LoopCheck.check_Z_complete /valid_semilattice_entailments /valid_Z_model. + now setoid_rewrite interp_cstrs_clauses_sem; setoid_rewrite interp_cstr_clauses_sem. + Qed. + + Lemma interp_univ_cstrs_of_m m : + interp_univ_cstrs (model_opt_val m) (constraints m). + Proof. + rewrite interp_cstrs_clauses_sem. + apply model_opt_Z_valuation. Qed. + (** The current model must already imply the constraint. Note that the converse + is not true: a constraint can be satisfied by chance in the model. *) + Theorem check_implies {m c} : + check m c -> interp_univ_cstr (opt_valuation m) c. + Proof. + now rewrite check_completeness => /(_ (opt_valuation m) (interp_univ_cstrs_of_m m)). + Qed. Definition valid_model m c := (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). Infix "⊩" := valid_model (at level 70, no associativity). - Theorem check_completeness {m c} : + Theorem check_any_completeness {m c} : check m c <-> m ⊩ c. Proof. rewrite LoopCheck.check_complete /LoopCheck.valid_entailments /valid_model. @@ -1898,10 +1932,13 @@ End ZUnivConstraint. apply constraint_levels_declared. Qed. + Definition to_nat_val (v : Level.t -> option Z) := + fun l => Z.to_nat (option_get 0%Z (v l)). + Theorem check_valid_nat {m c} : check m c -> (forall (v : Level.t -> nat), wf_valuation (levels m ∪ univ_constraint_levels c) v -> interp_cstrs v (constraints m) -> interp_nat_cstr v c). Proof. - rewrite check_completeness. + rewrite check_any_completeness. intros hv v wfv hp. have [wfm wfc] := wf_valuation_union wfv. move: (hv Z Zsemilattice (to_Z_val v)). @@ -1911,10 +1948,5 @@ End ZUnivConstraint. exact hp. destruct c as [[l d] r]; cbn. split; lsets. Qed. -(* - Theorem check_invalid_nat {m c} : - check m c = false -> (forall (v : Level.t -> nat), wf_valuation (levels m ∪ univ_constraint_levels c) v -> interp_cstrs v (constraints m) -> interp_nat_cstr v c -> False). - Proof. - *) End UnivLoopChecking. diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index 788407bd6..b8d0c0f52 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -225,27 +225,24 @@ Section CheckLeq. - rewrite check_completeness. intros mc. intros v sat. apply clauses_sem_satisfies0_equiv. - (* apply clauses_sem_satisfies_equiv in sat. *) red in mc. setoid_rewrite interp_cstrs_clauses_sem in mc. - specialize (mc Z _ (valuation_to_Z v)). + specialize (mc (valuation_to_Z v)). eapply interp_cstr_clauses_sem. apply mc. apply satisfies_clauses_sem_to_Z. destruct HG as [hlev hcstrs]. rewrite hcstrs. eapply satisfies_union. split => //. eapply satisfies_init. - - intros hv. red in hv. + - rewrite check_completeness. + intros hv. red in hv. have hi := interp_cstrs_of_m m. destruct HG as [hlev hcstrs]. rewrite hcstrs in hi. - - (* setoid_rewrite <- clauses_sem_satisfies0_equiv in hv. *) setoid_rewrite <- clauses_sem_satisfies_equiv in hv. - destruct HG as [hlev hcstrs]. - rewrite hcstrs in hcls. - - - (* rewrite interp_univ_cstrs_nat + red. intros v vcs. + rewrite interp_cstr_clauses_sem. + Search interp_univ_cstr. + rewrite interp_univ_cstrs_nat. setoid_rewrite interp_cstrs_clauses_sem in hcls. rewrite interp_cstr_clauses_sem. *) From a328f3711e44324336ef6113b2a3aca1ea1701c0 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 1 Oct 2025 19:04:29 +0200 Subject: [PATCH 085/164] Work to only talk about positive valuations --- common/theories/LoopChecking/Deciders.v | 207 +++++++++++++----- .../theories/LoopChecking/UnivLoopChecking.v | 36 ++- 2 files changed, 182 insertions(+), 61 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 4c267a72f..bf5c39f91 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -846,42 +846,45 @@ Module CorrectModel. Obligation Tactic := idtac. Import Semilattice (Semilattice, eq, add, join). - Equations? opt_semi : Semilattice (option Z) Z := + Context {S Q} {CM : CommutativeMonoid.IsCommMonoid Q} (SL : Semilattice S Q). + + Equations? opt_semi : Semilattice (option S) Q := opt_semi := {| - eq x y := R_opt Logic.eq x y; + eq x y := R_opt (@eq _ _ CM SL) x y; eq_equiv := _; - add n x := option_map (Z.add n) x; - join := option_map2 Z.max |}. + add n x := option_map (add n) x; + join := option_map2 join |}. Proof. all: intros. - split; red. - * intros x. destruct x => //. - * intros [x|] [y|]; cbn; auto. - * intros [x|] [y|] [z|]; cbn; auto. lia. - - destruct x => //=. lia. - - destruct x, y; cbn in *; lia. - - destruct x => //=. - - destruct x, y, z => //=. lia. - - destruct x, y => //=. lia. - - destruct x, x', y; cbn in *; lia. - - destruct x => //=. lia. - - destruct x => //=. lia. - - destruct x, y; cbn in *; lia. - - destruct x, y; cbn in *; lia. + * intros x. destruct x => //=. reflexivity. + * intros [x|] [y|]; cbn; auto. now symmetry. + * intros [x|] [y|] [z|]; cbn; auto. apply transitivity. + - destruct x => //=. now rewrite add_distr. + - destruct x, y; cbn in * => //. now apply add_congr. + - destruct x => //=. apply add_neutral. + - destruct x, y, z => //=. apply join_assoc. + - destruct x, y => //=. apply join_comm. + - destruct x, x', y; cbn in * => //. now apply join_congr. + - destruct x => //=. apply join_idem. + - destruct x => //=. apply join_sub. + - destruct x, y => //=; cbn in *. now eapply add_inj. + - destruct x, y => //=; cbn in *; now eapply add_join. Defined. - Existing Instance opt_semi. - Lemma opt_semi_le_spec {x y} : x ≤ y -> (y = None) \/ (exists x' y', x = Some x' /\ y = Some y' /\ x' <= y'). + + Lemma Zopt_semi_le_spec {x y : option S} : x ≤ y -> (y = None) \/ (exists x' y', x = Some x' /\ y = Some y' /\ le x' y'). Proof. rewrite /le. cbn. destruct x, y => //=. - - intros <-. right. exists z, (Z.max z z0). split => //. split => //. lia. + - intros hc. right. exists s, s0. split => //. - intros _. now left. - intros _. now left. Qed. End interp_semi. - Existing Instance opt_semi. + Definition Zopt_semi := opt_semi Zsemilattice. + Existing Instance Zopt_semi. Definition valuation_of_value m n := let max := model_max m in @@ -889,13 +892,13 @@ Module CorrectModel. max - n - min. Lemma valuation_of_value_pos {l m n} : - model_min m = 0 -> LevelMap.MapsTo l (Some n) m -> valuation_of_value m n >= 0. Proof. - rewrite /valuation_of_value => hmin0 hm. + rewrite /valuation_of_value => hm. have hmax := model_max_spec m _ _ hm. have hmin := model_min_spec m _ _ hm. - depelim hmax. lia. + depelim hmax. + have := model_min_spec2 m. lia. Qed. Definition opt_valuation_of_model (m : LevelMap.t (option Z)) l := @@ -904,12 +907,14 @@ Module CorrectModel. | _ => None end. - Lemma opt_valuation_of_model_pos {m l} : - model_min m = 0 -> forall k, opt_valuation_of_model m l = Some k -> k >= 0. + Definition positive_valuation (v : Level.t -> option Z) := + forall l k, v l = Some k -> k >= 0. + + Lemma opt_valuation_of_model_pos {m} : positive_valuation (opt_valuation_of_model m). Proof. - rewrite /opt_valuation_of_model. + rewrite /opt_valuation_of_model /positive_valuation => l k'. case: (find_spec l m) => //. - move=> [k|] hm min0 // k0 [=] <-. + move=> [k|] hm // [=] <-. now eapply valuation_of_value_pos. Qed. @@ -942,19 +947,74 @@ Module CorrectModel. - depelim hf. Qed. + Lemma min_premise_shift_inv {n m k u} : + min_premise m u = Some k -> + min_premise (shift_model n m) u = Some (n + k). + Proof. + move/min_premise_spec_aux => [hf [[minl mink] [hin heq]]]. + have [hf' [[minl' mink'] [hin' heq']]] := min_premise_spec (shift_model n m) u. + rewrite /min_atom_value level_value_shift_model in heq'. + destruct (level_value m minl') eqn:hl => //. + rewrite /min_atom_value in heq. + cbn in heq'. noconf heq'. + specialize (hf' _ hin). + specialize (hf _ hin'). + rewrite /min_atom_value in hf'. + rewrite /min_atom_value in hf. + destruct (level_value m minl) eqn:hl'; cbn in *. + - rewrite heq'; f_equal. rewrite heq' level_value_shift_model in hf'. + rewrite hl in hf. noconf heq. rewrite hl' in hf'. depelim hf. depelim hf'. lia. + - noconf heq. + - cbn in heq'. specialize (hf _ hin'). rewrite /min_atom_value hl //= in hf. depelim hf. + Qed. + + Lemma valid_clause_shift {n m cl} : valid_clause m cl <-> valid_clause (shift_model n m) cl. + Proof. + destruct cl as [prems [concl k]]. + split. + - move/valid_clause_elim => hz. + apply valid_clause_intro => z. + move/min_premise_shift /hz. + rewrite level_value_shift_model. + intros hle; depelim hle. rewrite H0 //=. constructor. lia. + - move/valid_clause_elim => hz. + apply valid_clause_intro => z. + move/min_premise_shift_inv /hz. + rewrite level_value_shift_model. + destruct (level_value m concl) => //=; + intros hle; depelim hle. constructor. lia. + Qed. + + Lemma enabled_clause_shift {n m cl} : enabled_clause m cl <-> enabled_clause (shift_model n m) cl. + Proof. + destruct cl as [prems [concl k]]. + split. + - move=> [] z. cbn. move/min_premise_shift_inv. + now eexists. + - move=> [] z; move/min_premise_shift. now eexists. + Qed. + Lemma shift_model_invariant {n m cls} : - is_model cls m -> + is_model cls m <-> is_model cls (shift_model n m). Proof. rewrite /is_model. - move/Clauses.for_all_spec => ha. - apply Clauses.for_all_spec; tc. - move=> [prems [concl k]] /ha. clear. - move/valid_clause_elim => hz. - apply valid_clause_intro => z. - move/min_premise_shift /hz. - rewrite level_value_shift_model. - intros hle; depelim hle. rewrite H0 //=. constructor. lia. + rewrite ![is_true _]Clauses.for_all_spec. + unfold Clauses.For_all. + now setoid_rewrite (@valid_clause_shift n m). + Qed. + + Lemma shift_model_min_pos {m} : model_min (shift_model (- model_min m) m) = 0. + Proof. + destruct (model_has_min (shift_model (- model_min m) m)) => //. + destruct H as [l [k [inshift eq]]]. + move: inshift. + rewrite /shift_model LevelMapFact.F.map_mapsto_iff => -[a [eq' hm]]. + destruct a; cbn in eq' => //. + noconf eq'. rewrite eq. + have msp := model_min_spec _ _ _ hm. + have m0 := model_min_spec2 m. + have m1 := model_min_spec2 (shift_model (- model_min m) m). lia. Qed. Lemma valid_clause_model_opt model cl : @@ -974,7 +1034,7 @@ Module CorrectModel. { cbn. subst v. unfold opt_valuation_of_model. move: hmin; rewrite /level_value; case: find_spec => //. move=> k hm. destruct k => //. } - move/opt_semi_le_spec. intros [] => //. + move/Zopt_semi_le_spec. intros [] => //. destruct H as [? [? []]]. congruence. } destruct interp_expr => //=. } destruct cl as [prems [concl k]]. cbn -[le]. @@ -1880,12 +1940,12 @@ Module Abstract. destruct (min_premise m u) => //. specialize (h _ eq_refl) as [z1 [? [[maxx [maxk [inmax [mmax maxle]]]]]]]. cbn. intros [= <-]. - have ha := (NES.interp_prems_add (SL := opt_semi) (opt_valuation_of_model m) (l, k) u). + have ha := (NES.interp_prems_add (SL := Zopt_semi) (opt_valuation_of_model m) (l, k) u). rewrite H in ha. have hminv := min_atom_value_mapsto hmin. cbn in hminv. cbn [interp_expr] in ha. rewrite (mapsto_opt_valuation_of_model hminv) in ha. - cbn [eq opt_semi] in ha. + cbn [eq Zopt_semi] in ha. destruct (interp_prems _ (NES.add _ _)); cbn in ha => //. subst z2. eexists; split; trea. split. @@ -1918,11 +1978,12 @@ Module Abstract. Theorem check_invalid_valuation {cls cl} : check cls cl = Invalid -> exists v : Level.t -> option Z, - clauses_sem v cls /\ ~ clause_sem v cl. + [/\ positive_valuation v, clauses_sem v cls & ~ clause_sem v cl]. Proof. move/check_invalid=> [m' [ism en inval]]. + have hpos := opt_valuation_of_model_pos. have semcls := valid_clauses_model_opt _ _ ism. - exists (opt_valuation_of_model m'). split => // => semcl. + exists (opt_valuation_of_model m'). split => // semcl. destruct cl as [prems [concl k]]. cbn -[le] in semcl. destruct en as [minp mineq]. cbn in mineq. @@ -1931,7 +1992,7 @@ Module Abstract. cbn -[le] in semcl. have [iprems [eqiprems [[maxl [maxk [inmax [hmax eqmax]]]] hleprems]]] := min_premise_interp_prems_ex mineq. rewrite eqiprems in semcl. subst iprems. - apply opt_semi_le_spec in semcl. destruct semcl => //. + apply Zopt_semi_le_spec in semcl. destruct semcl => //. destruct H as [y' [z' [eq [eq' le]]]]. noconf eq'. destruct opt_valuation_of_model eqn:evconcl; noconf eq. rename z into vconcl. @@ -1947,11 +2008,47 @@ Module Abstract. rewrite /min_atom_value in fmin. destruct (level_value m' minl) eqn:hminl => //. noconf fmin. noconf H0. move: lei ge le0. - rewrite /valuation_of_value. lia. + rewrite /valuation_of_value. unfold le, eq; cbn. lia. + Qed. + + Definition valid_clauses cls cls' := + forall v : Level.t -> option Z, + positive_valuation v -> + clauses_sem v cls -> clauses_sem v cls'. + + Lemma check_clauses_Z_positive_complete m cls : + check_clauses m cls <-> valid_clauses (clauses m) cls. + Proof. + split. + - rewrite check_clauses_spec. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -completeness_all. + move=> vr v. + red in vr. + move: (vr (option Z) Zopt_semi v). + rewrite !interp_rels_clauses_sem //. + - intros sem. unfold check_clauses, Deciders.check_clauses. + eapply Clauses.for_all_spec. tc. + move=> cl /sem => semcl. + destruct check eqn:hc => //. + * move/check_entails_looping : hc. + rewrite -to_entails_all. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -ISL.completeness_all. + move/(_ Z _ (Z_valuation_of_model m)). + rewrite -interp_rels_clauses_sem. + move/(_ (model_valuation m)). + rewrite -interp_rels_clauses_sem. + rewrite clauses_sem_leq. cbn. + rewrite interp_add_prems //=. lia. + * move/check_invalid_valuation: hc. + move=> [v [hpos semcls ncl]]. specialize (semcl v hpos semcls). now elim ncl. Qed. Lemma check_clauses_Z_complete m cls : - check_clauses m cls <-> valid_semilattice_entailments opt_semi (clauses m) cls. + check_clauses m cls <-> valid_semilattice_entailments Zopt_semi (clauses m) cls. Proof. split. - rewrite check_clauses_spec. @@ -1960,7 +2057,7 @@ Module Abstract. rewrite -completeness_all. move=> vr v. red in vr. - move: (vr (option Z) opt_semi v). + move: (vr (option Z) Zopt_semi v). rewrite !interp_rels_clauses_sem //. - intros sem. unfold check_clauses, Deciders.check_clauses. eapply Clauses.for_all_spec. tc. @@ -1978,7 +2075,7 @@ Module Abstract. rewrite clauses_sem_leq. cbn. rewrite interp_add_prems //=. lia. * move/check_invalid_valuation: hc. - move=> [v [semcls ncl]]. specialize (semcl v). elim ncl; now apply semcl. + move=> [v [_ semcls ncl]]. specialize (semcl v). elim ncl; now apply semcl. Qed. Definition opt_val_of_Z_val (v : Level.t -> Z) : Level.t -> option Z := fun l => Some (v l). @@ -1992,7 +2089,7 @@ Module Abstract. Qed. Lemma interp_expr_opt_inv {v e z} : - interp_expr (SL := opt_semi) v e = Some z -> + interp_expr (SL := Zopt_semi) v e = Some z -> interp_expr (Z_val_of_opt_val v) e = z. Proof. destruct e; cbn. rewrite /Z_val_of_opt_val. destruct (v t0) eqn:vt0 => //=. congruence. @@ -2011,10 +2108,10 @@ Module Abstract. - intros hr. destruct x, y; cbn; depelim hr; try congruence. Qed. - Lemma interp_prems_add_opt_Z {v le u} : NES.interp_prems (SL := opt_semi) v (NES.add le u) = - option_map2 Z.max (interp_expr v le) (interp_prems (SL := opt_semi) v u). + Lemma interp_prems_add_opt_Z {v le u} : NES.interp_prems (SL := Zopt_semi) v (NES.add le u) = + option_map2 Z.max (interp_expr v le) (interp_prems (SL := Zopt_semi) v u). Proof. - have ha := interp_prems_add (SL := opt_semi) v le u. + have ha := interp_prems_add (SL := Zopt_semi) v le u. move/R_optP: ha. move/(eqb_eq _ _). auto. Qed. @@ -2068,7 +2165,7 @@ Module Abstract. Lemma valid_entail_equiv {cls cls'} : - valid_semilattice_entailments opt_semi cls cls' <-> + valid_semilattice_entailments Zopt_semi cls cls' <-> valid_semilattice_entailments Zsemilattice cls cls'. Proof. split. @@ -2219,9 +2316,13 @@ Module LoopChecking (LS : LevelSets). (* Checking corresponds to validity in the lifted Z semilattice. *) Lemma check_Z_complete m c : - check m c <-> valid_semilattice_entailments opt_semi (clauses m) (to_clauses c). + check m c <-> valid_semilattice_entailments Zopt_semi (clauses m) (to_clauses c). Proof. apply check_clauses_Z_complete. Qed. + Lemma check_Z_complete_positive m c : + check m c <-> valid_clauses (clauses m) (to_clauses c). + Proof. apply check_clauses_Z_positive_complete. Qed. + (* Returns the valuation of the model: a minimal assignement from levels to constraints that make the enforced clauses valid. *) Definition valuation m := to_val (Model.valuation_of_model (model m)). diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 38d1a3a3d..e1d56d042 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -918,8 +918,8 @@ End ZUnivConstraint. Definition valuation_to_Z (v : Universes.valuation) : Level.t -> option Z := fun l => Some (Z.of_nat (val v l)). - Import LoopCheck.Impl.CorrectModel (opt_semi). - Existing Instance opt_semi. + Import LoopCheck.Impl.CorrectModel (Zopt_semi). + Existing Instance Zopt_semi. Lemma interp_prems_valuation_to_Z_to_atoms v u : interp_prems (valuation_to_Z v) (to_atoms u) = Some (Z.of_nat (Universes.val v u)). @@ -992,7 +992,7 @@ End ZUnivConstraint. funelim (UnivLoopChecking.enforce m c) => //=. move=> [=]; intros <-; cbn. clear H Heqcall. intros [v sat]. - have he := LoopCheck.enforce_inconsistent eq0 (option Z) opt_semi (valuation_to_Z v). + have he := LoopCheck.enforce_inconsistent eq0 (option Z) Zopt_semi (valuation_to_Z v). rewrite clauses_sem_union clauses_sem_satisfies0_equiv in he. rewrite UnivConstraintSetProp.add_union_singleton satisfies_union in sat. destruct sat as [satc satcs]. @@ -1836,10 +1836,29 @@ End ZUnivConstraint. exact hv. Qed. - Existing Instance Impl.CorrectModel.opt_semi. + Existing Instance Impl.CorrectModel.Zopt_semi. + + Instance nat_opt_semi : Semilattice (option nat) nat := Impl.CorrectModel.opt_semi Natsemilattice. + + Import Impl.CorrectModel (positive_valuation, opt_valuation_of_model_pos). Definition valid_Z_model m c := - (forall (v : Level.t -> option Z), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + (forall (v : Level.t -> option Z), positive_valuation v -> interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + + Definition valid_nat_model m c := + (forall (v : Level.t -> option nat), interp_cstrs v (constraints m) -> interp_nat_cstr v c). + + Lemma valid_Z_pos_nat_model m c : valid_Z_model m c <-> valid_nat_model m c. + Proof. + split. + - intros vz v ic. + specialize (vz (fun l => option_map Z.of_nat (v l))). + forward vz. { red. intros. destruct (v l); noconf H. lia. } + rewrite -interp_univ_cstr_nat. + Search interp_nat_cstr. + Qed. + + Infix "⊩Z" := valid_Z_model (at level 70, no associativity). @@ -1849,8 +1868,9 @@ End ZUnivConstraint. Theorem check_completeness {m c} : check m c <-> m ⊩Z c. Proof. - rewrite LoopCheck.check_Z_complete /valid_semilattice_entailments /valid_Z_model. - now setoid_rewrite interp_cstrs_clauses_sem; setoid_rewrite interp_cstr_clauses_sem. + rewrite LoopCheck.check_Z_complete_positive /valid_semilattice_entailments /valid_Z_model. + setoid_rewrite interp_cstrs_clauses_sem; setoid_rewrite interp_cstr_clauses_sem. + now rewrite /valid_clauses. Qed. Lemma interp_univ_cstrs_of_m m : @@ -1865,7 +1885,7 @@ End ZUnivConstraint. Theorem check_implies {m c} : check m c -> interp_univ_cstr (opt_valuation m) c. Proof. - now rewrite check_completeness => /(_ (opt_valuation m) (interp_univ_cstrs_of_m m)). + now rewrite check_completeness => /(_ (opt_valuation m) (opt_valuation_of_model_pos) (interp_univ_cstrs_of_m m)). Qed. Definition valid_model m c := From 87f1db1740bf51055fd0a724845db106ec8127fc Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 2 Oct 2025 13:46:07 +0200 Subject: [PATCH 086/164] WIP doing the partial/non-partial switch at the clauses level already --- common/theories/LoopChecking/Deciders.v | 175 ++++++++++++++++++++---- 1 file changed, 148 insertions(+), 27 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index bf5c39f91..ab2f85b43 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -1887,6 +1887,19 @@ Module Abstract. exists z. split => //. Qed. + Lemma valuation_of_model_inv {m l k} : + LevelMap.MapsTo l k (valuation_of_model m) -> + exists k', LevelMap.MapsTo l k' m /\ k = Z.to_nat (valuation_of_value m (option_get 0%Z k')). + Proof. + (* destruct k. *) + (* move/valuation_of_model_spec. + rewrite /valuation_of_model. + destruct (find_spec l m) => //. + destruct k0 => //; intros [= <-]. + exists z. split => //. *) + Admitted. + + Lemma mapsto_opt_valuation_of_model {m l k} : LevelMap.MapsTo l (Some k) m -> opt_valuation_of_model m l = Some (valuation_of_value m k). @@ -1975,20 +1988,109 @@ Module Abstract. Definition enables_clauses val cls := Clauses.For_all (enables_clause val) cls. - Theorem check_invalid_valuation {cls cl} : - check cls cl = Invalid -> - exists v : Level.t -> option Z, - [/\ positive_valuation v, clauses_sem v cls & ~ clause_sem v cl]. + Definition valuation_of_model model := + to_Z_val (to_val (Model.valuation_of_model model)). + + Lemma interp_expr_defined {model} le : + defined_model_of (LevelSet.singleton le.1) model -> + interp_expr (opt_valuation_of_model model) le = Some (interp_expr (valuation_of_model model) le). Proof. - move/check_invalid=> [m' [ism en inval]]. - have hpos := opt_valuation_of_model_pos. - have semcls := valid_clauses_model_opt _ _ ism. - exists (opt_valuation_of_model m'). split => // semcl. + destruct le as [l k]; cbn. + move => /(_ l) => /fwd. lsets. + move=> [v hm]. + have := (@opt_valuation_of_model_pos model l). + rewrite /opt_valuation_of_model /valuation_of_model /to_val /to_Z_val. + rewrite (LevelMap.find_1 hm). cbn. + eapply Model.valuation_of_model_spec in hm. + rewrite (LevelMap.find_1 hm). cbn. + rewrite /valuation_of_value. cbn. + intros h; specialize (h _ eq_refl). + f_equal. lia. + Qed. + + Lemma R_optP (x y : option Z) : reflectProp (R_opt eq x y) (eqb x y). + Proof. + destruct (eqb_spec x y); constructor. + - destruct x, y; cbn; try congruence. now noconf H. + - intros hr. destruct x, y; cbn; depelim hr; try congruence. + Qed. + + Lemma interp_prems_add_opt_Z {v le u} : NES.interp_prems (SL := Zopt_semi) v (NES.add le u) = + option_map2 Z.max (interp_expr v le) (interp_prems (SL := Zopt_semi) v u). + Proof. + have ha := interp_prems_add (SL := Zopt_semi) v le u. + move/R_optP: ha. move/(eqb_eq _ _). auto. + Qed. + + Lemma interp_prems_defined {m} (u : NES.t) : + defined_model_of (NES.levels u) m -> + interp_prems (opt_valuation_of_model m) u = Some (interp_prems (valuation_of_model m) u). + Proof. + move: u. + apply: elim. + - intros [l k] => //= hin. + rewrite !interp_prems_singleton. + rewrite levels_singleton in hin. + rewrite interp_expr_defined //. + - move=> le x eq wf def. + forward eq. move: def. rewrite /defined_model_of. + move=> h l hin. apply h. rewrite levels_add. lsets. + rewrite interp_prems_add_opt_Z eq interp_expr_defined. + { intros l; move: (def l) => h hin; apply h. rewrite levels_add. rsets. now left. } + cbn. now rewrite interp_prems_add. + Qed. + + Lemma clause_sem_defined_valid_all {model cl} : + defined_model_of (clause_levels cl) model -> + clause_sem (to_Z_val (to_val (Model.valuation_of_model model))) cl -> valid_clause model cl. + Proof. + intros def semcl. Print clause_sem. destruct cl as [prems [concl k]]. cbn -[le] in semcl. - destruct en as [minp mineq]. cbn in mineq. - unfold valid_clause in inval. rewrite mineq in inval. cbn in inval. - elim inval. clear inval. + apply valid_clause_intro => minp mineq. + cbn -[le] in semcl. + have [iprems [eqiprems [[maxl [maxk [inmax [hmax eqmax]]]] hleprems]]] := min_premise_interp_prems_ex mineq. + have he : interp_prems (valuation_of_model model) prems = iprems. + { rewrite interp_prems_defined in eqiprems. + intros l hin; apply (def l). rewrite /clause_levels //=. lsets. congruence. } + rewrite he in semcl. + move: semcl. + rewrite /to_Z_val /to_val. + case: (find_spec concl (Model.valuation_of_model _)) => [vconcl|] hmconcl. + 2:{ elim hmconcl. move:(def concl); rewrite clause_levels_spec. firstorder. + eexists. now eapply valuation_of_model_spec. } + have [vconclm [hmconcl' heqn]] := valuation_of_model_inv hmconcl. + subst vconcl. + rewrite /level_value_above. + rewrite (level_value_MapsTo hmconcl'). + have [exm [[minl mink] [hin fmin]]] := min_premise_spec_aux _ _ _ mineq. + specialize (hleprems _ inmax). cbn in hleprems. + destruct hleprems as [minv [hminv [lei ge]]]. + eapply LevelMapFact.F.MapsTo_fun in hmax; tea. noconf hmax. + have exm' := (exm _ hin). depelim exm'. + rewrite /min_atom_value in fmin. destruct (level_value model minl) eqn:hminl => //. + noconf fmin. noconf H0. + destruct vconclm. + - constructor. cbn in hmconcl. + move: lei ge. rewrite eqmax. + rewrite /valuation_of_value. unfold le, eq; cbn. cbn in semcl. + have valpos := valuation_of_value_pos hmconcl'. + move: semcl. rewrite Z2Nat.id. lia. subst iprems. + unfold valuation_of_value. lia. + - move: (def concl) => /fwd. + rewrite clause_levels_spec. cbn. now right. + intros [? hm]. eapply LevelMapFact.F.MapsTo_fun in hmconcl'; tea. congruence. + Qed. + + clause_sem_defined_valid_all + + Lemma clause_sem_valid {model cl} : + clause_sem (opt_valuation_of_model model) cl -> valid_clause model cl. + Proof. + intros semcl. + destruct cl as [prems [concl k]]. + cbn -[le] in semcl. + apply valid_clause_intro => minp mineq. cbn -[le] in semcl. have [iprems [eqiprems [[maxl [maxk [inmax [hmax eqmax]]]] hleprems]]] := min_premise_interp_prems_ex mineq. rewrite eqiprems in semcl. subst iprems. @@ -1999,18 +2101,51 @@ Module Abstract. move/opt_valuation_of_model_inv: evconcl => [mconcl [hmconcl eq]]. subst vconcl. rewrite /level_value_above. - rewrite (level_value_MapsTo hmconcl). apply Z.leb_le. + rewrite (level_value_MapsTo hmconcl). constructor. have [exm [[minl mink] [hin fmin]]] := min_premise_spec_aux _ _ _ mineq. specialize (hleprems _ inmax). cbn in hleprems. destruct hleprems as [minv [hminv [lei ge]]]. eapply LevelMapFact.F.MapsTo_fun in hmax; tea. noconf hmax. have exm' := (exm _ hin). depelim exm'. - rewrite /min_atom_value in fmin. destruct (level_value m' minl) eqn:hminl => //. + rewrite /min_atom_value in fmin. destruct (level_value model minl) eqn:hminl => //. noconf fmin. noconf H0. move: lei ge le0. rewrite /valuation_of_value. unfold le, eq; cbn. lia. Qed. + Lemma clauses_sem_valid {model cls} : + clauses_sem (opt_valuation_of_model model) cls <-> is_model cls model. + Proof. + rewrite is_model_valid. split. + intros clssem. red. move=> cl /clssem. apply clause_sem_valid. + move=> vm cl /vm. apply valid_clause_model_opt. + Qed. + + Lemma clauses_sem_all_valid {model cls} : + defined_model_of (clauses_levels cls) model -> + clauses_sem (to_Z_val (to_val (valuation_of_model model))) cls <-> is_model cls model. + Proof. + intros def. + rewrite is_model_valid. split. + intros clssem. red. move=> cl /clssem. apply clause_sem_valid. + move=> vm cl /vm. apply valid_clause_model_opt. + Qed. + + + (* cls ⊭ x >= y, so cls + x < y is consistent, validates all clauses *) + + Theorem check_invalid_valuation {cls cl} : + check cls cl = Invalid -> + exists v : Level.t -> option Z, + [/\ positive_valuation v, clauses_sem v cls & ~ clause_sem v cl]. + Proof. + move/check_invalid=> [m' [ism en inval]]. + have hpos := opt_valuation_of_model_pos. + have semcls := valid_clauses_model_opt _ _ ism. + exists (opt_valuation_of_model m'). split => // semcl. + apply clause_sem_valid in semcl. contradiction. + Qed. + Definition valid_clauses cls cls' := forall v : Level.t -> option Z, positive_valuation v -> @@ -2101,20 +2236,6 @@ Module Abstract. now rewrite interp_prems_add. Qed. - Lemma R_optP (x y : option Z) : reflectProp (R_opt eq x y) (eqb x y). - Proof. - destruct (eqb_spec x y); constructor. - - destruct x, y; cbn; try congruence. now noconf H. - - intros hr. destruct x, y; cbn; depelim hr; try congruence. - Qed. - - Lemma interp_prems_add_opt_Z {v le u} : NES.interp_prems (SL := Zopt_semi) v (NES.add le u) = - option_map2 Z.max (interp_expr v le) (interp_prems (SL := Zopt_semi) v u). - Proof. - have ha := interp_prems_add (SL := Zopt_semi) v le u. - move/R_optP: ha. move/(eqb_eq _ _). auto. - Qed. - Lemma interp_prems_opt {v e} : interp_prems (opt_val_of_Z_val v) e = Some (interp_prems v e). Proof. From 5460692d58b2c3a6f1bd1ee8a06f478e02f3453d Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 2 Oct 2025 13:55:23 +0200 Subject: [PATCH 087/164] Proven equivalence for defined valuations --- common/theories/LoopChecking/Deciders.v | 67 +++++++------------ .../theories/LoopChecking/UnivLoopChecking.v | 4 +- common/theories/uGraph.v | 22 ++++-- 3 files changed, 42 insertions(+), 51 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index ab2f85b43..0700c6163 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -2042,47 +2042,29 @@ Module Abstract. Lemma clause_sem_defined_valid_all {model cl} : defined_model_of (clause_levels cl) model -> - clause_sem (to_Z_val (to_val (Model.valuation_of_model model))) cl -> valid_clause model cl. + clause_sem (valuation_of_model model) cl <-> clause_sem (opt_valuation_of_model model) cl. Proof. - intros def semcl. Print clause_sem. + intros def. destruct cl as [prems [concl k]]. - cbn -[le] in semcl. - apply valid_clause_intro => minp mineq. - cbn -[le] in semcl. - have [iprems [eqiprems [[maxl [maxk [inmax [hmax eqmax]]]] hleprems]]] := min_premise_interp_prems_ex mineq. - have he : interp_prems (valuation_of_model model) prems = iprems. - { rewrite interp_prems_defined in eqiprems. - intros l hin; apply (def l). rewrite /clause_levels //=. lsets. congruence. } - rewrite he in semcl. - move: semcl. - rewrite /to_Z_val /to_val. - case: (find_spec concl (Model.valuation_of_model _)) => [vconcl|] hmconcl. - 2:{ elim hmconcl. move:(def concl); rewrite clause_levels_spec. firstorder. - eexists. now eapply valuation_of_model_spec. } - have [vconclm [hmconcl' heqn]] := valuation_of_model_inv hmconcl. - subst vconcl. - rewrite /level_value_above. - rewrite (level_value_MapsTo hmconcl'). - have [exm [[minl mink] [hin fmin]]] := min_premise_spec_aux _ _ _ mineq. - specialize (hleprems _ inmax). cbn in hleprems. - destruct hleprems as [minv [hminv [lei ge]]]. - eapply LevelMapFact.F.MapsTo_fun in hmax; tea. noconf hmax. - have exm' := (exm _ hin). depelim exm'. - rewrite /min_atom_value in fmin. destruct (level_value model minl) eqn:hminl => //. - noconf fmin. noconf H0. - destruct vconclm. - - constructor. cbn in hmconcl. - move: lei ge. rewrite eqmax. - rewrite /valuation_of_value. unfold le, eq; cbn. cbn in semcl. - have valpos := valuation_of_value_pos hmconcl'. - move: semcl. rewrite Z2Nat.id. lia. subst iprems. - unfold valuation_of_value. lia. - - move: (def concl) => /fwd. - rewrite clause_levels_spec. cbn. now right. - intros [? hm]. eapply LevelMapFact.F.MapsTo_fun in hmconcl'; tea. congruence. + rewrite /clause_sem. rewrite interp_prems_defined. + { intros l hin; apply def. rewrite /clause_levels //=. lsets. } + rewrite interp_expr_defined. + { intros l hin; apply def; rewrite /clause_levels //=. cbn in hin. lsets. } + now cbn. Qed. - clause_sem_defined_valid_all + Lemma clauses_sem_def_equiv {model cls} : + defined_model_of (clauses_levels cls) model -> + clauses_sem (valuation_of_model model) cls <-> clauses_sem (opt_valuation_of_model model) cls. + Proof. + intros def. + rewrite /clauses_sem. red in def. + split; move=> ha cl /[dup]/ha cs hin. + rewrite -clause_sem_defined_valid_all //. + { intros l hin'; apply def. eapply clauses_levels_spec. now exists cl. } + rewrite clause_sem_defined_valid_all //. + { intros l hin'; apply def. eapply clauses_levels_spec. now exists cl. } + Qed. Lemma clause_sem_valid {model cl} : clause_sem (opt_valuation_of_model model) cl -> valid_clause model cl. @@ -2121,17 +2103,14 @@ Module Abstract. move=> vm cl /vm. apply valid_clause_model_opt. Qed. - Lemma clauses_sem_all_valid {model cls} : + Lemma def_clauses_sem_valid {model cls} : defined_model_of (clauses_levels cls) model -> - clauses_sem (to_Z_val (to_val (valuation_of_model model))) cls <-> is_model cls model. + clauses_sem (valuation_of_model model) cls <-> is_model cls model. Proof. - intros def. - rewrite is_model_valid. split. - intros clssem. red. move=> cl /clssem. apply clause_sem_valid. - move=> vm cl /vm. apply valid_clause_model_opt. + intros def. rewrite clauses_sem_def_equiv //. + apply clauses_sem_valid. Qed. - (* cls ⊭ x >= y, so cls + x < y is consistent, validates all clauses *) Theorem check_invalid_valuation {cls cl} : diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index e1d56d042..84e2a0e83 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -1845,7 +1845,7 @@ End ZUnivConstraint. Definition valid_Z_model m c := (forall (v : Level.t -> option Z), positive_valuation v -> interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). - Definition valid_nat_model m c := + (* Definition valid_nat_model m c := (forall (v : Level.t -> option nat), interp_cstrs v (constraints m) -> interp_nat_cstr v c). Lemma valid_Z_pos_nat_model m c : valid_Z_model m c <-> valid_nat_model m c. @@ -1856,7 +1856,7 @@ End ZUnivConstraint. forward vz. { red. intros. destruct (v l); noconf H. lia. } rewrite -interp_univ_cstr_nat. Search interp_nat_cstr. - Qed. + Qed. *) diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index b8d0c0f52..7767d0fbb 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -217,6 +217,11 @@ Section CheckLeq. exact p. Qed. + Lemma posv v : LoopCheck.Impl.CorrectModel.positive_valuation (valuation_to_Z v). + Proof. + red. intros l k. unfold valuation_to_Z. intros [= <-]. lia. + Qed. + Lemma checkb_spec : check_spec checkb. Proof. intros c decl. @@ -228,21 +233,28 @@ Section CheckLeq. red in mc. setoid_rewrite interp_cstrs_clauses_sem in mc. specialize (mc (valuation_to_Z v)). - eapply interp_cstr_clauses_sem. apply mc. + eapply interp_cstr_clauses_sem. apply mc. apply posv. apply satisfies_clauses_sem_to_Z. destruct HG as [hlev hcstrs]. rewrite hcstrs. eapply satisfies_union. split => //. eapply satisfies_init. - rewrite check_completeness. intros hv. red in hv. - have hi := interp_cstrs_of_m m. destruct HG as [hlev hcstrs]. - rewrite hcstrs in hi. + rewrite valid_Z_pos_nat_model => v. + rewrite hcstrs. + erewrite <-interp_univ_cstrs_nat. + Search wf_valuation. + rewrite interp_cstrs_union. + specialize (hv (valuation_of_opt_nat v)). + intros interp. + rewrite -interp_univ_cstrs_nat in interp. + + setoid_rewrite <- clauses_sem_satisfies_equiv in hv. red. intros v vcs. rewrite interp_cstr_clauses_sem. - Search interp_univ_cstr. - rewrite interp_univ_cstrs_nat. + Search interp_univ_cstrs. setoid_rewrite interp_cstrs_clauses_sem in hcls. rewrite interp_cstr_clauses_sem. *) From 61020aefb19b5eaee1d2c2fd80c0e70010048d5a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 3 Oct 2025 07:49:42 +0200 Subject: [PATCH 088/164] Renamings, simplifications --- common/theories/LoopChecking/Common.v | 12 +- common/theories/LoopChecking/Deciders.v | 235 ++++++++++-------- common/theories/LoopChecking/HornClauses.v | 28 +-- .../LoopChecking/InitialSemilattice.v | 20 +- common/theories/LoopChecking/Model.v | 12 +- common/theories/LoopChecking/ModelValuation.v | 14 +- .../theories/LoopChecking/OldPresentation.v | 2 +- .../LoopChecking/PartialLoopChecking.v | 1 - .../theories/LoopChecking/UnivLoopChecking.v | 105 ++++---- common/theories/uGraph.v | 1 + oldLoopChecking.v | 50 ++-- template-rocq/theories/Junk.v | 2 +- utils/theories/MROption.v | 28 +++ utils/theories/NonEmptyLevelExprSet.v | 78 +++--- utils/theories/SemiLattice.v | 127 +++++++++- 15 files changed, 432 insertions(+), 283 deletions(-) diff --git a/common/theories/LoopChecking/Common.v b/common/theories/LoopChecking/Common.v index f2864e08f..4e9f66ca0 100644 --- a/common/theories/LoopChecking/Common.v +++ b/common/theories/LoopChecking/Common.v @@ -4,7 +4,6 @@ From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils NonEmptyLevelExprSet SemiLattice. -From MetaRocq.Common Require Universes. From Equations Require Import Equations. Set Equations Transparent. @@ -18,14 +17,6 @@ Next Obligation. destruct (Z.eqb_spec x y); constructor => //. Qed. -Definition option_map2 {A} (f : A -> A -> A) (o o' : option A) : option A := - match o, o' with - | Some x, Some y => Some (f x y) - | None, Some _ - | Some _, None - | None, None => None - end. - Derive Signature for InA. Lemma eqlistA_eq {A} (l l' : list A) : eqlistA Logic.eq l l' -> l = l'. @@ -58,6 +49,9 @@ Proof. now transitivity y. Qed. +Lemma opt_le_some_inv {A} (le : relation A) {x y} : opt_le le (Some x) (Some y) -> le x y. +Proof. now intros h; depelim h. Qed. + Instance option_map_2_comm {A} f : @Commutative A f -> @Commutative (option A) (option_map2 f). Proof. intros com [x|] [y|] => //=. now rewrite comm. diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 0700c6163..29f4f8afb 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -5,7 +5,7 @@ From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils MRClasses SemiLattice. -From MetaRocq.Common Require UnivConstraintType Universes. +From MetaRocq.Common Require UnivConstraintType. From Equations Require Import Equations. From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model Models PartialLoopChecking InitialSemilattice HornSemilatticeEquiv. @@ -260,13 +260,14 @@ Proof. move: (hcl (singleton le, succ_expr le)) => /fwd. { exists (succ_expr le). split => //. apply In_add_prems. exists le; split => //. now apply LevelExprSet.singleton_spec. } - move=> [z [hmin hleq]]. cbn in hleq. - depelim hleq. cbn in H0. + move=> [z [hmin hleq]]. cbn -[Z.add] in hleq. rewrite min_premise_singleton /min_atom_value in hmin. - destruct le as [l k]. cbn -[Z.add] in *. rewrite H0 in hmin. noconf hmin. lia. + destruct le as [l k]. cbn -[Z.add] in *. + destruct (level_value m l) eqn:hl => //. noconf hmin. + apply opt_le_some_inv in hleq. lia. - intros le x en hnin h. apply en. intros cl [lk [hin eq]]. subst cl. - eapply In_add_prems in hin as [? []]. subst lk. cbn. + eapply In_add_prems in hin as [? []]. subst lk. rewrite /concl. cbn. move: (h (add le x, succ_expr x0)) => /fwd. { exists (succ_expr x0). split => //. apply In_add_prems. exists x0. split => //. @@ -781,13 +782,13 @@ Module CorrectModel. Definition clause_sem {S} {SL : Semilattice S Q.t} (V : Level.t -> S) (cl : clause) : Prop := let '(prems, concl) := cl in - le (interp_expr V concl) (interp_prems V prems). + le (interp_expr V concl) (interp_nes V prems). Definition clauses_sem {S} {SL : Semilattice S Q.t} (V : Level.t -> S) (cls : Clauses.t) : Prop := Clauses.For_all (clause_sem V) cls. Instance clauses_sem_proper {S} {SL : Semilattice S Q.t} : - Proper (Logic.eq ==> Clauses.Equal ==> iff) clauses_sem. + Proper (Logic.eq ==> Clauses.Equal ==> iff) (clauses_sem (S:=S)). Proof. move=> ?? -> ?? h. rewrite /clauses_sem. @@ -795,7 +796,7 @@ Module CorrectModel. Qed. Lemma clauses_sem_singleton {S} {SL : Semilattice S Q.t} {V cl} : - clauses_sem V (Clauses.singleton cl) <-> clause_sem V cl. + clauses_sem (S:=S) V (Clauses.singleton cl) <-> clause_sem V cl. Proof. rewrite /clauses_sem /Clauses.For_all. split; firstorder. apply H. clsets. @@ -803,7 +804,7 @@ Module CorrectModel. Qed. Lemma clauses_sem_add {S} {SL : Semilattice S Q.t} {V cl cls} : - clauses_sem V (Clauses.add cl cls) <-> clause_sem V cl /\ clauses_sem V cls. + clauses_sem (S:=S) V (Clauses.add cl cls) <-> clause_sem V cl /\ clauses_sem V cls. Proof. rewrite /clauses_sem /Clauses.For_all. split. @@ -815,7 +816,7 @@ Module CorrectModel. Qed. Lemma clauses_sem_union {S} {SL : Semilattice S Q.t} {V cls cls'} : - clauses_sem V (Clauses.union cls cls') <-> clauses_sem V cls /\ clauses_sem V cls'. + clauses_sem (S:=S) V (Clauses.union cls cls') <-> clauses_sem V cls /\ clauses_sem V cls'. Proof. rewrite /clauses_sem /Clauses.For_all. setoid_rewrite Clauses.union_spec. firstorder. @@ -842,47 +843,6 @@ Module CorrectModel. depelim maxs. lia. Qed. - Section interp_semi. - Obligation Tactic := idtac. - Import Semilattice (Semilattice, eq, add, join). - - Context {S Q} {CM : CommutativeMonoid.IsCommMonoid Q} (SL : Semilattice S Q). - - Equations? opt_semi : Semilattice (option S) Q := - opt_semi := {| - eq x y := R_opt (@eq _ _ CM SL) x y; - eq_equiv := _; - add n x := option_map (add n) x; - join := option_map2 join |}. - Proof. - all: intros. - - split; red. - * intros x. destruct x => //=. reflexivity. - * intros [x|] [y|]; cbn; auto. now symmetry. - * intros [x|] [y|] [z|]; cbn; auto. apply transitivity. - - destruct x => //=. now rewrite add_distr. - - destruct x, y; cbn in * => //. now apply add_congr. - - destruct x => //=. apply add_neutral. - - destruct x, y, z => //=. apply join_assoc. - - destruct x, y => //=. apply join_comm. - - destruct x, x', y; cbn in * => //. now apply join_congr. - - destruct x => //=. apply join_idem. - - destruct x => //=. apply join_sub. - - destruct x, y => //=; cbn in *. now eapply add_inj. - - destruct x, y => //=; cbn in *; now eapply add_join. - Defined. - Existing Instance opt_semi. - - Lemma Zopt_semi_le_spec {x y : option S} : x ≤ y -> (y = None) \/ (exists x' y', x = Some x' /\ y = Some y' /\ le x' y'). - Proof. - rewrite /le. cbn. destruct x, y => //=. - - intros hc. right. exists s, s0. split => //. - - intros _. now left. - - intros _. now left. - Qed. - - End interp_semi. - Definition Zopt_semi := opt_semi Zsemilattice. Existing Instance Zopt_semi. @@ -907,10 +867,13 @@ Module CorrectModel. | _ => None end. - Definition positive_valuation (v : Level.t -> option Z) := + Definition positive_opt_valuation (v : Level.t -> option Z) := forall l k, v l = Some k -> k >= 0. - Lemma opt_valuation_of_model_pos {m} : positive_valuation (opt_valuation_of_model m). + Definition positive_valuation (v : Level.t -> Z) := + forall l, v l >= 0. + + Lemma opt_valuation_of_model_pos {m} : positive_opt_valuation (opt_valuation_of_model m). Proof. rewrite /opt_valuation_of_model /positive_valuation => l k'. case: (find_spec l m) => //. @@ -1027,14 +990,14 @@ Module CorrectModel. move=> _. destruct cl as [prems concl]. cbn. rewrite /min_atom_value in hmin. set (v := opt_valuation_of_model _). - set (ip := interp_prems _ _). + set (ip := interp_nes _ _). have -> : ip = None. - { subst ip. move/(interp_prems_ge v): inmin; tea. + { subst ip. move/(interp_nes_ge v): inmin; tea. have -> : interp_expr v (min, mink) = None. { cbn. subst v. unfold opt_valuation_of_model. move: hmin; rewrite /level_value; case: find_spec => //. move=> k hm. destruct k => //. } - move/Zopt_semi_le_spec. intros [] => //. + move/le_spec. intros [] => //. destruct H as [? [? []]]. congruence. } destruct interp_expr => //=. } destruct cl as [prems [concl k]]. cbn -[le]. @@ -1050,7 +1013,7 @@ Module CorrectModel. subst v. pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. rewrite hmin in premeq. - eapply transitivity. 2:{ eapply interp_prems_ge; tea. } + eapply transitivity. 2:{ eapply interp_nes_ge; tea. } unfold interp_expr. destruct prem as [prem k']. symmetry in premeq. move: premeq. unfold min_atom_value. @@ -1102,7 +1065,7 @@ Module CorrectModel. subst v. pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. rewrite hmin in premeq. - eapply transitivity. 2:{ eapply interp_prems_ge; tea. } + eapply transitivity. 2:{ eapply interp_nes_ge; tea. } unfold interp_expr. destruct prem as [prem k']. symmetry in premeq. move: premeq. unfold min_atom_value. @@ -1247,7 +1210,7 @@ Module CorrectModel. have hv := model_valuation m. apply hv in hin. move: hin; rewrite /clause_sem /init_clause_of_level //=. - rewrite interp_prems_singleton //=. + rewrite interp_nes_singleton //=. rewrite /to_Z_val /to_val /valuation /to_val. have vs:= valuation_of_model_spec _ _ _ hm. rewrite (LevelMap.find_1 vs). @@ -1286,7 +1249,7 @@ Module CorrectModel. have hv := model_valuation m. apply hv in hin. move: hin; rewrite /clause_sem /init_clause_of_level //=. - rewrite interp_prems_singleton //=. + rewrite interp_nes_singleton //=. rewrite /to_Z_val /to_val /valuation /to_val. have vs:= valuation_of_model_spec _ _ _ hm. rewrite (LevelMap.find_1 vs). @@ -1767,22 +1730,22 @@ Module Abstract. Lemma clauses_sem_leq {S} {SL : Semilattice S Q.t} (V : Level.t -> S) l r : clauses_sem V (l ⋞ r) <-> - (interp_prems V l ≤ interp_prems V r)%sl. + (interp_nes V l ≤ interp_nes V r)%sl. Proof. move: l. apply: elim. - intros le; cbn. rewrite clauses_of_le_singleton clauses_sem_singleton. - cbn. now rewrite interp_prems_singleton. + cbn. now rewrite interp_nes_singleton. - move=> le x xr hnin. rewrite clauses_of_le_add clauses_sem_add xr. - cbn. rewrite interp_prems_add. + cbn. rewrite interp_nes_add. symmetry; apply join_le_left_eq. Qed. Lemma clauses_sem_eq {S} {SL : Semilattice S Q.t} (V : Level.t -> S) l r : clauses_sem V (l ≡ r) <-> - (interp_prems V l ≡ interp_prems V r)%sl. + (interp_nes V l ≡ interp_nes V r)%sl. Proof. rewrite /clauses_of_eq clauses_sem_union !clauses_sem_leq. symmetry; apply eq_antisym. @@ -1790,7 +1753,7 @@ Module Abstract. Definition relation_of_clause cl := (singleton (concl cl) ≤ premise cl). - Lemma interp_rels_of_clauses {S} {SL : Semilattice S Q.t} {V cls} : + Lemma interp_rels_of_clauses {S} {SL : Semilattice S Q.t} {V : Level.t -> S} {cls} : interp_rels V (relations_of_clauses cls) <-> forall cl, Clauses.In cl cls -> interp_rel V (relation_of_clause cl). Proof. @@ -1802,15 +1765,15 @@ Module Abstract. now move=> [] /hcl hin ->. Qed. - Lemma interp_rels_clauses_sem {S} {SL : Semilattice S Q.t} {V cls} : + Lemma interp_rels_clauses_sem {S} {SL : Semilattice S Q.t} {V : Level.t -> S} {cls} : clauses_sem V cls <-> interp_rels V (relations_of_clauses cls). Proof. rewrite interp_rels_of_clauses. split. - move=> sem [prems concl] /sem //=. - now rewrite /le interp_prems_union interp_prems_singleton. + now rewrite /le interp_nes_union interp_nes_singleton. - move=> hcl [prems concl] /hcl /=. - now rewrite /le interp_prems_union interp_prems_singleton. + now rewrite /le interp_nes_union interp_nes_singleton. Qed. Definition Z_valuation_of_model m := @@ -1929,16 +1892,16 @@ Module Abstract. cbn. now have -> : k' - z + z = k' by lia. Qed. - Lemma min_premise_interp_prems_ex {m u minp} : + Lemma min_premise_interp_nes_ex {m u minp} : min_premise m u = Some minp -> - exists z, interp_prems (opt_valuation_of_model m) u = Some z /\ + exists z, interp_nes (opt_valuation_of_model m) u = Some z /\ (exists maxx maxk, LevelExprSet.In maxx u /\ LevelMap.MapsTo maxx.1 (Some maxk) m /\ z = valuation_of_value m maxk + maxx.2) /\ forall x, LevelExprSet.In x u -> exists k, LevelMap.MapsTo x.1 (Some k) m /\ valuation_of_value m k + x.2 <= z /\ minp <= k - x.2. Proof. move: u minp. apply: NES.elim. - { intros [l lk]. rewrite interp_prems_singleton min_premise_singleton //= => minp. + { intros [l lk]. rewrite interp_nes_singleton min_premise_singleton //= => minp. case: (@level_valueP m l) => // -[] // vl hm [=] <-. rewrite (mapsto_opt_valuation_of_model hm) //=. eexists; split => //. @@ -1953,13 +1916,13 @@ Module Abstract. destruct (min_premise m u) => //. specialize (h _ eq_refl) as [z1 [? [[maxx [maxk [inmax [mmax maxle]]]]]]]. cbn. intros [= <-]. - have ha := (NES.interp_prems_add (SL := Zopt_semi) (opt_valuation_of_model m) (l, k) u). + have ha := (NES.interp_nes_add (SL := Zopt_semi) (opt_valuation_of_model m) (l, k) u). rewrite H in ha. have hminv := min_atom_value_mapsto hmin. cbn in hminv. cbn [interp_expr] in ha. rewrite (mapsto_opt_valuation_of_model hminv) in ha. cbn [eq Zopt_semi] in ha. - destruct (interp_prems _ (NES.add _ _)); cbn in ha => //. + destruct (interp_nes _ (NES.add _ _)); cbn in ha => //. subst z2. eexists; split; trea. split. destruct (Z.max_spec (k + valuation_of_value m (z + k)) z1) as [[hle heq]|[hle heq]]. @@ -1984,7 +1947,7 @@ Module Abstract. Qed. Definition enables_clause val cl := - exists k, interp_prems val (premise cl) = Some k. + exists k, interp_nes val (premise cl) = Some k. Definition enables_clauses val cls := Clauses.For_all (enables_clause val) cls. @@ -2015,29 +1978,29 @@ Module Abstract. - intros hr. destruct x, y; cbn; depelim hr; try congruence. Qed. - Lemma interp_prems_add_opt_Z {v le u} : NES.interp_prems (SL := Zopt_semi) v (NES.add le u) = - option_map2 Z.max (interp_expr v le) (interp_prems (SL := Zopt_semi) v u). + Lemma interp_nes_add_opt_Z {v le u} : NES.interp_nes (SL := Zopt_semi) v (NES.add le u) = + option_map2 Z.max (interp_expr v le) (interp_nes (SL := Zopt_semi) v u). Proof. - have ha := interp_prems_add (SL := Zopt_semi) v le u. + have ha := interp_nes_add (SL := Zopt_semi) v le u. move/R_optP: ha. move/(eqb_eq _ _). auto. Qed. - Lemma interp_prems_defined {m} (u : NES.t) : + Lemma interp_nes_defined {m} (u : NES.t) : defined_model_of (NES.levels u) m -> - interp_prems (opt_valuation_of_model m) u = Some (interp_prems (valuation_of_model m) u). + interp_nes (opt_valuation_of_model m) u = Some (interp_nes (valuation_of_model m) u). Proof. move: u. apply: elim. - intros [l k] => //= hin. - rewrite !interp_prems_singleton. + rewrite !interp_nes_singleton. rewrite levels_singleton in hin. rewrite interp_expr_defined //. - move=> le x eq wf def. forward eq. move: def. rewrite /defined_model_of. move=> h l hin. apply h. rewrite levels_add. lsets. - rewrite interp_prems_add_opt_Z eq interp_expr_defined. + rewrite interp_nes_add_opt_Z eq interp_expr_defined. { intros l; move: (def l) => h hin; apply h. rewrite levels_add. rsets. now left. } - cbn. now rewrite interp_prems_add. + cbn. now rewrite interp_nes_add. Qed. Lemma clause_sem_defined_valid_all {model cl} : @@ -2046,7 +2009,7 @@ Module Abstract. Proof. intros def. destruct cl as [prems [concl k]]. - rewrite /clause_sem. rewrite interp_prems_defined. + rewrite /clause_sem. rewrite interp_nes_defined. { intros l hin; apply def. rewrite /clause_levels //=. lsets. } rewrite interp_expr_defined. { intros l hin; apply def; rewrite /clause_levels //=. cbn in hin. lsets. } @@ -2074,9 +2037,9 @@ Module Abstract. cbn -[le] in semcl. apply valid_clause_intro => minp mineq. cbn -[le] in semcl. - have [iprems [eqiprems [[maxl [maxk [inmax [hmax eqmax]]]] hleprems]]] := min_premise_interp_prems_ex mineq. + have [iprems [eqiprems [[maxl [maxk [inmax [hmax eqmax]]]] hleprems]]] := min_premise_interp_nes_ex mineq. rewrite eqiprems in semcl. subst iprems. - apply Zopt_semi_le_spec in semcl. destruct semcl => //. + apply le_spec in semcl. destruct semcl => //. destruct H as [y' [z' [eq [eq' le]]]]. noconf eq'. destruct opt_valuation_of_model eqn:evconcl; noconf eq. rename z into vconcl. @@ -2103,6 +2066,16 @@ Module Abstract. move=> vm cl /vm. apply valid_clause_model_opt. Qed. + Lemma def_clause_sem_valid {model cl} : + defined_model_of (clause_levels cl) model -> + clause_sem (valuation_of_model model) cl <-> valid_clause model cl. + Proof. + intros def. + split. + - intros cs. apply clause_sem_valid. rewrite -clause_sem_defined_valid_all //. + - intros v. rewrite clause_sem_defined_valid_all //. now apply valid_clause_model_opt. + Qed. + Lemma def_clauses_sem_valid {model cls} : defined_model_of (clauses_levels cls) model -> clauses_sem (valuation_of_model model) cls <-> is_model cls model. @@ -2111,12 +2084,10 @@ Module Abstract. apply clauses_sem_valid. Qed. - (* cls ⊭ x >= y, so cls + x < y is consistent, validates all clauses *) - Theorem check_invalid_valuation {cls cl} : check cls cl = Invalid -> exists v : Level.t -> option Z, - [/\ positive_valuation v, clauses_sem v cls & ~ clause_sem v cl]. + [/\ positive_opt_valuation v, clauses_sem v cls & ~ clause_sem v cl]. Proof. move/check_invalid=> [m' [ism en inval]]. have hpos := opt_valuation_of_model_pos. @@ -2127,7 +2098,7 @@ Module Abstract. Definition valid_clauses cls cls' := forall v : Level.t -> option Z, - positive_valuation v -> + positive_opt_valuation v -> clauses_sem v cls -> clauses_sem v cls'. Lemma check_clauses_Z_positive_complete m cls : @@ -2209,41 +2180,41 @@ Module Abstract. destruct e; cbn. rewrite /Z_val_of_opt_val. destruct (v t0) eqn:vt0 => //=. congruence. Qed. - Lemma interp_prems_add_Z {v le u} : NES.interp_prems (SL := Zsemilattice) v (NES.add le u) = - Z.max (interp_expr v le) (interp_prems v u). + Lemma interp_nes_add_Z {v le u} : NES.interp_nes (SL := Zsemilattice) v (NES.add le u) = + Z.max (interp_expr v le) (interp_nes v u). Proof. - now rewrite interp_prems_add. + now rewrite interp_nes_add. Qed. - Lemma interp_prems_opt {v e} : - interp_prems (opt_val_of_Z_val v) e = Some (interp_prems v e). + Lemma interp_nes_opt {v e} : + interp_nes (opt_val_of_Z_val v) e = Some (interp_nes v e). Proof. move: e; apply elim. - - intros []. now rewrite !interp_prems_singleton interp_expr_opt. + - intros []. now rewrite !interp_nes_singleton interp_expr_opt. - intros le x h nin. - rewrite interp_prems_add_opt_Z interp_expr_opt h //=. - f_equal. now rewrite interp_prems_add. + rewrite interp_nes_add_opt_Z interp_expr_opt h //=. + f_equal. now rewrite interp_nes_add. Qed. - Lemma interp_prems_opt_inv {v} {e z} : - interp_prems v e = Some z -> - interp_prems (Z_val_of_opt_val v) e = z. + Lemma interp_nes_opt_inv {v} {e z} : + interp_nes v e = Some z -> + interp_nes (Z_val_of_opt_val v) e = z. Proof. move: e z; apply: NES.elim. - - intros le z. rewrite !interp_prems_singleton. + - intros le z. rewrite !interp_nes_singleton. now move/interp_expr_opt_inv. - intros le x h nin z. - rewrite interp_prems_add_opt_Z interp_prems_add. - case he : interp_expr => //. 2:{ cbn. destruct interp_prems => //. } + rewrite interp_nes_add_opt_Z interp_nes_add. + case he : interp_expr => //. 2:{ cbn. destruct interp_nes => //. } move/interp_expr_opt_inv: he => ->. - case he' : interp_prems => //=. + case he' : interp_nes => //=. move/h: he'. intros ->. congruence. Qed. Lemma clause_sem_opt {v cl} : clause_sem (opt_val_of_Z_val v) cl <-> clause_sem v cl. Proof. - destruct cl as [prems concl]; rewrite /clause_sem interp_expr_opt interp_prems_opt. + destruct cl as [prems concl]; rewrite /clause_sem interp_expr_opt interp_nes_opt. now cbn. Qed. @@ -2253,6 +2224,56 @@ Module Abstract. now split; move => h cl /h; rewrite clause_sem_opt. Qed. + + (** ~ (x >= y) <-> (y > x)*) + (* cls ⊭ x >= y, so cls + x < y is consistent, validates all clauses *) + + Definition inverse_clauses (cl : clause) := + let (prems, concl) := cl in + clauses_of_le (succ_prems prems) (singleton concl). + + Definition enforce_inverse m cl := + enforce_clauses m (inverse_clauses cl). + +(* ~ (x <= y) <-> (x <= y -> succ x <= x). + check cls cl = Invalid -> + exists v : Level.t -> option Z, + [/\ positive_opt_valuation v, clauses_sem v cls & ~ clause_sem v cl]. +*) + + Lemma enforce_inverse_model m minv cl : + is_model (clauses m) minv -> + ~ valid_clause minv cl -> + exists m', enforce_inverse m cl = Some (inl m'). + Proof. + intros ism inval. + rewrite /enforce_inverse. + destruct enforce_clauses eqn:ec. + destruct s. + - eexists; trea. + - move/enforce_clauses_inconsistent: ec. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -completeness_all. + move/(_ Z _ (Z_valuation_of_model m)). + rewrite -!interp_rels_clauses_sem. + rewrite clauses_sem_union. + rewrite -def_clause_sem_valid in inval. admit. + + move=> /fwd. split. admit. + Search valid_clause. + Search interp_rels. + + + + + rewrite entails_ℋ_ + admit. + - move/enforce_clauses_None: ec. + admit. + Admitted. + + + (* Definition full_valuation V v := forall l, LevelSet.In l V -> exists z, v l = Some z /\ if l == Level.zero then z = 0 @@ -2275,7 +2296,7 @@ Module Abstract. - move=> ent v cs. specialize (ent (Z_val_of_opt_val v)). forward ent. move=> cl /cs. destruct cl as [prems concl] => //=. - intros hm. rewrite interp_expr_opt interp_prems_opt //=. + intros hm. rewrite interp_expr_opt interp_nes_opt //=. move=> cl /ent. destruct cl as [prems concl] => //=. Qed.*) End Abstract. @@ -2466,7 +2487,7 @@ Module LoopChecking (LS : LevelSets). move=> cl /en; clear. destruct cl as [prems concl]; rewrite /enabled_clause /enables_clause; cbn. intros [k hmin]. - move/min_premise_interp_prems_ex: hmin => [z [eq rest]]. now exists z. + move/min_premise_interp_nes_ex: hmin => [z [eq rest]]. now exists z. Qed. Lemma clauses_consistent_val m : consistent_val (opt_valuation m) (clauses m). diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 4106672f9..98eabf54e 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -888,7 +888,7 @@ Module Clauses (LS : LevelSets). destruct cl'; cbn in * => /In_add_prems => [] [] x []. destruct x => hin [=] ->. intros ->. apply clause_levels_spec. left. apply NES.levels_spec. now exists z. - intros ->. apply clause_levels_spec; right. destruct cl' => //=. destruct t2 => //. + intros ->. apply clause_levels_spec; right. destruct cl' => //=. now destruct t2. - move/clauses_levels_spec => [] cl [] hin /clause_levels_spec []. * move=> /NES.levels_spec => [] [k hin']; exists (add_clause n cl); split => //. now apply add_clauses_spec. @@ -907,13 +907,12 @@ Module Clauses (LS : LevelSets). now rewrite add_prems_0. Qed. - Lemma add_clause_singleton n le concl k : add_clause n (singleton le, (concl, k)) = (singleton (add_expr n le), (concl, k + n)). + Lemma add_clause_singleton n le concl k : add_clause n (singleton le, (concl, k)) = (singleton (add_expr n le), (concl, n + k)). Proof. rewrite /add_clause //=. f_equal. apply NES.equal_exprsets. intros le'. rewrite In_add_prems. rewrite_strat (topdown LevelExprSet.singleton_spec). unfold LevelExprSet.E.eq. firstorder; subst; try lia_f_equal. - f_equal. lia. Qed. Lemma max_premise_of_spec_aux s l k : @@ -1403,28 +1402,27 @@ Module Clauses (LS : LevelSets). Qed. Lemma entails_incr_shift cls concl k n : - entails cls (singleton (concl, k), (concl, k + 1)) -> - entails cls (singleton (concl, k), (concl, k + 1 + Z.of_nat n)). + entails cls (singleton (concl, k), (concl, 1 + k)) -> + entails cls (singleton (concl, k), (concl, Z.of_nat n + 1 + k)). Proof. induction n in k |- *; auto. - - now rewrite Z.add_0_r. - - intros en. - have hs := entails_shift 1 en. rewrite add_clause_singleton /= in hs. - rewrite Z.add_comm in hs. - apply IHn in hs. - eapply entails_trans; tea. - now have -> : k + 1 + Z.of_nat (S n) = k + 1 + 1 + Z.of_nat n by lia. + intros en. + have hs := entails_shift 1 en. rewrite add_clause_singleton /= in hs. + apply IHn in hs. + eapply entails_trans; tea. + now have <- : Z.of_nat n + 1 + (1 + k) = Z.of_nat (S n) + 1 + k by lia. Qed. Lemma entails_incr_all cls concl k : - entails cls (singleton (concl, k), (concl, k + 1)) -> + entails cls (singleton (concl, k), (concl, 1 + k)) -> forall k', entails cls (singleton (concl, k), (concl, k')). Proof. intros en k'. destruct (Z.lt_trichotomy k k') as [|[]]; subst; auto. - have ispos : 0 <= k' - k - 1 by lia. eapply (entails_incr_shift _ _ _ (Z.to_nat (k' - k - 1))) in en. - assert (k + 1 + Z.of_nat (Z.to_nat (k' - k - 1)) = k') by lia. now rewrite H0 in en. + assert (Z.of_nat (Z.to_nat (k' - k - 1)) + 1 + k = k') by lia. + now rewrite H0 in en. - constructor. now rewrite LevelExprSet.singleton_spec. - have [k0 ->] : (exists kd : nat, k = k' + Z.of_nat kd). { exists (Z.to_nat (k - k')). lia. } eapply (entails_pred_closure_n (n:=k0)). constructor. now apply LevelExprSet.singleton_spec. @@ -1594,7 +1592,7 @@ Module Clauses (LS : LevelSets). rewrite Z.add_comm in H1. rewrite -(add_prems_add_prems 1 n prems') in H1. now move/inj_add_prems_sub: H1. - + specialize (H0 (x, k + 1)). forward H0. now apply LevelExprSet.singleton_spec. + + specialize (H0 (x, 1 + k)). forward H0. rewrite Z.add_comm. now apply LevelExprSet.singleton_spec. eapply In_add_prems in H0 as [[l' k'] [hin heq]]. noconf heq. cbn -[Z.add] in *. have eq: k' = k by lia. subst k'. clear H. diff --git a/common/theories/LoopChecking/InitialSemilattice.v b/common/theories/LoopChecking/InitialSemilattice.v index 0b0eb6a8c..c45dee4a5 100644 --- a/common/theories/LoopChecking/InitialSemilattice.v +++ b/common/theories/LoopChecking/InitialSemilattice.v @@ -412,7 +412,7 @@ Module InitialSemilattice (LS : LevelSets). Definition interp_rel r := let '(l, r) := r in - interp_prems v l ≡ interp_prems v r. + interp_nes v l ≡ interp_nes v r. Definition interp_rels c := List.Forall interp_rel c. @@ -436,7 +436,7 @@ Module InitialSemilattice (LS : LevelSets). all:try specialize (IHh1 _ _ Logic.eq_refl S SL _ hv). all:try specialize (IHh2 _ _ Logic.eq_refl S SL _ hv). all:try lia; eauto. - all:rewrite ?interp_add_prems ?interp_prems_union ?interp_add_prems; try lia. + all:rewrite ?interp_add_prems ?interp_nes_union ?interp_add_prems; try lia. - eapply reflexivity. - now eapply symmetry, IHh. - eapply transitivity; [eapply IHh1|eapply IHh2] => //. @@ -470,15 +470,15 @@ Module InitialSemilattice (LS : LevelSets). Definition ids (rs : rels) : Level.t -> t := (fun l : Level.t => singleton (l, zero)). - Lemma interp_triv rs l : eq (Semilattice := init_model rs) (interp_prems (SL := init_model rs) (ids rs) l) l. + Lemma interp_triv rs l : eq (Semilattice := init_model rs) (interp_nes (SL := init_model rs) (ids rs) l) l. Proof. move: l; apply: elim. - intros [l k]. - rewrite interp_prems_singleton //= /ids //=. - rewrite add_prems_singleton //=. rewrite comm neutral. + rewrite interp_nes_singleton //= /ids //=. + rewrite add_prems_singleton //=. rewrite /add_expr //= comm neutral. apply entails_refl. - move=> [] l k x ih hnin. - have ha := (interp_prems_add (SL := init_model rs) (ids rs) (l, k)). + have ha := (interp_nes_add (SL := init_model rs) (ids rs) (l, k)). rewrite ha ih. rewrite /interp_expr. rewrite -union_add_singleton /ids. rewrite [add _ _]add_prems_singleton /add_expr comm neutral. apply (join_comm (Semilattice := init_model rs)). @@ -494,7 +494,7 @@ Module InitialSemilattice (LS : LevelSets). induction rs0; cbn. - constructor. - destruct a. constructor. - * change (eq (Semilattice := init_model rs) (interp_prems (SL := init_model rs) (ids rs) t0) (interp_prems (SL := init_model rs) (ids rs) t1)). + * change (eq (Semilattice := init_model rs) (interp_nes (SL := init_model rs) (ids rs) t0) (interp_nes (SL := init_model rs) (ids rs) t1)). rewrite !interp_triv. constructor. apply ir. now constructor. * apply IHrs0. intros r hin; apply ir. now right. @@ -516,7 +516,7 @@ Module InitialSemilattice (LS : LevelSets). rewrite /valid_relation. intros ha. apply syntax_model. destruct r as [l r]. cbn. - change (eq (Semilattice := init_model p) (interp_prems (SL := init_model p) (ids p) l) (interp_prems (SL := init_model p) (ids p) r)). + change (eq (Semilattice := init_model p) (interp_nes (SL := init_model p) (ids p) l) (interp_nes (SL := init_model p) (ids p) r)). specialize (ha _ (init_model p) (ids p) (interp_rels_init p)). now cbn in ha. Qed. @@ -549,7 +549,7 @@ Module InitialSemilattice (LS : LevelSets). Open Scope rel_scope. - Instance interp_rels_entails_proper {S} {SL : Semilattice S Q.t} V : Proper (entails_L_rels ==> impl) (interp_rels V). + Instance interp_rels_entails_proper {S} {SL : Semilattice S Q.t} V : Proper (entails_L_rels ==> impl) (interp_rels (S:=S) V). Proof. intros rs rs' hl. induction rs' in rs, hl |- *. @@ -559,7 +559,7 @@ Module InitialSemilattice (LS : LevelSets). now apply (H S SL V H0). Qed. - Instance interp_rels_proper {S} {SL : Semilattice S Q.t} V : Proper (equiv_L_rels ==> iff) (interp_rels V). + Instance interp_rels_proper {S} {SL : Semilattice S Q.t} V : Proper (equiv_L_rels ==> iff) (interp_rels (S:=S) V). Proof. intros rs rs' [hl hr]. split; now apply interp_rels_entails_proper. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 63d7e40e2..6b45c472d 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -1151,7 +1151,7 @@ Module Model (LS : LevelSets). Lemma min_atom_value_add_inv m e x n : min_atom_value m (add_expr n e) = Some x -> - min_atom_value m e = Some (x + n)%Z. + min_atom_value m e = Some (n + x)%Z. Proof. rewrite /min_atom_value. destruct e. cbn. destruct level_value => //. intros [= <-]. @@ -1176,21 +1176,21 @@ Module Model (LS : LevelSets). Qed. Lemma min_premise_add_prems_inv {m n prems z} : min_premise m (add_prems n prems) = Some z -> - min_premise m prems = Some (z + n)%Z. + min_premise m prems = Some (n + z)%Z. Proof. revert z. pattern prems. set (P := (fun n0 hm => forall z : Z, - min_premise m (add_prems n n0) = Some z -> hm = Some (z + n)%Z)). + min_premise m (add_prems n n0) = Some z -> hm = Some (n + z)%Z)). apply (@min_premise_elim _ P); subst P; cbn. - intros le z hm. destruct le as [concl k]. - rewrite add_prems_singleton min_premise_singleton in hm. + rewrite add_prems_singleton min_premise_singleton //= in hm. now apply min_atom_value_add_inv. - intros prems' acc le ih nle z. rewrite add_prems_add min_premise_add. - destruct (min_premise m (add_prems n prems')) eqn:he => //=. + destruct (min_premise m (add_prems n prems')) eqn:he => //. * destruct (min_atom_value m (add_expr n le)) eqn:ha => //=. intros [= <-]. eapply min_atom_value_add_inv in ha. rewrite ha. @@ -1254,7 +1254,7 @@ Module Model (LS : LevelSets). rewrite In_add_prems. split. - move=> [] [l' k'] [] hin heq. noconf heq. now have <- : k' = - premise_min s + k' + premise_min s by lia. - - move=> hin; exists (l, k + premise_min s). split => //. + - move=> hin; exists (l, k + premise_min s). split; rewrite /add_expr => //. cbn. lia_f_equal. Qed. diff --git a/common/theories/LoopChecking/ModelValuation.v b/common/theories/LoopChecking/ModelValuation.v index 1d6584087..df47f8349 100644 --- a/common/theories/LoopChecking/ModelValuation.v +++ b/common/theories/LoopChecking/ModelValuation.v @@ -9,7 +9,7 @@ Definition clause_sem (cl : clause) : Prop := let '(prems, concl) := cl in - le (interp_expr concl) (interp_prems prems). + le (interp_expr concl) (interp_nes prems). Definition clauses_sem (cls : clauses) : Prop := Clauses.For_all clause_sem cls. @@ -37,7 +37,7 @@ rewrite /add_expr; cbn. rewrite -add_distr => le. now apply (le_add (n:=n)) in le. - intros V clsm. cbn. - rewrite interp_prems_singleton. + rewrite interp_nes_singleton. cbn. red. rewrite -!add_distr. rewrite -add_join. now rewrite join_sub. Qed. @@ -54,13 +54,13 @@ induction 1. - intros v clls. red. destruct concl0 as [concl k]. - have hge := interp_prems_ge (SL := Zsemilattice) v prems _ H. + have hge := interp_nes_ge (SL := Zsemilattice) v prems _ H. cbn in *. by lia. - move=> V Hcls. move: {IHentails} (IHentails _ Hcls). unfold clause_sem. unfold ge => hyp. - etransitivity; tea. rewrite interp_prems_add. - rewrite interp_prems_add in hyp. + etransitivity; tea. rewrite interp_nes_add. + rewrite interp_nes_add in hyp. eapply in_pred_closure_entails in H; tea. move: H; rewrite /clause_sem. unfold ge. have ssub := clauses_sem_subset (SL := Zsemilattice) H1 V. @@ -69,13 +69,13 @@ Lemma clauses_sem_entails_all {cls prems concl} : cls ⊢a prems → concl -> - (forall V, clauses_sem V cls -> interp_prems V concl ≤ interp_prems V prems). + (forall V, clauses_sem V cls -> interp_nes V concl ≤ interp_nes V prems). Proof. intros ha V hcls. red in ha. move: ha. revert concl. - refine (@interp_prems_elim _ _ (fun concl z => _ -> z ≤ interp_prems V prems) V _ _ _). + refine (@interp_nes_elim _ _ (fun concl z => _ -> z ≤ interp_nes V prems) V _ _ _). - move=> le //=. move/(_ le). intros h; forward h by now apply LevelExprSet.singleton_spec. now have ent := (clauses_sem_entails h _ hcls). diff --git a/common/theories/LoopChecking/OldPresentation.v b/common/theories/LoopChecking/OldPresentation.v index 5965e5538..e53bdf529 100644 --- a/common/theories/LoopChecking/OldPresentation.v +++ b/common/theories/LoopChecking/OldPresentation.v @@ -80,7 +80,7 @@ rewrite /valid_constraint /interp_z_cstr //=. move/presentation_entails_valid_eq => vc v hc. specialize (vc v hc). cbn in vc. - rewrite interp_prems_union in vc. apply vc. + rewrite interp_nes_union in vc. apply vc. Qed. Lemma presentation_entails_valid {p c} : diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index f8f14691f..7cdf0440d 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -152,7 +152,6 @@ From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils. -From MetaRocq.Common Require Universes. From Equations Require Import Equations. From MetaRocq.Common.LoopChecking Require Import Common Interfaces HornClauses Model Models. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 84e2a0e83..00e486cd2 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -729,8 +729,8 @@ End ZUnivConstraint. Definition interp_z_cstr c := let '(l, d, r) := c in match d with - | ConstraintType.Le => interp_prems v l ≤ interp_prems v r - | ConstraintType.Eq => interp_prems v l ≡ interp_prems v r + | ConstraintType.Le => interp_nes v l ≤ interp_nes v r + | ConstraintType.Eq => interp_nes v l ≡ interp_nes v r end%Z. Definition interp_univ_cstr c := interp_z_cstr (to_constraint c). @@ -749,7 +749,7 @@ End ZUnivConstraint. cbn in heq; noconf heq. destruct d; noconf heq. * eapply to_z_cstrs_spec_2 in hin as [cstr [hin heq]]. destruct cstr as [[] ?]; noconf heq. specialize (hf _ hin). cbn in hf. - rewrite /interp_rel interp_prems_union; cbn in *. exact hf. + rewrite /interp_rel interp_nes_union; cbn in *. exact hf. * eapply to_z_cstrs_spec_2 in hin as [cstr [hin heq]]. destruct cstr as [[] ?]; noconf heq. specialize (hf _ hin). cbn in hf. exact hf. @@ -758,7 +758,7 @@ End ZUnivConstraint. rewrite relations_of_constraints_spec; exists (to_constraint uc); split => //. now apply to_z_cstrs_spec_1 in hin as [cstrz [hin ->]]. destruct uc as [[l []] r] => //=. - rewrite interp_prems_union //=. + rewrite interp_nes_union //=. Qed. Import LoopCheck.Impl.CorrectModel (clause_sem, clauses_sem, clauses_sem_union, to_val, to_Z_val). @@ -770,7 +770,7 @@ End ZUnivConstraint. rewrite relation_of_constraint_of_clause. rewrite /Clauses.ISL.interp_rels Forall_tip. destruct c as [[l []] r]; cbn => //. - now rewrite interp_prems_union. + now rewrite interp_nes_union. Qed. Lemma interp_cstrs_clauses_sem {m} {S} {SL : Semilattice S Q.t} {v : Level.t -> S} : @@ -921,26 +921,26 @@ End ZUnivConstraint. Import LoopCheck.Impl.CorrectModel (Zopt_semi). Existing Instance Zopt_semi. - Lemma interp_prems_valuation_to_Z_to_atoms v u : - interp_prems (valuation_to_Z v) (to_atoms u) = Some (Z.of_nat (Universes.val v u)). + Lemma interp_nes_valuation_to_Z_to_atoms v u : + interp_nes (valuation_to_Z v) (to_atoms u) = Some (Z.of_nat (Universes.val v u)). Proof. move: u. apply: Universe.elim. - - intros [l k]; rewrite to_atoms_singleton interp_prems_singleton //= val_singleton //=. + - intros [l k]; rewrite to_atoms_singleton interp_nes_singleton //= val_singleton //=. cbn; lia_f_equal. - intros [l k] x hx hnin. - rewrite to_atoms_add !interp_prems_add_opt_Z //= val_add //= hx; cbn. + rewrite to_atoms_add !interp_nes_add_opt_Z //= val_add //= hx; cbn. lia_f_equal. Qed. Lemma clauses_sem_satisfies0_equiv v cstr : clauses_sem (valuation_to_Z v) (LoopCheck.to_clauses (to_constraint cstr)) <-> satisfies0 v cstr. Proof. destruct cstr as [[l []] r]; cbn. - - rewrite clauses_sem_leq !interp_prems_valuation_to_Z_to_atoms. + - rewrite clauses_sem_leq !interp_nes_valuation_to_Z_to_atoms. split; cbn. * constructor; lia. * intros s; depelim s. lia. - - rewrite clauses_sem_eq !interp_prems_valuation_to_Z_to_atoms. + - rewrite clauses_sem_eq !interp_nes_valuation_to_Z_to_atoms. split; cbn. * constructor. lia. * intros s; depelim s. lia. @@ -975,15 +975,15 @@ End ZUnivConstraint. red in sat. now move/sat. Qed. - Lemma interp_prems_valuation_to_Z v u : - interp_prems (valuation_to_Z v) u <> None. + Lemma interp_nes_valuation_to_Z v u : + interp_nes (valuation_to_Z v) u <> None. Proof. move: u. apply: NES.elim. - - intros [l k]. rewrite interp_prems_singleton //= val_singleton //=. + - intros [l k]. rewrite interp_nes_singleton //= val_singleton //=. - intros [l k] x hx hnin. - rewrite !interp_prems_add_opt_Z //=. - destruct interp_prems => //. + rewrite !interp_nes_add_opt_Z //=. + destruct interp_nes => //. Qed. Lemma enforce_inconsistent m (c : UnivConstraint.t) u : @@ -1001,8 +1001,8 @@ End ZUnivConstraint. { split => //. now apply satisfies_clauses_sem_to_Z. } destruct loop0 as [u hu]. cbn in he. apply clauses_sem_eq in he. rewrite interp_add_prems in he. cbn -[Z.add] in he. - have hid := interp_prems_valuation_to_Z v u. - destruct interp_prems => //. cbn -[Z.add] in he. lia. + have hid := interp_nes_valuation_to_Z v u. + destruct interp_nes => //. cbn -[Z.add] in he. lia. Qed. Definition enforce_constraints_aux (g : option univ_model) (cstrs : UnivConstraintSet.t) : option univ_model := @@ -1355,19 +1355,19 @@ End ZUnivConstraint. Lemma clauses_sem_clauses_of_le (V : Level.t -> Z) l r : clauses_sem V (clauses_of_le l r) -> - (interp_prems V l ≤ interp_prems V r)%sl. + (interp_nes V l ≤ interp_nes V r)%sl. Proof. rewrite /clauses_sem. intros hl. red in hl. setoid_rewrite clauses_of_le_spec in hl. move: l hl. apply: elim. - move => le he. - rewrite interp_prems_singleton. + rewrite interp_nes_singleton. move: (he (r, le)) => /fwd. exists le. split => //. now apply LevelExprSet.singleton_spec. cbn. lia. - intros le x ih hnin ih'. - rewrite interp_prems_add. + rewrite interp_nes_add. forward ih. intros x0 [x1 [hin ->]]. move: (ih' (r, x1)) => /fwd. exists x1. split => //. apply LevelExprSet.add_spec. now right. auto. @@ -1406,20 +1406,20 @@ End ZUnivConstraint. - cbn. unfold to_Z_val; cbn. lia. Qed. - Lemma interp_prems_to_atoms {V v} (u : Universe.t) : + Lemma interp_nes_to_atoms {V v} (u : Universe.t) : wf_valuation V v -> LevelSet.Subset (Universe.levels u) V -> - interp_prems (to_Z_val v) (to_atoms u) = Z.of_nat (Universes.val (to_valuation v) u). + interp_nes (to_Z_val v) (to_atoms u) = Z.of_nat (Universes.val (to_valuation v) u). Proof. move: u. apply: Universe.elim. - intros [l k] => //= hin. - rewrite to_atoms_singleton interp_prems_singleton. + rewrite to_atoms_singleton interp_nes_singleton. rewrite val_singleton Universe.levels_singleton => hwf. rewrite (interp_prem_to_atom V (l, k)) //. cbn in *; lsets. - move=> le x eq nin wf. specialize (eq wf). - rewrite to_atoms_add interp_prems_add val_add. + rewrite to_atoms_add interp_nes_add val_add. rewrite Universe.levels_add => hincl. forward eq by lsets. rewrite (interp_prem_to_atom V) //. cbn in *. apply hincl. rsets. now left. @@ -1437,8 +1437,8 @@ End ZUnivConstraint. Proof. move=> wf decll declr. move/clauses_sem_clauses_of_le. - have he := @interp_prems_to_atoms V v l wf decll. - have he' := @interp_prems_to_atoms V v r wf declr. + have he := @interp_nes_to_atoms V v l wf decll. + have he' := @interp_nes_to_atoms V v r wf declr. cbn in *. unfold Universes.LevelExpr.t in *. lia. Qed. @@ -1601,7 +1601,7 @@ End ZUnivConstraint. move=> hlev leq [prems concl]. move=> [] [l'' k'] [] /to_levelexprzset_spec_2 [] inl' pos ->. cbn -[le]. - erewrite interp_prems_to_atoms. + erewrite interp_nes_to_atoms. rewrite to_of_valuation_univ. { intros ? hin; apply hlev. cbn. lsets. } transitivity (Z.of_nat (val v l)). @@ -1658,7 +1658,7 @@ End ZUnivConstraint. intros hin hsem. destruct c as [[l []] r]; cbn in *. - constructor. move/clauses_sem_clauses_of_le: hsem. - erewrite !interp_prems_to_atoms; tea. + erewrite !interp_nes_to_atoms; tea. rewrite !to_of_valuation_univ. lsets. lsets. cbn; lia. setoid_rewrite <- hin. lsets. setoid_rewrite <- hin. lsets. @@ -1666,17 +1666,17 @@ End ZUnivConstraint. rewrite clauses_sem_union in hsem. destruct hsem as [hsem hsem']. move/clauses_sem_clauses_of_le: hsem. move/clauses_sem_clauses_of_le: hsem'. - erewrite !interp_prems_to_atoms; tea. + erewrite !interp_nes_to_atoms; tea. rewrite !to_of_valuation_univ. lsets. lsets. cbn; lia. setoid_rewrite <- hin; lsets. setoid_rewrite <- hin; lsets. Qed. - Lemma val_respects cls v : @respects _ _ Z _ (horn_semi cls) _ Zsemilattice (fun u => interp_prems v u). + Lemma val_respects cls v : @respects _ _ Z _ (horn_semi cls) _ Zsemilattice (fun u => interp_nes v u). Proof. split; cbn. - intros n x. rewrite interp_add_prems; cbn. lia. - - intros x y. rewrite interp_prems_union; cbn. lia. + - intros x y. rewrite interp_nes_union; cbn. lia. Qed. @@ -1695,8 +1695,8 @@ End ZUnivConstraint. Definition interp_nat_cstr c := let '(l, d, r) := c in match d with - | ConstraintType.Le => interp_prems v l ≤ interp_prems v r - | ConstraintType.Eq => interp_prems v l ≡ interp_prems v r + | ConstraintType.Le => interp_nes v l ≤ interp_nes v r + | ConstraintType.Eq => interp_nes v l ≡ interp_nes v r end%Z. Definition interp_cstrs c := UnivConstraintSet.For_all interp_nat_cstr c. @@ -1729,7 +1729,7 @@ End ZUnivConstraint. eapply to_z_cstrs_spec_2 in hin as [cstr [hin ->]]. have hrepr := repr_constraints m _ hin. destruct cstr as [[l' []] r']; cbn in heq; noconf heq. - - rewrite /interp_rel interp_prems_union. cbn in hrepr. + - rewrite /interp_rel interp_nes_union. cbn in hrepr. eapply UnivLoopChecking.clauses_sem_subset in hv; tea. apply clauses_sem_clauses_of_le in hv. cbn in hv |- *. unfold model_Z_val in *. lia. @@ -1755,7 +1755,7 @@ End ZUnivConstraint. - move: (hi ((to_atoms l ∨ to_atoms r)%nes, to_atoms r)) => /fwd. { apply relations_of_constraints_spec. exists (to_atoms l, ConstraintType.Le, to_atoms r). cbn. split => //. } - by rewrite /interp_rel interp_prems_union; unfold model_Z_val in *; cbn; lia. + by rewrite /interp_rel interp_nes_union; unfold model_Z_val in *; cbn; lia. - move: (hi (to_atoms l, to_atoms r)) => /fwd. { apply relations_of_constraints_spec. exists (to_atoms l, ConstraintType.Eq, to_atoms r). cbn. split => //. } @@ -1776,12 +1776,12 @@ End ZUnivConstraint. Hint Rewrite Universe.levels_singleton : set_specs. (** Interpretation in the semilattice of natural numbers *) - Lemma interp_prems_val {V} (v : Level.t -> nat) (u : Universe.t) : + Lemma interp_nes_val {V} (v : Level.t -> nat) (u : Universe.t) : Universe.levels u ⊂_lset V -> wf_valuation V v -> - Universe.interp_prems v u = Universes.val (to_valuation v) u. + Universe.interp_nes v u = Universes.val (to_valuation v) u. Proof. - move: u. refine (Universe.interp_prems_elim v (fun u i => _ -> _ -> i = val (to_valuation v) u) _ _ _). + move: u. refine (Universe.interp_nes_elim v (fun u i => _ -> _ -> i = val (to_valuation v) u) _ _ _). - intros [l k]; rewrite val_singleton //= /val; rsets. cbn in *. rewrite /Universe.interp_expr (to_valuation_val V) //; cbn. apply H; lsets. - move=>[l k] u k' ih hnin. @@ -1796,8 +1796,8 @@ End ZUnivConstraint. Proof. move=> wfv. destruct cl as [[l []] r] => //= decl; - cbn; erewrite !interp_prems_to_atoms; tea; - try rewrite !(@interp_prems_val V v) /model_val //; try (split; lia); intuition eauto. + cbn; erewrite !interp_nes_to_atoms; tea; + try rewrite !(@interp_nes_val V v) /model_val //; try (split; lia); intuition eauto. Qed. Lemma interp_univ_cstrs_nat V v cl : @@ -1825,7 +1825,7 @@ End ZUnivConstraint. Qed. Lemma entails_L_completeness {p l r} : - (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v p -> interp_prems v l ≡ interp_prems v r)%sl -> + (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v p -> interp_nes v l ≡ interp_nes v r)%sl -> p ⊢ℒ l ≡ r. Proof. intros hv. @@ -1845,30 +1845,35 @@ End ZUnivConstraint. Definition valid_Z_model m c := (forall (v : Level.t -> option Z), positive_valuation v -> interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). - (* Definition valid_nat_model m c := - (forall (v : Level.t -> option nat), interp_cstrs v (constraints m) -> interp_nat_cstr v c). + Infix "⊩Z" := valid_Z_model (at level 70, no associativity). + + Definition defined_valuation_of V (v : Level.t -> option nat) := + forall l, LevelSet.In l V -> exists x, v l = Some x. + Definition valid_nat_model m c := + (forall (v : Level.t -> option nat), defined_valuation_of (UnivLoopChecking.levels m ∪ univ_constraint_levels c) v -> + interp_cstrs v (constraints m) -> interp_nat_cstr v c). +(* Lemma valid_Z_pos_nat_model m c : valid_Z_model m c <-> valid_nat_model m c. Proof. split. - intros vz v ic. specialize (vz (fun l => option_map Z.of_nat (v l))). forward vz. { red. intros. destruct (v l); noconf H. lia. } + Search interp_univ_cstr. + rewrite interp_cstrs_clauses_sem in vz. + rewrite interp_cstr_clauses_sem in vz. + have df := def_clauses_sem_valid. rewrite -interp_univ_cstr_nat. Search interp_nat_cstr. Qed. *) - Infix "⊩Z" := valid_Z_model (at level 70, no associativity). - - Definition valid_Z_entailments p r := - (forall (v : Level.t -> Z), interp_rels v p -> interp_rels v r). - Theorem check_completeness {m c} : check m c <-> m ⊩Z c. Proof. - rewrite LoopCheck.check_Z_complete_positive /valid_semilattice_entailments /valid_Z_model. + rewrite LoopCheck.check_Z_complete_positive /valid_Z_model. setoid_rewrite interp_cstrs_clauses_sem; setoid_rewrite interp_cstr_clauses_sem. now rewrite /valid_clauses. Qed. diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index 7767d0fbb..585558f12 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -241,6 +241,7 @@ Section CheckLeq. - rewrite check_completeness. intros hv. red in hv. destruct HG as [hlev hcstrs]. + red. rewrite valid_Z_pos_nat_model => v. rewrite hcstrs. erewrite <-interp_univ_cstrs_nat. diff --git a/oldLoopChecking.v b/oldLoopChecking.v index fbb6ca386..df5f2e5a5 100644 --- a/oldLoopChecking.v +++ b/oldLoopChecking.v @@ -4751,13 +4751,13 @@ Section Semantics. end. Definition interp_expr '(l, k) := (interp_level l + k)%nat. - Definition interp_prems prems := + Definition interp_nes prems := let '(hd, tl) := to_nonempty_list prems in fold_right (fun lk acc => Nat.max (interp_expr lk) acc) (interp_expr hd) tl. Definition clause_sem (cl : clause) : Prop := let '(prems, concl) := cl in - interp_prems prems >= interp_expr concl. + interp_nes prems >= interp_expr concl. Definition clauses_sem (cls : clauses) : Prop := Clauses.For_all clause_sem cls. @@ -5981,12 +5981,12 @@ Proof. rewrite heq in hp. depelim hp. exists y. split => //; lia. Qed. -Lemma interp_prems_ge v (prems : nonEmptyLevelExprSet) : +Lemma interp_nes_ge v (prems : nonEmptyLevelExprSet) : forall prem, LevelExprSet.In prem prems -> - interp_expr v prem <= interp_prems v prems. + interp_expr v prem <= interp_nes v prems. Proof. intros. - unfold interp_prems. + unfold interp_nes. have he := to_nonempty_list_spec prems. destruct to_nonempty_list. pose proof to_nonempty_list_spec'. @@ -6024,7 +6024,7 @@ Proof. subst v. pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. rewrite hmin in premeq. - eapply Nat.le_trans. 2:{ eapply interp_prems_ge; tea. } + eapply Nat.le_trans. 2:{ eapply interp_nes_ge; tea. } unfold interp_expr. destruct prem as [prem k']. symmetry in premeq. move: premeq. unfold min_atom_value. @@ -6076,11 +6076,11 @@ End Nat_as_OT. Module NatSet := MSetList.MakeWithLeibniz Nat_as_OT. -Definition interp_prems_nat V e := LevelExprSet.fold (fun e acc => NatSet.add (interp_expr V e) acc) e NatSet.empty. +Definition interp_nes_nat V e := LevelExprSet.fold (fun e acc => NatSet.add (interp_expr V e) acc) e NatSet.empty. -Lemma interp_prems_eq V (u : univ) : interp_prems V u = LevelExprSet.fold (fun e acc => Nat.max (interp_expr V e) acc) u 0. +Lemma interp_nes_eq V (u : univ) : interp_nes V u = LevelExprSet.fold (fun e acc => Nat.max (interp_expr V e) acc) u 0. Proof. - rewrite /interp_prems. + rewrite /interp_nes. have he := to_nonempty_list_spec u. destruct to_nonempty_list. pose proof to_nonempty_list_spec'. @@ -6152,9 +6152,9 @@ Proof. lia. Qed. -Lemma interp_add_prems V n e : interp_prems V (add_prems n e) = n + interp_prems V e. +Lemma interp_add_prems V n e : interp_nes V (add_prems n e) = n + interp_nes V e. Proof. - rewrite !interp_prems_eq. + rewrite !interp_nes_eq. rewrite !LevelExprSetProp.fold_spec_right. rewrite Universes.fold_right_map (Universes.fold_right_map _ (interp_expr V)). rewrite fold_right_comm_add_n. @@ -6178,10 +6178,10 @@ Proof. eapply In_add_prems. exists (l, k); split => //. Qed. -Lemma interp_prems_singleton V e : - interp_prems V (singleton e) = interp_expr V e. +Lemma interp_nes_singleton V e : + interp_nes V (singleton e) = interp_expr V e. Proof. - rewrite /interp_prems. + rewrite /interp_nes. now rewrite singleton_to_nonempty_list /=. Qed. @@ -6198,14 +6198,14 @@ Proof. destruct concl as [concl conclk]. rewrite /add_expr; cbn. lia. - intros V clsm. cbn. - rewrite interp_prems_singleton. + rewrite interp_nes_singleton. cbn. lia. Qed. -Lemma interp_prems_add V cl (u : univ) : - interp_prems V (add cl u) = Nat.max (interp_expr V cl) (interp_prems V u). +Lemma interp_nes_add V cl (u : univ) : + interp_nes V (add cl u) = Nat.max (interp_expr V cl) (interp_nes V u). Proof. - rewrite !interp_prems_eq. unfold add. cbn. + rewrite !interp_nes_eq. unfold add. cbn. destruct (LevelExprSetProp.In_dec cl u). erewrite LevelExprSetProp.add_fold => //. 2-3:tc. 2:red; lia. rewrite LevelExprSetProp.fold_spec_right. @@ -6221,10 +6221,10 @@ Proof. Qed. Lemma clauses_sem_subset {u u' : univ} : u ⊂_leset u' -> - forall V, interp_prems V u' >= interp_prems V u. + forall V, interp_nes V u' >= interp_nes V u. Proof. intros hsub V. - rewrite !interp_prems_eq. red. + rewrite !interp_nes_eq. red. rewrite !LevelExprSetProp.fold_spec_right. rewrite !(Universes.fold_right_map _ (interp_expr V)). eapply fold_right_impl. intros x. @@ -6243,12 +6243,12 @@ Proof. induction 1. - intros v clls. red. destruct concl0 as [concl k]. - now have hge := interp_prems_ge v prems _ H. + now have hge := interp_nes_ge v prems _ H. - move=> V Hcls. move: {IHentails} (IHentails _ Hcls). unfold clause_sem. unfold ge => hyp. - etransitivity; tea. rewrite interp_prems_add. - rewrite interp_prems_add in hyp. + etransitivity; tea. rewrite interp_nes_add. + rewrite interp_nes_add in hyp. eapply in_pred_closure_entails in H; tea. move: H; rewrite /clause_sem. unfold ge. have ssub := clauses_sem_subset H1 V. lia. @@ -6256,12 +6256,12 @@ Qed. Lemma clauses_sem_entails_all {cls prems concl} : cls ⊢a prems → concl -> - (forall V, clauses_sem V cls -> interp_prems V prems >= interp_prems V concl). + (forall V, clauses_sem V cls -> interp_nes V prems >= interp_nes V concl). Proof. intros ha V hcls. red in ha. move: ha. - rewrite (interp_prems_eq _ concl); cbn. + rewrite (interp_nes_eq _ concl); cbn. destruct concl as [concl t_ne]; cbn. clear t_ne. eapply LevelExprSetProp.fold_rec. - lia. diff --git a/template-rocq/theories/Junk.v b/template-rocq/theories/Junk.v index 693c4305f..28d69512e 100644 --- a/template-rocq/theories/Junk.v +++ b/template-rocq/theories/Junk.v @@ -836,7 +836,7 @@ Qed. *) Proof. move=> [v sat] [e]. move/presentation_entails_valid_rel/(_ Z_semilattice v sat). cbn. - rewrite interp_add_prems. change (add 1%Z (interp_prems v e)) with (Z.add 1 (interp_prems v e)). + rewrite interp_add_prems. change (add 1%Z (interp_nes v e)) with (Z.add 1 (interp_nes v e)). cbn -[Z.add]. lia. Qed. diff --git a/utils/theories/MROption.v b/utils/theories/MROption.v index f9f691fad..55a2fedd2 100644 --- a/utils/theories/MROption.v +++ b/utils/theories/MROption.v @@ -46,6 +46,34 @@ Definition R_opt {A} (R : relation A) : relation (option A) := | _, _ => False end. +Instance R_opt_refl {A R} : @Reflexive A R -> Reflexive (R_opt R). +Proof. + intros hr []; cbn; reflexivity. +Qed. + +Instance R_opt_sym {A R} : @Symmetric A R -> Symmetric (R_opt R). +Proof. + intros hr [] []; cbn => //. now symmetry. +Qed. + +Instance R_opt_trans {A R} : @Transitive A R -> Transitive (R_opt R). +Proof. + intros hr [] [] []; cbn => //. intros; now etransitivity. +Qed. + +Instance R_opt_equiv {A R} : @Equivalence A R -> Equivalence (R_opt R). +Proof. + split; tc. +Qed. + +Definition option_map2 {A B} (f : A -> A -> B) (o o' : option A) : option B := + match o, o' with + | Some x, Some y => Some (f x y) + | None, Some _ + | Some _, None + | None, None => None + end. + Definition option_default {A B} (f : A -> B) (o : option A) (b : B) := match o with Some x => f x | None => b end. diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v index 06e091990..883c1a062 100644 --- a/utils/theories/NonEmptyLevelExprSet.v +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -577,7 +577,8 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) firstorder eauto. subst. firstorder. Qed. - Definition add_expr n '((l, k) : LevelExpr.t) := (l, CommutativeMonoid.add n k). + Definition add_expr n (le : LevelExpr.t) := + let '(l, k) := le in (l, CommutativeMonoid.add n k). Lemma add_expr_add_expr n n' lk : add_expr n (add_expr n' lk) = add_expr (CommutativeMonoid.add n n') lk. Proof. destruct lk; unfold add_expr. f_equal. symmetry. @@ -646,7 +647,7 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) Lemma add_expr_0 e : add_expr CommutativeMonoid.zero e = e. Proof. - destruct e => //=. now rewrite neutral. + destruct e. rewrite /add_expr. now rewrite neutral. Qed. Lemma add_prems_0 u : add_prems CommutativeMonoid.zero u = u. @@ -700,9 +701,10 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) Context {S: Type} {SL : Semilattice S Q.t}. Context (v : Level.t -> S). - Definition interp_expr '(l, k) := (add k (v l)). + Definition interp_expr le := + let '(l, k) := le in (add k (v l)). - Definition interp_prems prems := + Definition interp_nes prems := let '(hd, tl) := to_nonempty_list prems in fold_right (fun lk acc => join (interp_expr lk) acc) (interp_expr hd) tl. @@ -712,19 +714,19 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) destruct e as [l k]; cbn. now rewrite add_distr. Qed. - Lemma interp_prems_singleton e : - interp_prems (singleton e) = interp_expr e. + Lemma interp_nes_singleton e : + interp_nes (singleton e) = interp_expr e. Proof. - rewrite /interp_prems. + rewrite /interp_nes. now rewrite singleton_to_nonempty_list /=. Qed. - Lemma interp_prems_ge (prems : t) : + Lemma interp_nes_ge (prems : t) : forall prem, LevelExprSet.In prem prems -> - interp_expr prem ≤ interp_prems prems. + interp_expr prem ≤ interp_nes prems. Proof. intros. - unfold interp_prems. + unfold interp_nes. have he := to_nonempty_list_spec prems. destruct to_nonempty_list. pose proof to_nonempty_list_spec'. @@ -741,10 +743,10 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) * specialize (IHl H). etransitivity; tea. apply join_le_right. Qed. - Lemma interp_prems_elements u : - interp_prems u = fold_right join (interp_expr (to_nonempty_list u).1) (List.map (interp_expr) (to_nonempty_list u).2). + Lemma interp_nes_elements u : + interp_nes u = fold_right join (interp_expr (to_nonempty_list u).1) (List.map (interp_expr) (to_nonempty_list u).2). Proof. - rewrite /interp_prems. + rewrite /interp_nes. have he := to_nonempty_list_spec u. destruct to_nonempty_list. now rewrite fold_right_map. @@ -779,10 +781,10 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) apply LevelExprSet.add_spec. now apply LevelExprSet.elements_spec1 in h. Qed. - Lemma interp_prems_add le (u : t) : - interp_prems (NonEmptyLevelExprSet.add le u) ≡ join (interp_expr le) (interp_prems u). + Lemma interp_nes_add le (u : t) : + interp_nes (NonEmptyLevelExprSet.add le u) ≡ join (interp_expr le) (interp_nes u). Proof. - rewrite 2!interp_prems_elements. + rewrite 2!interp_nes_elements. erewrite fold_right_interp. 2:apply equivlistA_add. rewrite fold_right_comm. { apply map_nil, elements_not_empty. } @@ -791,39 +793,39 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) destruct to_nonempty_list. rewrite -he //=. Qed. - Lemma interp_prems_elim (P : t -> S -> Prop) : + Lemma interp_nes_elim (P : t -> S -> Prop) : Proper (Logic.eq ==> eq ==> iff) P -> (forall le, P (singleton le) (interp_expr le)) -> (forall le u k, P u k -> ~ LevelExprSet.In le u -> P (NonEmptyLevelExprSet.add le u) (join (interp_expr le) k)) -> - forall u, P u (interp_prems u). + forall u, P u (interp_nes u). Proof. intros prop hs hadd. eapply elim. - - intros le. rewrite interp_prems_singleton. apply hs. + - intros le. rewrite interp_nes_singleton. apply hs. - intros le prems ih hnin. - rewrite interp_prems_add. now apply hadd. + rewrite interp_nes_add. now apply hadd. Qed. - Lemma interp_add_prems n e : interp_prems (add_prems n e) ≡ add n (interp_prems e). + Lemma interp_add_prems n e : interp_nes (add_prems n e) ≡ add n (interp_nes e). Proof. revert e. - refine (interp_prems_elim (fun u z => interp_prems (add_prems n u) ≡ add n z) _ _ _). + refine (interp_nes_elim (fun u z => interp_nes (add_prems n u) ≡ add n z) _ _ _). - intros p p' eq a a' eq'. subst p'. now rewrite eq'. - intros le. - rewrite add_prems_singleton interp_prems_singleton //=. + rewrite add_prems_singleton interp_nes_singleton //=. destruct le; cbn. now rewrite add_distr. - intros le u k heq hnin. rewrite add_prems_add. - rewrite interp_prems_add heq interp_add_expr. + rewrite interp_nes_add heq interp_add_expr. now rewrite add_join. Qed. - Lemma interp_prems_in {le} {u : t} : - LevelExprSet.In le u -> interp_expr le ≤ interp_prems u. + Lemma interp_nes_in {le} {u : t} : + LevelExprSet.In le u -> interp_expr le ≤ interp_nes u. Proof. revert u. - refine (interp_prems_elim (fun u z => LevelExprSet.In le u -> interp_expr le ≤ z) _ _ _). + refine (interp_nes_elim (fun u z => LevelExprSet.In le u -> interp_expr le ≤ z) _ _ _). - intros ? ? <- x y eq. now rewrite eq. - intros le' u'. apply LevelExprSet.singleton_spec in u'. red in u'; subst. @@ -834,36 +836,36 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) now apply join_le_right_trans. Qed. - Lemma interp_prems_union {x y : t} : - interp_prems (x ∪ y) ≡ - join (interp_prems x) (interp_prems y). + Lemma interp_nes_union {x y : t} : + interp_nes (x ∪ y) ≡ + join (interp_nes x) (interp_nes y). Proof. move: x; apply elim. - intros []. rewrite union_comm union_add_singleton. - now rewrite interp_prems_add interp_prems_singleton. + now rewrite interp_nes_add interp_nes_singleton. - intros le' x ih hnin. - rewrite union_add_distr !interp_prems_add ih. cbn. + rewrite union_add_distr !interp_nes_add ih. cbn. now rewrite join_assoc. Qed. - Lemma interp_prems_subset {u u' : t} : u ⊂_leset u' -> - interp_prems u ≤ interp_prems u'. + Lemma interp_nes_subset {u u' : t} : u ⊂_leset u' -> + interp_nes u ≤ interp_nes u'. Proof. intros hsub. revert u u' hsub. - refine (interp_prems_elim (fun u z => forall u' : t, u ⊂_leset u' -> - z ≤ interp_prems u') _ _ _). + refine (interp_nes_elim (fun u z => forall u' : t, u ⊂_leset u' -> + z ≤ interp_nes u') _ _ _). - intros ?? <- ?? eq. now setoid_rewrite eq. - intros le u' hsing. specialize (hsing le). forward hsing by now apply LevelExprSet.singleton_spec. - now apply interp_prems_in. + now apply interp_nes_in. - intros le u k ih hin u' sub. have hle := sub le. specialize (ih u'). forward ih. intros x hin'. apply sub. now apply LevelExprSet.add_spec; right. forward hle by now apply LevelExprSet.add_spec; left. - have hi := interp_prems_in hle. + have hi := interp_nes_in hle. apply join_le_left_eq. split => //. Qed. diff --git a/utils/theories/SemiLattice.v b/utils/theories/SemiLattice.v index 11d18dae1..d2348b689 100644 --- a/utils/theories/SemiLattice.v +++ b/utils/theories/SemiLattice.v @@ -1,8 +1,9 @@ (* Distributed under the terms of the MIT license. *) +From Equations Require Import Equations. From Stdlib Require Import ssreflect ssrbool ssrfun ZArith. From Stdlib Require Import Program RelationClasses Morphisms SetoidList. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import MRPrelude MRClasses MRList. +From MetaRocq.Utils Require Import MRPrelude MRClasses MRList MROption. Set Equations Transparent. @@ -14,6 +15,8 @@ Module Semilattice. Local Open Scope comm_monoid. Reserved Notation "x ≡ y" (at level 70). + + #[mode="! ! -"] Class Semilattice (carrier : Type) (incr : Type) `{CM : IsCommMonoid incr} := { eq : carrier -> carrier -> Prop where "x ≡ y" := (eq x y) : sl_scope; eq_equiv :: Equivalence eq; @@ -42,33 +45,34 @@ Module Semilattice. Infix "<" := lt (at level 70) : sl_scope. Class JoinDec (carrier : Type) `{SL : Semilattice carrier} := - { join_dec x y : (join x y ≡ x) \/ (join y x ≡ y) }. + { join_dec (x y : carrier) : (join x y ≡ x) \/ (join y x ≡ y) }. Local Open Scope sl_scope. Section Derived. Context {A : Type} {incr : Type} {CM : IsCommMonoid incr} {SL : Semilattice A incr}. - + Implicit Type x y s t u : A. Lemma join_congr_r x y y' : y ≡ y' -> join x y ≡ join x y'. Proof. intros he; etransitivity. apply join_comm. etransitivity. 2:apply join_comm. now apply join_congr. Qed. - - #[export] Instance proper_join : Proper (eq ==> eq ==> eq) join. + #[export] Instance proper_join : Proper (eq ==> eq ==> eq) (@join A incr _ _). Proof. intros x y ? x0 y0 ?. transitivity (join y x0). now apply join_congr. now apply join_congr_r. Qed. - #[export] Instance proper_add : Proper (Logic.eq ==> eq ==> eq) add. + #[export] Instance proper_add : Proper (Logic.eq ==> eq ==> eq) (@add A incr _ _). Proof. intros x y ? x0 y0 ?. subst y. now apply add_congr. Qed. Lemma le_refl x : x ≤ x. Proof. apply join_idem. Qed. + Lemma le_trans x y z : x ≤ y -> y ≤ z -> x ≤ z. Proof. unfold le; intros le le'. now rewrite -le' -join_assoc le. Qed. - #[export] Instance le_preorder : PreOrder le. + + #[export] Instance le_preorder : @PreOrder A le. Proof. split. - intros ?; apply le_refl. @@ -86,7 +90,7 @@ Module Semilattice. apply join_comm. Qed. - #[export] Instance proper_le : Proper (eq ==> eq ==> iff) le. + #[export] Instance proper_le : Proper (eq ==> eq ==> iff) (@le A incr _ _). Proof. intros x y ? x0 y0 ?. apply eq_antisym in H0 as []. apply eq_antisym in H as []. @@ -103,12 +107,12 @@ Module Semilattice. - intros []. red in H0. apply eq_antisym. split => //. Qed. - Lemma join_le_left {s t} : s ≤ s ∨ t. + Lemma join_le_left {s t : A} : s ≤ s ∨ t. Proof. red. now rewrite -join_assoc join_idem. Qed. - Lemma join_le_left_trans {s t u} : s ≤ t -> s ≤ t ∨ u. + Lemma join_le_left_trans {s t u : A} : s ≤ t -> s ≤ t ∨ u. Proof. transitivity t => //. apply join_le_left. Qed. Lemma join_le_right {s t} : t ≤ s ∨ t. @@ -129,6 +133,18 @@ Module Semilattice. now rewrite join_assoc le' le. Qed. + Lemma join_le_pres {s t u v} : + s ≤ t -> u ≤ v -> s ∨ u ≤ t ∨ v. + Proof. + intros le le'. + rewrite join_le_left_eq. split. + - setoid_rewrite le. apply join_le_left. + - setoid_rewrite le'. apply join_le_right. + Qed. + + #[export] Instance proper_join_le : Proper (le ==> le ==> le) (@join A incr _ _). + Proof. intros x y ? x0 y0 ?. now apply join_le_pres. Qed. + Lemma join_le_right_impl {s t u} : s ≤ t \/ s ≤ u -> s ≤ t ∨ u. Proof. @@ -163,6 +179,7 @@ Module Semilattice. Import CommutativeMonoid. Context {A : Type} {V : Type} {CM : IsCommMonoid V} {SL : Semilattice A V}. Open Scope sl_scope. + Implicit Types n : A. Lemma fold_right_max_in {a : A} {l : list A} n : In a l -> a ≤ (fold_right join n l). Proof. @@ -172,14 +189,14 @@ Module Semilattice. cbn. specialize (IHl inl). etransitivity; tea. apply join_le_right. Qed. - Lemma fold_right_max_acc {n l} : n ≤ fold_right join n l. + Lemma fold_right_max_acc {n : A} {l} : n ≤ fold_right join n l. Proof. induction l. - now cbn. - cbn. etransitivity; tea. eapply join_le_right. Qed. - Lemma fold_right_impl n l l' : + Lemma fold_right_impl (n : A) l l' : (forall x, In x l -> In x l') -> fold_right join n l ≤ fold_right join n l'. Proof. induction l in l' |- *. @@ -239,7 +256,7 @@ Module Semilattice. now symmetry. Qed. - Lemma fold_right_comm acc l : l <> [] -> fold_right join acc l ≡ join acc (fold_right join (List.hd acc l) (List.tl l)). + Lemma fold_right_comm (acc : A) l : l <> [] -> fold_right join acc l ≡ join acc (fold_right join (List.hd acc l) (List.tl l)). Proof. induction l in acc |- *. - intros; congruence. @@ -252,3 +269,87 @@ Module Semilattice. End FoldSemilattice. End Semilattice. + +Section OptSemilattice. + Obligation Tactic := idtac. + Import Semilattice. + + Context {S Q} {CM : CommutativeMonoid.IsCommMonoid Q} (SL : Semilattice S Q). + + (* The semilattice on possibly undefined elements: two elements are equal iff + they are both undefined or both defined to equal elements of {S}. *) + Equations? opt_semi : Semilattice (option S) Q := + opt_semi := {| + eq x y := R_opt (@eq _ _ CM SL) x y; + eq_equiv := _; + add n x := option_map (add n) x; + join := option_map2 join |}. + Proof. + all: intros. + - destruct x => //=. now rewrite add_distr. + - destruct x, y; cbn in * => //. now apply add_congr. + - destruct x => //=. apply add_neutral. + - destruct x, y, z => //=. apply join_assoc. + - destruct x, y => //=. apply join_comm. + - destruct x, x', y; cbn in * => //. now apply join_congr. + - destruct x => //=. apply join_idem. + - destruct x => //=. apply join_sub. + - destruct x, y => //=; cbn in *. now eapply add_inj. + - destruct x, y => //=; cbn in *; now eapply add_join. + Defined. + Existing Instance opt_semi. + + (* None is greater than any element in this semilattice *) + Lemma le_spec {x y : option S} : x ≤ y <-> + (y = None) \/ (exists x' y', x = Some x' /\ y = Some y' /\ le x' y'). + Proof. + rewrite /le. cbn. destruct x, y => //=. + - split. + * intros hc. right. exists s, s0. split => //. + * now move=> [] => // -[x' [y' [[= ->]]]] [[= ->]]. + - split; auto. + - split => //; auto. case => //. case => [] x [] y [] => //. + - now split => //. + Qed. + + (* The alternative notions of strict inequality and equality *) + Definition le_strict (x y : option S) := + match x, y with + | Some x, Some y => x ≤ y + | _, _ => False + end. + + Infix "≤!" := le_strict (at level 50). + + Lemma le_strict_spec {x y : option S} : x ≤! y <-> + (exists x' y', x = Some x' /\ y = Some y' /\ le x' y'). + Proof. + rewrite /le. cbn. destruct x, y => //=. + - split. + * intros hc. exists s, s0. split => //. + * now move=> // -[x' [y' [[= ->]]]] [[= ->]]. + - split => //. case => x [] y [] ? [] => //. + - split => //. case => x [] y [] ? [] => //. + - split => //. case => x [] y [] => //. + Qed. +(* + (* The alternative notions of strict inequality and equality *) + Definition eq_strict (x y : option S) := + match x, y with + | Some x, Some y => x ≤ y + | _, _ => False + end. + + Lemma eq_strict_spec {x y : option S} : x y <-> + (exists x' y', x = Some x' /\ y = Some y' /\ le x' y'). + Proof. + rewrite /le. cbn. destruct x, y => //=. + - split. + * intros hc. exists s, s0. split => //. + * now move=> // -[x' [y' [[= ->]]]] [[= ->]]. + - split => //. case => x [] y [] ? [] => //. + - split => //. case => x [] y [] ? [] => //. + - split => //. case => x [] y [] => //. + Qed. *) + +End OptSemilattice. \ No newline at end of file From 6d49d28f54dd0df58f19024266554632d633794c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 3 Oct 2025 10:59:25 +0200 Subject: [PATCH 089/164] Compiling again --- common/theories/LoopChecking/Deciders.v | 110 +++++++++++------- .../LoopChecking/PartialLoopChecking.v | 66 +++++++++-- .../theories/LoopChecking/UnivLoopChecking.v | 11 +- 3 files changed, 131 insertions(+), 56 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 29f4f8afb..cfd6517b9 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -91,7 +91,7 @@ Definition print_level_Z_map (m : LevelMap.t (option Z)) := Definition print_result {V cls} (m : infer_result V cls) := match m return string with - | Loop _ _ => "looping on " + | Loop _ _ _ => "looping on " | Model w m _ => "satisfiable with model: " ^ print_level_Z_map m.(model_model) ^ nl ^ " W = " ^ print_lset w ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model m.(model_model)) @@ -99,7 +99,7 @@ Definition print_result {V cls} (m : infer_result V cls) := Definition valuation_of_result {V cls} (m : infer_result V cls) := match m with - | Loop _ _ => "looping" + | Loop _ _ _ => "looping" | Model w m _ => print_level_nat_map (valuation_of_model m.(model_model)) end. @@ -123,7 +123,7 @@ Definition valuation := LevelMap.t nat. Equations? infer_model (cls : clauses) : model + premises := infer_model cls with loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (init_model cls) _ := - | Loop v _ => inr v + | Loop v _ _ => inr v | Model w vm heq => inl vm.(model_model). Proof. split. @@ -334,7 +334,7 @@ Next Obligation. Qed. Variant check_result {cls} := - | IsLooping (v : premises) (islooping : loop_on_univ cls v) + | IsLooping (v : premises) (hincl : NES.levels v ⊂_lset clauses_levels cls) (islooping : loop_on_univ cls v) | Invalid | Valid. Arguments check_result : clear implicits. @@ -353,19 +353,20 @@ Proof. Qed. Equations check (cls : clauses) (cl : clause) : check_result cls := - check cls cl with loop_check cls cl := - | Loop v isl => IsLooping v isl - | Model W v _ with inspect (LevelMap.find (concl cl).1 v.(model_model)) := { - | exist (Some val) he with check_atom_value (Some (concl cl).2) val := +check cls cl with inspect (loop_check cls cl) := + { | exist (Loop v _ isl) he => IsLooping v _ isl + | exist (Model W v _) he with inspect (LevelMap.find (concl cl).1 v.(model_model)) := { + | exist (Some val) he' with check_atom_value (Some (concl cl).2) val := { | true => Valid | false => Invalid } - | exist None he with valid_model_find v he := {} - }. + | exist None he' with valid_model_find v he' := {} + } + }. Definition check_clauses (cls : clauses) (cls' : clauses) : bool := let check_one cl := match check cls cl with - | IsLooping _ _ => false + | IsLooping _ _ _ => false | Valid => true | Invalid => false end @@ -379,7 +380,7 @@ Proof. destruct cl as [prems [concl k]]. funelim (check cls _) => // _. set (V := (clause_levels _ ∪ clauses_levels cls)%levels) in *. - clear Heqcall H. cbn [concl fst snd] in *. clear Heq0. + clear Heqcall H H0. cbn [concl fst snd] in *. move/check_atom_value_spec: Heq; intros h; depelim h. rename H into hgt. have vmupd := model_updates v. have vmok := model_ok v. @@ -395,18 +396,18 @@ Proof. have of_lset := of_level_map_premises_model_map cls cl V nepm. have tr := entails_all_trans of_lset ent. eapply (entails_all_satisfies (l := concl0) (k := k)) in tr. - 2:{ red. rewrite /level_value he. now constructor. } + 2:{ red. rewrite /level_value he'. now constructor. } exact tr. Qed. -Lemma check_entails_looping {cls cl v isl} : - check cls cl = IsLooping v isl -> cls ⊢a v → succ_prems v. +Lemma check_entails_looping {cls cl v vcls isl} : + check cls cl = IsLooping v vcls isl -> cls ⊢a v → succ_prems v. Proof. funelim (check cls cl) => //. Qed. -Lemma check_looping {cls cl v isl} : - check cls cl = IsLooping v isl -> +Lemma check_looping {cls cl v vcls isl} : + check cls cl = IsLooping v vcls isl -> ~ (exists m, defined_model_of (levels v) m /\ is_model cls m). Proof. move/check_entails_looping. @@ -418,30 +419,25 @@ Proof. now apply enabled_clauses_le. Qed. -(* Lemma check_valid_looping {cls cl m v isl} : - enabled_clauses m cls -> +Lemma check_valid_looping {cls cl m v vcls isl} : is_model cls m -> - check cls cl = IsLooping v isl -> False. + check cls cl = IsLooping v vcls isl -> + defined_model_of (levels v) m -> False. Proof. - move=> en ism. - rewrite /check /loop_check. - destruct loop. - - /check_looping; apply. - destruct def as [def isupd]. - exists m'. split => //. - move: isupd; move/is_update_of_case => []. - * move=> [] empw eq. rewrite -eq. - exists m. -Qed. *) + move=> ism. + move/check_looping => ex hdef. apply ex. + exists m. split => //. +Qed. Theorem check_invalid {cls cl} : check cls cl = Invalid -> exists m, [/\ is_model cls m, enabled_clause m cl & ~ valid_clause m cl]. Proof. funelim (check cls cl) => //. + clear H H0 he. set (V := (clause_levels cl ∪ clauses_levels cls)%levels) in *. destruct cl as [prems [concl k]]. - rename val into conclval_v => _. clear H Heq0 Heqcall prf. cbn in he. + rename val into conclval_v => _. + clear Heqcall prf. move: (check_atom_value_spec (Some k) conclval_v). rewrite Heq. intros r; depelim r. rename H into nent. have vmupd := model_updates v. @@ -466,7 +462,8 @@ Proof. destruct en as [z minp]. move/valid_clause_elim/(_ z minp). cbn in minp. - rewrite /level_value he => h; depelim h. apply nent. + cbn in he'. + rewrite /level_value he' => h; depelim h. apply nent. constructor. cbn -[check_atom_value] in Heq. have posz : 0 <= z. { have hsu := model_updates v. @@ -628,6 +625,9 @@ Module CorrectModel. Definition model_of {V cls} (x : t V cls) := x.(model_valid).(model_model). Coercion model_of : t >-> model. + Lemma is_model_of {V cls} (x : t V cls) : is_model cls (model_of x). + Proof. apply x.(model_valid). Qed. + Lemma declared_zero_model_of {V cls} (x :t V cls) : zero_declared (model_of x). Proof. have h := declared_zero x. @@ -697,7 +697,7 @@ Module CorrectModel. (declp : declared_pos V init) : result V (Clauses.union cls cls') := infer_extension_correct m enabled hincl hs cls' hs' hdeclz hdecla hdeclp with infer_extension m hincl hs cls' := - | Loop u isl => inr {| loop_univ := u; loop_on_univ := isl |} + | Loop u vcls isl => inr {| loop_univ := u; loop_on_univ := isl |} | Model w m' _ => inl {| initial_model := min_model_map m.(model_model) cls'; @@ -2225,6 +2225,35 @@ Module Abstract. Qed. + Lemma defined_model (m : t) : defined_model_of (levels m) (model_of m). + Proof. + intros l hin. + have [k hm] := declared_pos_model_of m l hin. + now exists (Z.of_nat k). + Qed. + + Definition declared_clauses_levels V cls := LevelSet.Subset (clauses_levels cls) V. + + Lemma defined_model_of_subset {V V' m} : LevelSet.Subset V V' -> defined_model_of V' m -> defined_model_of V m. + Proof. + now move=> sub def l /sub /def. + Qed. + + Lemma entails_dec (m : t) cl : + { entails (clauses m) cl } + { ~ entails (clauses m) cl }. + Proof. + destruct (check (clauses m) cl) eqn:ch. + - move/check_looping: ch; elim. + exists (model_of m). split. + { have dm := defined_model m. + eapply defined_model_of_subset; tea. + eapply defined_model_of_subset; tea. + apply clauses_levels_declared. } + exact: is_model_of m. + - move/check_invalid_entails: ch. now right. + - move/check_entails: ch. now left. + Qed. + (** ~ (x >= y) <-> (y > x)*) (* cls ⊭ x >= y, so cls + x < y is consistent, validates all clauses *) @@ -2241,12 +2270,17 @@ Module Abstract. [/\ positive_opt_valuation v, clauses_sem v cls & ~ clause_sem v cl]. *) + Definition valid_clauses_nat cls cl := + forall v : Level.t -> Z, clauses_sem v cls -> ~ clause_sem v cl. +(* Lemma enforce_inverse_model m minv cl : is_model (clauses m) minv -> ~ valid_clause minv cl -> exists m', enforce_inverse m cl = Some (inl m'). Proof. intros ism inval. + Search entails. + Search enforce_clauses. rewrite /enforce_inverse. destruct enforce_clauses eqn:ec. destruct s. @@ -2270,7 +2304,7 @@ Module Abstract. admit. - move/enforce_clauses_None: ec. admit. - Admitted. + Admitted. *) @@ -2387,7 +2421,7 @@ Module LoopChecking (LS : LevelSets). Import Semilattice. Lemma enforce_inconsistent {m cls u} : enforce m cls = Some (inr u) -> - forall S (SL : Semilattice.Semilattice S Q.t) V, clauses_sem V (Clauses.union (clauses m) (to_clauses cls)) -> + forall S (SL : Semilattice.Semilattice S Q.t) (V : Level.t -> S), clauses_sem V (Clauses.union (clauses m) (to_clauses cls)) -> clauses_sem V (Impl.CorrectModel.loop_univ u ≡ succ (Impl.CorrectModel.loop_univ u)). Proof. rewrite /enforce. @@ -2398,10 +2432,6 @@ Module LoopChecking (LS : LevelSets). specialize (vr S SL V). move: vr. rewrite !interp_rels_clauses_sem // => vr /vr. - (* rewrite -interp_rels_clauses_sem. - rewrite clauses_sem_eq. - setoid_rewrite interp_add_prems; cbn -[Z.add]. - lia. *) Qed. Lemma enforce_clauses {m cls m'} : diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index 7cdf0440d..45d29ac40 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -189,8 +189,15 @@ Proof. now eapply entails_all_clauses_subset. Qed. +Definition declared_clause_levels V cl := LevelSet.Subset (clause_levels cl) V. + +Lemma declared_clause_levels_mon {V V' cl} : LevelSet.Subset V V' -> declared_clause_levels V cl -> declared_clause_levels V' cl. +Proof. + now move => sub h l /h. +Qed. + Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := - | Loop (v : premises) (islooping : loop_on_univ cls v) + | Loop (v : premises) (hincl : LevelSet.Subset (levels v) (clauses_levels cls)) (islooping : loop_on_univ cls v) | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). Arguments Loop {V U cls m}. Arguments Model {V U cls m}. @@ -346,7 +353,7 @@ Qed. Definition option_of_result {V U m cls} (r : result V U m cls) : option model := match r with | Model w m _ => Some m.(model_model) - | Loop v _ => None + | Loop v _ _ => None end. Notation loop_measure V W := (#|V|, #|V| - #|W|)%nat. @@ -562,14 +569,14 @@ Section InnerLoop. by wf (measure W cls m) lt := inner_loop_partition m upd with loop W LevelSet.empty premconclW (restrict_model W m) (restrict_model W m) _ _ := { (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) - | Loop u isl => Loop u (loop_on_subset _ isl) + | Loop u incl isl => Loop u _ (loop_on_subset _ isl) (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). By invariant Wr ⊂ W *) | Model Wr mr empWr with inspect (check_model conclW (Wr, model_update m (model_model mr))) := { | exist None eqm => Model Wr {| model_model := model_update m (model_model mr) |} _ | exist (Some (Wconcl, mconcl)) eqm with inner_loop_partition mconcl _ := { (* Here Wr ⊂ Wconcl by invariant *) - | Loop u isl => Loop u isl + | Loop u incl isl => Loop u incl isl | Model Wr' mr' UWconcl => Model (LevelSet.union Wconcl Wr') {| model_model := model_model mr' |} _ } (* Here Wr' ⊂ W by invariant *) (* We check if the new model [mr] for (cls ⇂ W) extends to a model of (cls ↓ W). *) @@ -590,6 +597,8 @@ Section InnerLoop. * now eapply strictly_updates_restrict_only_model. * eapply is_update_of_empty. - left. now eapply strict_subset_cardinal. + - transitivity (clauses_levels premconclW) => //. + eapply clauses_levels_mon. rewrite eqprem. apply restrict_clauses_subset. - rewrite eqprem. eapply restrict_clauses_subset. - have mu := model_updates mr. setoid_rewrite eqprem at 1 in mu. @@ -686,6 +695,14 @@ End InnerLoop. (* To help equations *) Opaque lexprod_rel_wf. +Lemma is_update_of_incl {cls : clauses} {W : LevelSet.t} {m m' : model} : + is_update_of cls W m m' -> W ⊂_lset clauses_conclusions cls. +Proof. + move/is_update_of_case => [[he heq]|]. + - intros l; lsets. + - now move/strictly_updates_incl. +Qed. + Local Open Scope Z_scope. #[tactic="idtac"] @@ -695,33 +712,42 @@ Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : mod loop V U cls minit m prf with inspect (check_model cls (U, m)) := | exist None eqm => Model U {| model_model := m |} _ | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { - | exist true eq := Loop (of_level_map minit (check_model_defined_init_map prf eqm)) _ + | exist true eq := Loop (of_level_map minit (check_model_defined_init_map prf eqm)) _ _ (* Loop on cls ↓ W, with |W| < |V| *) | exist false neq with inner_loop V U minit loop W (cls ↓ W) m' _ := - { | Loop u isloop := Loop u (loop_on_subset _ isloop) + { | Loop u incl isloop := Loop u _ (loop_on_subset _ isloop) | Model Wc mwc _ (* We get a model for (cls ↓ W), we check if it extends to all clauses. By invariant |Wc| cannot be larger than |W|. *) with inspect (check_model cls (Wc, mwc.(model_model))) := { | exist None eqm' => Model (LevelSet.union W Wc) {| model_model := mwc.(model_model) |} _ | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { - | exist true _ := Loop (of_level_map m' (check_model_defined_map eqm)) _ + | exist true _ := Loop (of_level_map m' (check_model_defined_map eqm)) _ _ | exist false neq' with loop V (LevelSet.union W Wcls) cls minit mcls _ := { (* Here Wcls < V, we've found a model for all of the clauses with conclusion in W, which can now be fixed. We concentrate on the clauses whose conclusion is different. Clearly |W| < |V|, but |Wcls| is not necessarily < |V| *) - | Loop u isloop := Loop u isloop + | Loop u incl isloop := Loop u incl isloop | Model Wvw mcls' hsub := Model Wvw {| model_model := model_model mcls' |} _ } } } } } . Proof. - all:cbn -[cls_diff clauses_with_concl restrict_clauses]; clear loop. + all:cbn -[of_level_map cls_diff clauses_with_concl restrict_clauses]; clear loop. all:try solve [intuition auto]. all:try eapply levelset_neq in neq. all:have cls_sub := clauses_conclusions_levels cls. all:destruct prf as [clsV mof isupd]. + - red. eapply LevelSet.equal_spec in eq0. + set (prf := check_model_defined_init_map _ _); clearbody prf. + eapply check_model_is_update_of in eqm; tea. rewrite eq0 in eqm. + destruct eqm. rewrite union_idem in H. eapply strictly_updates_incl in H. + have heq : V =_lset clauses_levels cls. + { intros l. split. move/H. apply clauses_conclusions_levels. apply clsV. } + intros l. rewrite -heq. + rewrite levels_spec => -[k]. + rewrite of_level_map_spec. specialize (mof l). rewrite mof. now eexists. - red. eapply LevelSet.equal_spec in eq0. set (prf := check_model_defined_init_map _ _); clearbody prf. eapply check_model_is_update_of in eqm; tea. rewrite eq0 in eqm. @@ -736,8 +762,28 @@ Proof. * now eapply strictly_updates_non_empty. * apply clauses_conclusions_clauses_with_concl. * eapply strictly_updates_strenghten. exact eqm. - + - intros l; move/incl. apply clauses_levels_mon. apply clauses_with_concl_subset. - now intros ?; rewrite in_clauses_with_concl. + - apply LevelSet.equal_spec in e. + set (ne := check_model_defined_map _). clearbody ne. + have hu := model_updates mwc. + eapply check_model_is_update_of in eqm as [eqm incl]; tea. + have om : only_model_of V m'. + { rewrite union_idem in eqm. + have incl' := strictly_updates_incl eqm. + have hcl := clauses_conclusions_levels cls. + eapply strictly_updates_only_model_gen in eqm; tea. eapply only_model_of_eq; tea. intro; lsets. } + eapply strictly_updates_is_update_of in eqm; tea. + rewrite union_idem union_with_concl in eqm. + eapply check_model_update_of in eqm' as [wmcls [upd eq]]. + intros l. rewrite levels_spec => -[k hin]. + eapply of_level_map_spec in hin. + specialize (om l) as [_ incl']. + forward incl'. now eexists. rewrite -e in incl'. + eapply strictly_updates_incl in eqm. + eapply is_update_of_incl in upd. + apply cls_sub. move: incl'; rewrite eq LevelSet.union_spec => -[] incl'. + apply eqm. lsets. now apply upd. - set (ne := check_model_defined_map _). clearbody ne. have hu := model_updates mwc. eapply check_model_is_update_of in eqm as [eqm incl]; tea. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 00e486cd2..1c3ea5912 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -738,7 +738,7 @@ End ZUnivConstraint. End interp. - Lemma interp_univ_cstrs_relations {S} {SL : Semilattice S Z} v cstrs : + Lemma interp_univ_cstrs_relations {S} {SL : Semilattice S Z} (v : Level.t -> S) cstrs : interp_univ_cstrs v cstrs <-> interp_rels v (relations_of_constraints (to_z_cstrs cstrs)). Proof. @@ -1346,7 +1346,7 @@ End ZUnivConstraint. LevelSet.fold add_val V (LevelMap.empty _). - Lemma clauses_sem_subset {S} {SL : Semilattice.Semilattice S Q.t} {v cls cls'} : clauses_sem v cls -> cls' ⊂_clset cls -> clauses_sem v cls'. + Lemma clauses_sem_subset {S} {SL : Semilattice.Semilattice S Q.t} {v : Level.t -> S} {cls cls'} : clauses_sem v cls -> cls' ⊂_clset cls -> clauses_sem v cls'. Proof. now move=> hall hsub cl /hsub. Qed. @@ -1838,12 +1838,12 @@ End ZUnivConstraint. Existing Instance Impl.CorrectModel.Zopt_semi. - Instance nat_opt_semi : Semilattice (option nat) nat := Impl.CorrectModel.opt_semi Natsemilattice. + Instance nat_opt_semi : Semilattice (option nat) nat := opt_semi Natsemilattice. - Import Impl.CorrectModel (positive_valuation, opt_valuation_of_model_pos). + Import Impl.CorrectModel (positive_valuation, positive_opt_valuation, opt_valuation_of_model_pos). Definition valid_Z_model m c := - (forall (v : Level.t -> option Z), positive_valuation v -> interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + (forall (v : Level.t -> option Z), positive_opt_valuation v -> interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). Infix "⊩Z" := valid_Z_model (at level 70, no associativity). @@ -1869,7 +1869,6 @@ End ZUnivConstraint. Qed. *) - Theorem check_completeness {m c} : check m c <-> m ⊩Z c. Proof. From e7b06fe52a1d862eacc4436f6ee6dc22dbe5a7b4 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 3 Oct 2025 23:03:53 +0200 Subject: [PATCH 090/164] Finished proof, which required considering consistent but not entailed constraints --- common/theories/LoopChecking/Deciders.v | 729 +++++++++++++----- .../LoopChecking/HornSemilatticeEquiv.v | 21 +- .../theories/LoopChecking/UnivLoopChecking.v | 41 - 3 files changed, 551 insertions(+), 240 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index cfd6517b9..7772a444b 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -679,6 +679,7 @@ Module CorrectModel. Qed. Record loop {cls} := { loop_univ : premises; + loop_incl : NES.levels loop_univ ⊂_lset clauses_levels cls; loop_on_univ : cls ⊢a loop_univ → succ_prems loop_univ; }. Arguments loop : clear implicits. @@ -1649,13 +1650,13 @@ Module Abstract. Import I.Model.Model.Clauses.ISL. - Lemma enforce_clauses_inconsistent m cls u : + Lemma enforce_clauses_loop m cls u : enforce_clauses m cls = Some (inr u) -> entails_L_clauses (Clauses.union (clauses m) cls) (loop_univ u ≡ succ_prems (loop_univ u)). Proof. funelim (enforce_clauses m cls) => //=. intros [= <-]. clear -u. - destruct u as [u loop]. cbn [loop_univ]. + destruct u as [u incl loop]. cbn [loop_univ]. eapply to_entails_all in loop. apply entails_L_clauses_eq; split; revgoals. - now eapply entails_ℋ_entails_L. @@ -1664,6 +1665,156 @@ Module Abstract. apply entails_all_succ. Qed. + + (* Returns the valuation of the model: a minimal assignement from levels to constraints + that make the enforced clauses valid. *) + Definition valuation m := to_val (Model.valuation_of_model (model m)). + + (** This is a valuation in Z, which defaults to 0 for undefined universes. It enables all clauses. *) + Definition model_valuation m : clauses_sem (to_Z_val (valuation m)) (clauses m). + Proof. + destruct m as [levels clauses []]; cbn. + apply valid_clauses_model; tea; cbn. + - eapply enabled_clauses_ext; tea; cbn. + eapply is_update_of_ext, model_valid0. + - apply model_valid. + Qed. + + Definition opt_valuation (m : t) := opt_valuation_of_model (model m). + + (** This is a valuation in Z⊥ *) + Definition model_opt_Z_valuation m : clauses_sem (opt_valuation m) (clauses m). + Proof. + apply valid_clauses_model_opt; tea; cbn. + apply model_valid. + Qed. + + Definition enables_clause val cl := + exists k, interp_nes val (premise cl) = Some k. + + Definition enables_clauses val cls := Clauses.For_all (enables_clause val) cls. + + Definition valuation_of_model model := + to_Z_val (to_val (Model.valuation_of_model model)). + + Definition consistent_opt_val (val : Level.t -> option Z) (cls : Clauses.t) := + (* enables_clauses val cls /\ *) + clauses_sem val cls. + + Definition consistent_opt cls := exists val : Level.t -> option Z, consistent_opt_val val cls. + + Definition consistent cls := + exists val : Level.t -> Z, positive_valuation val /\ clauses_sem val cls. + + (* +Lemma opt_valuation_of_model_equiv m l : + option_get 0%Z (opt_valuation_of_model m l) = to_Z_val (to_val (valuation_of_model m)) l. + Proof. + rewrite /opt_valuation_of_model /to_Z_val /to_val. + case: find_spec. + * move=> k hm. + destruct k => //. + have he := valuation_of_model_spec m l _ hm. + apply LevelMap.find_1 in he. rewrite he. todo "bounds". + apply LevelMap.find_1 in hm. cbn. todo "zero". + * move=> hnin. cbn. todo "zero". + Qed. *) + + Lemma min_atom_value_mapsto {m le k} : min_atom_value m le = Some k -> + LevelMap.MapsTo le.1 (Some (k + le.2)) m. + Proof. + rewrite /min_atom_value. + destruct le. case: (@level_valueP m t0) => // -[k'|] // hm [=] <-. + cbn. now have -> : k' - z + z = k' by lia. + Qed. + + Lemma mapsto_opt_valuation_of_model {m l k} : + LevelMap.MapsTo l (Some k) m -> + opt_valuation_of_model m l = Some (valuation_of_value m k). + Proof. + rewrite /opt_valuation_of_model => hm; apply LevelMap.find_1 in hm. + now rewrite hm. + Qed. + + Lemma min_premise_interp_nes_ex {m u minp} : + min_premise m u = Some minp -> + exists z, interp_nes (opt_valuation_of_model m) u = Some z /\ + (exists maxx maxk, LevelExprSet.In maxx u /\ LevelMap.MapsTo maxx.1 (Some maxk) m /\ z = valuation_of_value m maxk + maxx.2) /\ + forall x, LevelExprSet.In x u -> exists k, LevelMap.MapsTo x.1 (Some k) m /\ + valuation_of_value m k + x.2 <= z /\ minp <= k - x.2. + Proof. + move: u minp. + apply: NES.elim. + { intros [l lk]. rewrite interp_nes_singleton min_premise_singleton //= => minp. + case: (@level_valueP m l) => // -[] // vl hm [=] <-. + rewrite (mapsto_opt_valuation_of_model hm) //=. + eexists; split => //. + setoid_rewrite LevelExprSet.singleton_spec. split. + do 2 eexists; split; trea. split; tea. cbn. lia. + intros x ->. eexists; split => //. exact hm. split => //. cbn. lia. cbn. lia. } + { intros [l k] u. + intros h nin minp. + rewrite min_premise_add. + destruct min_atom_value eqn:hmin => //. + 2:{ now move/min_opt_None_left. } + destruct (min_premise m u) => //. + specialize (h _ eq_refl) as [z1 [? [[maxx [maxk [inmax [mmax maxle]]]]]]]. + cbn. intros [= <-]. + have ha := (NES.interp_nes_add (SL := Zopt_semi) (opt_valuation_of_model m) (l, k) u). + rewrite H in ha. + have hminv := min_atom_value_mapsto hmin. cbn in hminv. + cbn [interp_expr] in ha. + rewrite (mapsto_opt_valuation_of_model hminv) in ha. + cbn [eq Zopt_semi] in ha. + destruct (interp_nes _ (NES.add _ _)); cbn in ha => //. + subst z2. eexists; split; trea. + split. + destruct (Z.max_spec (k + valuation_of_value m (z + k)) z1) as [[hle heq]|[hle heq]]. + * do 2 eexists; split => //. eapply LevelExprSet.add_spec. now right. + split; tea. now subst z1. + * do 2 eexists; split => //. eapply LevelExprSet.add_spec. left; trea. + split. exact hminv. cbn in *. lia. + * intros x; rewrite LevelExprSet.add_spec => -[]. + + intros ->. eexists; split; tea. cbn. lia. + + move/H0 => [k' [hm [hle hle']]]. eexists; split; tea. lia. } + Qed. + + Lemma opt_valuation_enables m : enables_clauses (opt_valuation m) (clauses m). + Proof. + have hen := enabled_model m. + have hupd := I.model_updates m.(model_valid). + eapply is_update_of_ext in hupd. + eapply enabled_clauses_ext in hen; tea. + move: hen. + cbn. rewrite /opt_valuation /opt_valuation_of_model /model /model_of. + generalize (model_model (model_valid m)). + generalize (clauses m). + clear; intros cls m en. + move=> cl /en; clear. + destruct cl as [prems concl]; rewrite /enabled_clause /enables_clause; cbn. + intros [k hmin]. + move/min_premise_interp_nes_ex: hmin => [z [eq rest]]. now exists z. + Qed. + + Lemma clauses_consistent_opt_val m : consistent_opt_val (opt_valuation m) (clauses m). + Proof. + (* split. *) + (* apply opt_valuation_enables. *) + apply model_opt_Z_valuation. + Qed. + + Lemma clauses_consistent_opt m : consistent_opt (clauses m). + Proof. + eexists; eapply clauses_consistent_opt_val. + Qed. + + Lemma clauses_consistent m : consistent (clauses m). + Proof. Admitted. + + Definition inconsistent_opt cls := ~ (consistent_opt cls). + + Definition inconsistent cls := ~ (consistent cls). + Definition check_clauses m cls := check_clauses (clauses m) cls. @@ -1765,25 +1916,27 @@ Module Abstract. now move=> [] /hcl hin ->. Qed. + Lemma interp_rel_clause_sem {S} {SL : Semilattice S Q.t} {V : Level.t -> S} {cl} : + clause_sem V cl <-> interp_rel V (relation_of_clause cl). + Proof. + destruct cl as [prems concl] => //=. + now rewrite /le interp_nes_union interp_nes_singleton. + Qed. + Lemma interp_rels_clauses_sem {S} {SL : Semilattice S Q.t} {V : Level.t -> S} {cls} : clauses_sem V cls <-> interp_rels V (relations_of_clauses cls). Proof. rewrite interp_rels_of_clauses. split. - - move=> sem [prems concl] /sem //=. - now rewrite /le interp_nes_union interp_nes_singleton. - - move=> hcl [prems concl] /hcl /=. - now rewrite /le interp_nes_union interp_nes_singleton. + - move=> sem cl /sem; apply interp_rel_clause_sem. + - move=> hcl cl /hcl /=. apply interp_rel_clause_sem. Qed. - Definition Z_valuation_of_model m := - to_Z_val (to_val (valuation_of_model (model m))). - Lemma model_entails_succ m v : clauses m ⊢a v → succ v -> False. Proof. move/to_entails_all/entails_L_entails_ℋ_equiv. move/entails_L_rels_entails_L_clauses/completeness_all. - move/(_ Z _ (Z_valuation_of_model m)). + move/(_ Z _ (valuation_of_model m)). rewrite -!interp_rels_clauses_sem => /fwd. cbn in *. have mok := m.(correct_model).(model_valid).(model_ok). @@ -1813,6 +1966,85 @@ Module Abstract. exfalso. elim he. now apply hv. Qed. + Lemma enforce_clauses_inconsistent_semilattice {m cls u} : + enforce_clauses m cls = Some (inr u) -> + forall S (SL : Semilattice.Semilattice S Q.t) (V : Level.t -> S), + clauses_sem V (Clauses.union (clauses m) cls) -> + clauses_sem V (loop_univ u ≡ succ (loop_univ u)). + Proof. + move/enforce_clauses_loop. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -ISL.completeness_all. + move=> vr S SL V. + specialize (vr S SL V). + move: vr. + rewrite !interp_rels_clauses_sem // => vr /vr. + Qed. + + Lemma enforce_clauses_inconsistent_opt {m cls u} : + enforce_clauses m cls = Some (inr u) -> + inconsistent_opt (Clauses.union (clauses m) cls). + Proof. + move/enforce_clauses_inconsistent_semilattice => ec [v cs]. + move: (ec (option Z) _ v cs). + rewrite clauses_sem_eq //= interp_add_prems //=. + destruct u as [loop incl hloop]. cbn. + admit. + Admitted. + + Lemma enforce_clauses_inconsistent {m cls u} : + enforce_clauses m cls = Some (inr u) -> + inconsistent (Clauses.union (clauses m) cls). + Proof. + move/enforce_clauses_inconsistent_semilattice => ec [v [posv cs]]. + move: (ec Z _ v cs). + rewrite clauses_sem_eq //= interp_add_prems //=. lia. + Qed. + + (* Lemma enforce_clauses_inconsistent_opt {m cls u} : + enforce_clauses m cls = Some (inr u) -> + inconsistent_opt (Clauses.union (clauses m) cls). + Proof. + move/enforce_clauses_inconsistent_semilattice => ec [v cs]. + red in cs. destruct cs as [en cs]. + move: (ec _ _ v cs). + destruct u as [loop incl eq]. cbn in ec. + rewrite clauses_sem_eq //= interp_add_prems //=. + red in en. unfold enables_clause in en. + rewrite interp_nes_defined. + Qed. *) + + Definition inconsistent_ext m cls := + forall v : Level.t -> Z, positive_valuation v -> clauses_sem v (clauses m) -> ~ clauses_sem v cls. + + Lemma enforce_dec m cls : + clauses_levels cls ⊂_lset levels m -> + { consistent (Clauses.union (clauses m) cls) } + { inconsistent_ext m cls }. + Proof. + intros hm. + destruct (enforce_clauses m cls) eqn:ec. + destruct s as [model|loop]. + - left. move/enforce_clauses_clauses: ec. + intros <-. apply clauses_consistent. + - right. move/enforce_clauses_inconsistent: ec. + intros he v vpos semcs semc. apply he. exists v. split => //. + apply clauses_sem_union. split => //. + - move/enforce_clauses_None: ec. contradiction. + Qed. + + Lemma enforce_dec_opt m cls : + clauses_levels cls ⊂_lset levels m -> + { consistent_opt (Clauses.union (clauses m) cls) } + { ~ consistent_opt (Clauses.union (clauses m) cls) }. + Proof. + intros hm. + destruct (enforce_clauses m cls) eqn:ec. + destruct s as [model|loop]. + - left. move/enforce_clauses_clauses: ec. + intros <-. exact: (clauses_consistent_opt model). + - right. now move/enforce_clauses_inconsistent_opt: ec. + - move/enforce_clauses_None: ec. contradiction. + Qed. + Definition valid_entailments cls cls' := forall S (SL : Semilattice S Q.t) (V : Level.t -> S), clauses_sem V cls -> clauses_sem V cls'. @@ -1851,7 +2083,7 @@ Module Abstract. Qed. Lemma valuation_of_model_inv {m l k} : - LevelMap.MapsTo l k (valuation_of_model m) -> + LevelMap.MapsTo l k (Model.valuation_of_model m) -> exists k', LevelMap.MapsTo l k' m /\ k = Z.to_nat (valuation_of_value m (option_get 0%Z k')). Proof. (* destruct k. *) @@ -1862,79 +2094,6 @@ Module Abstract. exists z. split => //. *) Admitted. - - Lemma mapsto_opt_valuation_of_model {m l k} : - LevelMap.MapsTo l (Some k) m -> - opt_valuation_of_model m l = Some (valuation_of_value m k). - Proof. - rewrite /opt_valuation_of_model => hm; apply LevelMap.find_1 in hm. - now rewrite hm. - Qed. - - Lemma opt_valuation_of_model_equiv m l : - option_get 0%Z (opt_valuation_of_model m l) = to_Z_val (to_val (valuation_of_model m)) l. - Proof. - rewrite /opt_valuation_of_model /to_Z_val /to_val. - case: find_spec. - * move=> k hm. - destruct k => //. - have he := valuation_of_model_spec m l _ hm. - apply LevelMap.find_1 in he. rewrite he. todo "bounds". - apply LevelMap.find_1 in hm. cbn. todo "zero". - * move=> hnin. cbn. todo "zero". - Qed. - - Lemma min_atom_value_mapsto {m le k} : min_atom_value m le = Some k -> - LevelMap.MapsTo le.1 (Some (k + le.2)) m. - Proof. - rewrite /min_atom_value. - destruct le. case: (@level_valueP m t0) => // -[k'|] // hm [=] <-. - cbn. now have -> : k' - z + z = k' by lia. - Qed. - - Lemma min_premise_interp_nes_ex {m u minp} : - min_premise m u = Some minp -> - exists z, interp_nes (opt_valuation_of_model m) u = Some z /\ - (exists maxx maxk, LevelExprSet.In maxx u /\ LevelMap.MapsTo maxx.1 (Some maxk) m /\ z = valuation_of_value m maxk + maxx.2) /\ - forall x, LevelExprSet.In x u -> exists k, LevelMap.MapsTo x.1 (Some k) m /\ - valuation_of_value m k + x.2 <= z /\ minp <= k - x.2. - Proof. - move: u minp. - apply: NES.elim. - { intros [l lk]. rewrite interp_nes_singleton min_premise_singleton //= => minp. - case: (@level_valueP m l) => // -[] // vl hm [=] <-. - rewrite (mapsto_opt_valuation_of_model hm) //=. - eexists; split => //. - setoid_rewrite LevelExprSet.singleton_spec. split. - do 2 eexists; split; trea. split; tea. cbn. lia. - intros x ->. eexists; split => //. exact hm. split => //. cbn. lia. cbn. lia. } - { intros [l k] u. - intros h nin minp. - rewrite min_premise_add. - destruct min_atom_value eqn:hmin => //. - 2:{ now move/min_opt_None_left. } - destruct (min_premise m u) => //. - specialize (h _ eq_refl) as [z1 [? [[maxx [maxk [inmax [mmax maxle]]]]]]]. - cbn. intros [= <-]. - have ha := (NES.interp_nes_add (SL := Zopt_semi) (opt_valuation_of_model m) (l, k) u). - rewrite H in ha. - have hminv := min_atom_value_mapsto hmin. cbn in hminv. - cbn [interp_expr] in ha. - rewrite (mapsto_opt_valuation_of_model hminv) in ha. - cbn [eq Zopt_semi] in ha. - destruct (interp_nes _ (NES.add _ _)); cbn in ha => //. - subst z2. eexists; split; trea. - split. - destruct (Z.max_spec (k + valuation_of_value m (z + k)) z1) as [[hle heq]|[hle heq]]. - * do 2 eexists; split => //. eapply LevelExprSet.add_spec. now right. - split; tea. now subst z1. - * do 2 eexists; split => //. eapply LevelExprSet.add_spec. left; trea. - split. exact hminv. cbn in *. lia. - * intros x; rewrite LevelExprSet.add_spec => -[]. - + intros ->. eexists; split; tea. cbn. lia. - + move/H0 => [k' [hm [hle hle']]]. eexists; split; tea. lia. } - Qed. - Lemma interp_expr_inv {m le k} : interp_expr (opt_valuation_of_model m) le = Some k -> exists k', LevelMap.MapsTo le.1 (Some k') m /\ k = le.2 + valuation_of_value m k'. @@ -1946,14 +2105,6 @@ Module Abstract. exists z. split => //. Qed. - Definition enables_clause val cl := - exists k, interp_nes val (premise cl) = Some k. - - Definition enables_clauses val cls := Clauses.For_all (enables_clause val) cls. - - Definition valuation_of_model model := - to_Z_val (to_val (Model.valuation_of_model model)). - Lemma interp_expr_defined {model} le : defined_model_of (LevelSet.singleton le.1) model -> interp_expr (opt_valuation_of_model model) le = Some (interp_expr (valuation_of_model model) le). @@ -2029,6 +2180,21 @@ Module Abstract. { intros l hin'; apply def. eapply clauses_levels_spec. now exists cl. } Qed. + + Definition valuation_max V v := + LevelSet.fold (fun l acc => match v l with Some k => Z.max k acc | None => acc end) V 0%Z. + + Definition valuation_min V v := + LevelSet.fold (fun l acc => match v l with Some k => Z.min k acc | None => acc end) V 0%Z. + + Definition value_of_valuation V v k := + let max := valuation_max V v in + let min := valuation_min V v in + min + k - max. + + Definition levels_of_model (m : Model.model) := + LevelMap.fold (fun l _ => LevelSet.add l) m LevelSet.empty. + Lemma clause_sem_valid {model cl} : clause_sem (opt_valuation_of_model model) cl -> valid_clause model cl. Proof. @@ -2122,7 +2288,7 @@ Module Abstract. rewrite -entails_L_entails_ℋ_equiv. rewrite -entails_L_rels_entails_L_clauses. rewrite -ISL.completeness_all. - move/(_ Z _ (Z_valuation_of_model m)). + move/(_ Z _ (valuation_of_model m)). rewrite -interp_rels_clauses_sem. move/(_ (model_valuation m)). rewrite -interp_rels_clauses_sem. @@ -2153,7 +2319,7 @@ Module Abstract. rewrite -entails_L_entails_ℋ_equiv. rewrite -entails_L_rels_entails_L_clauses. rewrite -ISL.completeness_all. - move/(_ Z _ (Z_valuation_of_model m)). + move/(_ Z _ (valuation_of_model m)). rewrite -interp_rels_clauses_sem. move/(_ (model_valuation m)). rewrite -interp_rels_clauses_sem. @@ -2240,7 +2406,7 @@ Module Abstract. Qed. Lemma entails_dec (m : t) cl : - { entails (clauses m) cl } + { ~ entails (clauses m) cl }. + { entails (clauses m) cl } + { ~ entails (clauses m) cl /\ exists v : Level.t -> option Z, [/\ positive_opt_valuation v, clauses_sem v (clauses m) & ~ clause_sem v cl] }. Proof. destruct (check (clauses m) cl) eqn:ch. - move/check_looping: ch; elim. @@ -2250,61 +2416,301 @@ Module Abstract. eapply defined_model_of_subset; tea. apply clauses_levels_declared. } exact: is_model_of m. - - move/check_invalid_entails: ch. now right. + - have ci := check_invalid_valuation ch. + move/check_invalid_entails: ch. now right. - move/check_entails: ch. now left. Qed. - (** ~ (x >= y) <-> (y > x)*) - (* cls ⊭ x >= y, so cls + x < y is consistent, validates all clauses *) + Definition valid_clause_opt cls cl := + forall v : Level.t -> option Z, + positive_opt_valuation v -> + clauses_sem v cls -> clause_sem v cl. + + Definition valid_clause_total cls cl := + forall v : Level.t -> Z, + positive_valuation v -> + clauses_sem v cls -> clause_sem v cl. + + Definition model_of_valuation V v := + LevelSet.fold (fun l => LevelMap.add l (option_map (value_of_valuation V v) (v l))) V (LevelMap.empty _). + + Definition to_Z_val (v : Level.t -> option Z) := + fun l => option_get 0 (v l). + + Lemma entails_L_completeness {p l r} : + (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v p -> interp_nes v l ≡ interp_nes v r)%sl -> + p ⊢ℒ l ≡ r. + Proof. + intros hv. + specialize (hv _ (init_model p) (ids p)). + forward hv. + { apply interp_rels_init. } + rewrite !interp_triv in hv. + exact hv. + Qed. +About entails_L_entails_ℋ. + + Lemma entails_L_clause_clauses {cls cl} : entails_L_pres_clause (relations_of_clauses cls) cl <-> entails_L_clauses cls (Clauses.singleton cl). + Proof. + rewrite /entails_L_clauses. + rewrite /entails_L_pres_clauses. + split. + - intros en c; rsets. now subst c. + - rsets. specialize (H cl). forward H; now rsets. + Qed. + + Lemma relations_of_clauses_singleton cl : relations_of_clauses (Clauses.singleton cl) = [relation_of_clause cl]. + Proof. destruct cl; reflexivity. Qed. + + Lemma interp_rels_tip {S} {SL : Semilattice S Q.t} (v : Level.t -> S) r : interp_rels v [r] <-> interp_rel v r. + Proof. + split. + - now intros h; depelim h. + - now constructor. + Qed. + + Lemma entails_completeness {cls cl} : + (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), clauses_sem v cls -> clause_sem v cl)%sl <-> + entails cls cl. + Proof. + split. + - intros hv. + eapply entails_L_entails_ℋ_equiv. + 2:{ now eapply Clauses.singleton_spec. } + intros c. rewrite Clauses.singleton_spec => ->. + red. eapply entails_L_completeness. + intros S SL v. specialize (hv S SL v). + rewrite -interp_rels_clauses_sem. move/hv. + destruct cl; cbn => //. + rewrite interp_nes_union interp_nes_singleton //. + - move/entails_entails_L. + move/entails_L_clause_clauses. + move/entails_L_rels_entails_L_clauses. + move/completeness_all. + unfold valid_relations. + setoid_rewrite interp_rels_clauses_sem. + setoid_rewrite interp_rel_clause_sem. + rewrite relations_of_clauses_singleton. + now setoid_rewrite interp_rels_tip. + Qed. + + Lemma contraP P Q : (P -> Q) -> (~ Q -> ~ P). + Proof. intros f hp q. apply (hp (f q)). Qed. Definition inverse_clauses (cl : clause) := let (prems, concl) := cl in clauses_of_le (succ_prems prems) (singleton concl). + Lemma clauses_sem_subset {S} {SL : Semilattice.Semilattice S Q.t} {v : Level.t -> S} {cls cls'} : clauses_sem v cls -> cls' ⊂_clset cls -> clauses_sem v cls'. + Proof. + now move=> hall hsub cl /hsub. + Qed. + + Import Semilattice. + + Lemma clauses_sem_clauses_of_le (V : Level.t -> Z) l r : + clauses_sem V (clauses_of_le l r) -> + (interp_nes V l ≤ interp_nes V r)%sl. + Proof. + rewrite /clauses_sem. + intros hl. red in hl. + setoid_rewrite clauses_of_le_spec in hl. + move: l hl. apply: elim. + - move => le he. + rewrite interp_nes_singleton. + move: (he (r, le)) => /fwd. + exists le. split => //. now apply LevelExprSet.singleton_spec. + cbn. lia. + - intros le x ih hnin ih'. + rewrite interp_nes_add. + forward ih. intros x0 [x1 [hin ->]]. + move: (ih' (r, x1)) => /fwd. exists x1. split => //. apply LevelExprSet.add_spec. now right. + auto. + move: (ih' (r, le)) => /fwd. exists le. split => //. apply LevelExprSet.add_spec. now left. + cbn. cbn in ih. lia. + Qed. + + Lemma clauses_sem_tot_inverse_false (v : Level.t -> Z) (cl : clause) : + clauses_sem v (inverse_clauses cl) -> + clause_sem v cl -> + False. + Proof. + destruct cl as [prems concl]. + cbn [clause_sem]. move/clauses_sem_clauses_of_le. + rewrite interp_add_prems interp_nes_singleton. cbn; lia. + Qed. + + + Lemma neg_inverse (v : Level.t -> Z) (cl : clause) : + ~ (clauses_sem v (inverse_clauses cl)) <-> clause_sem v cl. + Proof. + destruct cl as [prems concl]. + cbn [clause_sem]. rewrite clauses_sem_leq. + rewrite interp_add_prems interp_nes_singleton. cbn; lia. + Qed. + + Lemma neg_inverse_opt (v : Level.t -> option Z) (cl : clause) : + ~ (clauses_sem v (inverse_clauses cl)) <-> clause_sem v cl. + Proof. + destruct cl as [prems concl]. + cbn [clause_sem]. rewrite clauses_sem_leq. + rewrite interp_add_prems interp_nes_singleton. cbn. + destruct (interp_expr v concl) eqn:e => //=; + destruct (interp_nes v prems) eqn:e' => //=. + lia. lia. admit. + Admitted. + Definition enforce_inverse m cl := enforce_clauses m (inverse_clauses cl). -(* ~ (x <= y) <-> (x <= y -> succ x <= x). - check cls cl = Invalid -> - exists v : Level.t -> option Z, - [/\ positive_opt_valuation v, clauses_sem v cls & ~ clause_sem v cl]. -*) + (*Lemma not_entails_invalid {m cl} : ~ entails (clauses m) cl -> ~ (forall m', clauses_sem v (clauses m) -> clause_sem v cl). + Proof. + destruct cl as [prems [concl k]]. + intros ne. + move/valid_clause_elim => hz. - Definition valid_clauses_nat cls cl := - forall v : Level.t -> Z, clauses_sem v cls -> ~ clause_sem v cl. -(* - Lemma enforce_inverse_model m minv cl : - is_model (clauses m) minv -> - ~ valid_clause minv cl -> - exists m', enforce_inverse m cl = Some (inl m'). - Proof. - intros ism inval. - Search entails. - Search enforce_clauses. - rewrite /enforce_inverse. - destruct enforce_clauses eqn:ec. - destruct s. - - eexists; trea. - - move/enforce_clauses_inconsistent: ec. - rewrite -entails_L_rels_entails_L_clauses. - rewrite -completeness_all. - move/(_ Z _ (Z_valuation_of_model m)). - rewrite -!interp_rels_clauses_sem. - rewrite clauses_sem_union. - rewrite -def_clause_sem_valid in inval. admit. + nv. - move=> /fwd. split. admit. - Search valid_clause. - Search interp_rels. + [hm [en hv]]. + have ev := entails_model_valid. + destruct (entails_dec m cl). contradiction. + destruct a. destruct H0 as [v []]. apply H2. + apply ne. + destruct (entails_dec m cl). + destruct + Search entails. *) + (* Lemma inconsistent_decompose {m cls'} : inconsistent (Clauses.union (clauses m) cls') -> + forall v : Level.t -> Z, clauses_sem v (clauses m) -> clauses_sem v cls' -> False. + Proof. + intros ni v cs cs'. apply ni. exists v. apply clauses_sem_union. split => //. + Qed. *) + Lemma inconsistent_opt_decompose {m cls'} : inconsistent_opt (Clauses.union (clauses m) cls') -> + forall v : Level.t -> option Z, clauses_sem v (clauses m) -> clauses_sem v cls' -> False. + Proof. + intros ni v cs cs'. apply ni. exists v. red. apply clauses_sem_union. split => //. + Admitted. - rewrite entails_ℋ_ - admit. - - move/enforce_clauses_None: ec. - admit. - Admitted. *) + Definition defined_valuation_of V (v : Level.t -> option Z) := + forall l, LevelSet.In l V -> exists x, v l = Some x. + + Definition incon m cls := + forall v : Level.t -> option Z, + defined_valuation_of (clauses_levels cls) v -> + clauses_sem v (clauses m) -> clauses_sem v cls -> False. + + Lemma cl_inverse_consistent_opt {m cl} : incon m (inverse_clauses cl) -> entails (clauses m) cl. + Proof. + move=> i. + have hc : forall v : Level.t -> option Z, + defined_valuation_of (clause_levels cl) v -> + clauses_sem v (clauses m) -> clause_sem v cl. + { intros v def cs. specialize (i v). forward i. admit. + apply neg_inverse_opt in i; tea. } + have hcheck := check_clauses_spec m (Clauses.singleton cl). + have hcheckz := check_clauses_Z_complete m (Clauses.singleton cl). + rewrite hcheck in hcheckz. apply hcheckz. + red. intros v cs cl' hin. eapply Clauses.singleton_spec in hin. subst cl'. + apply hc. admit. exact cs. clsets. + Admitted. + + (* Lemma cl_inverse_consistent {m cl} : inconsistent_opt (Clauses.union (clauses m) (inverse_clauses cl)) -> entails (clauses m) cl. + Proof. + move/inconsistent_decompose => i. + have hc : forall v : Level.t -> Z, clauses_sem v (clauses m) -> clause_sem v cl. + { intros v cs. specialize (i v cs). + now apply neg_inverse in i. } + have hcheck := check_clauses_spec m (Clauses.singleton cl). + have hcheckz := check_clauses_Z_complete m (Clauses.singleton cl). + rewrite hcheck in hcheckz. apply hcheckz. + red. intros v cs cl' hin. eapply Clauses.singleton_spec in hin. subst cl'. + apply hc. + + rewrite -(@entails_completeness (clauses m) cl). + + + destruct (entails_dec m cl). auto. + destruct a as [a _]. + move: (i (valuation_of_model m)) => /fwd. + apply model_valuation. elim. clear i. + destruct cl as [prems concl]; cbn. + rewrite clauses_sem_leq. + rewrite interp_add_prems. + cbn -[le]. rewrite interp_nes_singleton. + rewrite -(@entails_completeness (clauses m) (prems, concl)) in a. + + Search clauses_sem. + Search valuation_of_model. + Admitted. *) + Lemma entails_singleton cls cl : cls ⊢ℋ Clauses.singleton cl <-> entails cls cl. + Proof. Admitted. + + Lemma clause_levels_inverse cl : + clauses_levels (inverse_clauses cl) =_lset clause_levels cl. + Proof. + intros l. destruct cl as [prems concl]. + rewrite clauses_levels_spec. + rewrite /inverse_clauses. + rewrite clause_levels_spec => //=. + split; firstorder. + - eapply clauses_of_le_spec in H. + destruct H as [lk [hin eq]]. subst x. + apply clause_levels_spec in H0. + destruct H0; cbn in *; firstorder. + right. apply NES.levels_spec in H as []. + rsets. subst. left. + apply In_add_prems in hin as [le' []]. subst lk. + cbn. apply levels_spec. exists le'.2. destruct le' => //. + - apply levels_spec in H as [k hin]. + exists ((singleton concl), (l, add 1 k)). split. + apply clauses_of_le_spec. exists (l, add 1 k); split => //. + apply In_add_prems. eexists; split; trea. reflexivity. + apply clause_levels_spec. now right; cbn. + - subst. exists (singleton concl, choose (succ prems)). + split. apply clauses_of_le_spec. + exists (choose (succ prems)). split => //. apply choose_spec. + apply clause_levels_spec. left; cbn. + apply levels_spec; exists concl.2. destruct concl; cbn. now rsets. + Qed. + + + Lemma validity_decidable m cl : + clause_levels cl ⊂_lset levels m -> + { valid_clause_total (clauses m) cl } + { ~ valid_clause_total (clauses m) cl }. + Proof. + intros hwf. + (* Check *) + destruct (entails_dec m cl). + - left. intros h hpov hsem. + rewrite -entails_completeness in e. + now apply e. + - destruct a as [a ne]. + have hcheck := check_clauses_spec m (Clauses.singleton cl). + have hcheckz := check_clauses_Z_complete m (Clauses.singleton cl). + (* rewrite entails_singleton in hcheck. *) + (* rewrite -hcheck hcheckz in a. *) + unfold valid_semilattice_entailments in a. + destruct (enforce_dec m (inverse_clauses cl)) => //. + * setoid_rewrite <- hwf. + now rewrite clause_levels_inverse. + * right. intros vc. + destruct c as [tot [totpos csem]]. + apply clauses_sem_union in csem as [cls cinv]. + red in vc. move: (vc tot) => /fwd. exact: totpos. + move=>/(_ cls) => hcl. + now eapply clauses_sem_tot_inverse_false. + * (* the converse m /\ j < i |= is inconsistent, + so i <= j is consistent but not entailed. *) + left. + red in i. + red. intros v posv semcs. + specialize (i v posv semcs). now apply neg_inverse in i. + Qed. + + Definition valid_clauses_nat cls cl := + forall v : Level.t -> Z, clauses_sem v cls -> ~ clause_sem v cl. @@ -2474,63 +2880,6 @@ Module LoopChecking (LS : LevelSets). check m c <-> valid_clauses (clauses m) (to_clauses c). Proof. apply check_clauses_Z_positive_complete. Qed. - (* Returns the valuation of the model: a minimal assignement from levels to constraints - that make the enforced clauses valid. *) - Definition valuation m := to_val (Model.valuation_of_model (model m)). - - (** This is a valuation in Z, which defaults to 0 for undefined universes. It enables all clauses. *) - Definition model_valuation m : clauses_sem (to_Z_val (valuation m)) (clauses m). - Proof. - destruct m as [levels clauses []]; cbn. - apply valid_clauses_model; tea; cbn. - - eapply enabled_clauses_ext; tea; cbn. - eapply is_update_of_ext, model_valid0. - - apply model_valid. - Qed. - - Definition opt_valuation (m : t) := opt_valuation_of_model (model m). - - (** This is a valuation in Z⊥ *) - Definition model_opt_Z_valuation m : clauses_sem (opt_valuation m) (clauses m). - Proof. - apply valid_clauses_model_opt; tea; cbn. - apply model_valid. - Qed. - - Definition consistent_val val (cls : Clauses.t) := - enables_clauses val cls /\ clauses_sem val cls. - - Definition consistent cls := exists val : Level.t -> option Z, consistent_val val cls. - - Lemma opt_valuation_enables m : enables_clauses (opt_valuation m) (clauses m). - Proof. - have hen := enabled_model m. - have hupd := model_updates m.(model_valid). - eapply is_update_of_ext in hupd. - eapply enabled_clauses_ext in hen; tea. - move: hen. rewrite /clauses. - cbn. rewrite /opt_valuation /model /Impl.Abstract.model. - unfold Impl.CorrectModel.model_of. - generalize (model_model (model_valid m)). - generalize (Impl.Abstract.clauses m). - clear; intros cls m en. - move=> cl /en; clear. - destruct cl as [prems concl]; rewrite /enabled_clause /enables_clause; cbn. - intros [k hmin]. - move/min_premise_interp_nes_ex: hmin => [z [eq rest]]. now exists z. - Qed. - - Lemma clauses_consistent_val m : consistent_val (opt_valuation m) (clauses m). - Proof. - split. apply opt_valuation_enables. - apply model_opt_Z_valuation. - Qed. - - Lemma clauses_consistent m : consistent (clauses m). - Proof. - eexists; eapply clauses_consistent_val. - Qed. - Lemma zero_declared m : Impl.CorrectModel.zero_declared (model m). Proof. eapply zero_declared. Qed. diff --git a/common/theories/LoopChecking/HornSemilatticeEquiv.v b/common/theories/LoopChecking/HornSemilatticeEquiv.v index 0f6459907..8cd757ecd 100644 --- a/common/theories/LoopChecking/HornSemilatticeEquiv.v +++ b/common/theories/LoopChecking/HornSemilatticeEquiv.v @@ -96,11 +96,14 @@ Module HornSemilattice (LS : LevelSets). apply (relations_of_clauses_spec_inv (_, _)); now apply Clauses.union_spec. Qed. - Definition entails_L_clause p cl := + Definition entails_L_pres_clause p cl := p ⊢ℒ singleton (concl cl) ≤ premise cl. Definition entails_L_pres_clauses p cls := - Clauses.For_all (entails_L_clause p) cls. + Clauses.For_all (entails_L_pres_clause p) cls. + + Definition entails_L_clause cls cl := + entails_L_pres_clause (relations_of_clauses cls) cl. Definition entails_L_clauses cls cls' := entails_L_pres_clauses (relations_of_clauses cls) cls'. @@ -123,10 +126,10 @@ Module HornSemilattice (LS : LevelSets). Lemma in_pred_closure_entails_L {cls} cl : in_pred_closure cls cl -> - entails_L_clause (relations_of_clauses cls) cl. + entails_L_pres_clause (relations_of_clauses cls) cl. Proof. induction 1. - - rewrite /entails_L_clause /rel_le. + - rewrite /entails_L_pres_clause /rel_le. destruct cl as [prems concl]; cbn. rewrite -add_prems_singleton -add_prems_union. apply entails_add_congr. @@ -139,14 +142,14 @@ Module HornSemilattice (LS : LevelSets). Lemma entails_entails_L {cls} cl : entails cls cl -> - entails_L_clause (relations_of_clauses cls) cl. + entails_L_pres_clause (relations_of_clauses cls) cl. Proof. intros h; induction h. - red. now apply entails_L_idem_gen. - move: IHh; rewrite -!union_add_singleton. eapply in_pred_closure_entails_L in H. - rewrite /entails_L_clause in H |- *; cbn in *. + rewrite /entails_L_pres_clause in H |- *; cbn in *. have hsub:= entails_L_subset H H0. move=> h'. eapply entails_L_le_trans. tea. @@ -338,7 +341,7 @@ Module HornSemilattice (LS : LevelSets). Qed. (* Lemma entails_L_clause_entails {cls cl} : - entails_L_clause (relations_of_clauses cls) cl -> + entails_L_pres_clause (relations_of_clauses cls) cl -> entails cls cl. Proof. *) @@ -619,8 +622,8 @@ Module HornSemilattice (LS : LevelSets). Qed. Lemma entails_L_clause_rels {p cl} : - entails_L_clause p cl -> - entails_L_clause (relations_of_clauses (clauses_of_relations p)) cl. + entails_L_pres_clause p cl -> + entails_L_pres_clause (relations_of_clauses (clauses_of_relations p)) cl. Proof. now move/entails_L_to_clauses_pres_all. Qed. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 1c3ea5912..f5acb9f12 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -1346,35 +1346,6 @@ End ZUnivConstraint. LevelSet.fold add_val V (LevelMap.empty _). - Lemma clauses_sem_subset {S} {SL : Semilattice.Semilattice S Q.t} {v : Level.t -> S} {cls cls'} : clauses_sem v cls -> cls' ⊂_clset cls -> clauses_sem v cls'. - Proof. - now move=> hall hsub cl /hsub. - Qed. - - Import Semilattice. - - Lemma clauses_sem_clauses_of_le (V : Level.t -> Z) l r : - clauses_sem V (clauses_of_le l r) -> - (interp_nes V l ≤ interp_nes V r)%sl. - Proof. - rewrite /clauses_sem. - intros hl. red in hl. - setoid_rewrite clauses_of_le_spec in hl. - move: l hl. apply: elim. - - move => le he. - rewrite interp_nes_singleton. - move: (he (r, le)) => /fwd. - exists le. split => //. now apply LevelExprSet.singleton_spec. - cbn. lia. - - intros le x ih hnin ih'. - rewrite interp_nes_add. - forward ih. intros x0 [x1 [hin ->]]. - move: (ih' (r, x1)) => /fwd. exists x1. split => //. apply LevelExprSet.add_spec. now right. - auto. - move: (ih' (r, le)) => /fwd. exists le. split => //. apply LevelExprSet.add_spec. now left. - cbn. cbn in ih. lia. - Qed. - Import LoopCheck (valuation). Import LoopCheck.Impl.CorrectModel (clauses_sem, clause_sem). @@ -1824,18 +1795,6 @@ End ZUnivConstraint. - exact ha. Qed. - Lemma entails_L_completeness {p l r} : - (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v p -> interp_nes v l ≡ interp_nes v r)%sl -> - p ⊢ℒ l ≡ r. - Proof. - intros hv. - specialize (hv _ (init_model p) (ids p)). - forward hv. - { apply interp_rels_init. } - rewrite !interp_triv in hv. - exact hv. - Qed. - Existing Instance Impl.CorrectModel.Zopt_semi. Instance nat_opt_semi : Semilattice (option nat) nat := opt_semi Natsemilattice. From 525ea37562069053c1a37ece895baa2e81f82f04 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sun, 5 Oct 2025 23:20:39 +0200 Subject: [PATCH 091/164] Refactor and cleanup deciders --- common/theories/LoopChecking/Deciders.v | 1251 ++++++----------- common/theories/LoopChecking/HornClauses.v | 50 + .../LoopChecking/HornSemilatticeEquiv.v | 203 +++ .../LoopChecking/InitialSemilattice.v | 7 + common/theories/LoopChecking/Model.v | 291 +++- .../theories/LoopChecking/ModelValuations.v | 0 common/theories/LoopChecking/Models.v | 117 +- .../theories/LoopChecking/UnivLoopChecking.v | 102 +- utils/theories/MRInstances.v | 11 + utils/theories/SemiLattice.v | 41 +- 10 files changed, 1134 insertions(+), 939 deletions(-) create mode 100644 common/theories/LoopChecking/ModelValuations.v diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 7772a444b..d9402cb1b 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -54,9 +54,6 @@ Module Import I := LoopCheckingImpl LS. Import LS. Local Open Scope Z_scope. -(* Import I.Model.ISL. *) -(* Import Equiv *) - Definition init_model cls := max_clause_premises cls. Lemma init_model_levels cls k : @@ -68,12 +65,6 @@ Proof. Qed. Definition init_w (levels : LevelSet.t) : LevelSet.t := LevelSet.empty. - -(* We don't need predecessor clauses as they are trivially satisfied *) -(* Definition add_predecessors (V : LevelSet.t) cls := - LevelSet.fold (fun l acc => - Clauses.add (NonEmptySetFacts.singleton (l, 1), (l, 0)) acc) V cls. *) - Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). Equations? infer (cls : clauses) : infer_result (clauses_levels cls) cls := @@ -136,32 +127,9 @@ Definition correct_model (cls : clauses) (m : model) := enabled_clauses m cls /\ is_model cls m. +(* Entailment *) -Lemma clauses_of_le_singleton le r : - (singleton le ⋞ r)%cls =_clset Clauses.singleton (r, le). -Proof. - intros l. - rewrite Clauses.singleton_spec clauses_of_le_spec. - firstorder. - - subst l. apply LevelExprSet.singleton_spec in H. - now red in H; subst x. - - subst l. exists le. split => //. now apply LevelExprSet.singleton_spec. -Qed. - -Lemma clauses_of_le_add le l r : - (NES.add le l ⋞ r)%cls =_clset Clauses.add (r, le) (l ⋞ r). -Proof. - intros cl. - rewrite Clauses.add_spec clauses_of_le_spec. - split. - - move=> [] x [] /LevelExprSet.add_spec; rewrite /LevelExprSet.E.eq. - move=> [->|hin]. now left. - intros ->. right. rewrite clauses_of_le_spec. now exists x. - - move=> [->|]. exists le. split => //. - * now apply LevelExprSet.add_spec; left. - * rewrite clauses_of_le_spec => -[] k [] hin ->. - exists k. split => //. now apply LevelExprSet.add_spec. -Qed. +Import I.Model.Model.Clauses.ISL. Lemma enabled_clauses_of_le m v u : (exists z, min_premise m u = Some z) -> @@ -352,8 +320,8 @@ Proof. rewrite clause_levels_spec. now right. Qed. -Equations check (cls : clauses) (cl : clause) : check_result cls := -check cls cl with inspect (loop_check cls cl) := +Equations check_gen (cls : clauses) (cl : clause) : check_result cls := +check_gen cls cl with inspect (loop_check cls cl) := { | exist (Loop v _ isl) he => IsLooping v _ isl | exist (Model W v _) he with inspect (LevelMap.find (concl cl).1 v.(model_model)) := { | exist (Some val) he' with check_atom_value (Some (concl cl).2) val := @@ -363,22 +331,12 @@ check cls cl with inspect (loop_check cls cl) := } }. -Definition check_clauses (cls : clauses) (cls' : clauses) : bool := - let check_one cl := - match check cls cl with - | IsLooping _ _ _ => false - | Valid => true - | Invalid => false - end - in - Clauses.for_all check_one cls'. - (* If a clause checks, then it is entailed (and will be valid in any extension of the model) *) -Theorem check_entails {cls cl} : - check cls cl = Valid -> entails cls cl. +Theorem check_gen_entails {cls cl} : + check_gen cls cl = Valid -> entails cls cl. Proof. destruct cl as [prems [concl k]]. - funelim (check cls _) => // _. + funelim (check_gen cls _) => // _. set (V := (clause_levels _ ∪ clauses_levels cls)%levels) in *. clear Heqcall H H0. cbn [concl fst snd] in *. move/check_atom_value_spec: Heq; intros h; depelim h. rename H into hgt. @@ -400,17 +358,18 @@ Proof. exact tr. Qed. -Lemma check_entails_looping {cls cl v vcls isl} : - check cls cl = IsLooping v vcls isl -> cls ⊢a v → succ_prems v. + +Lemma check_gen_entails_looping {cls cl v vcls isl} : + check_gen cls cl = IsLooping v vcls isl -> cls ⊢a v → succ_prems v. Proof. - funelim (check cls cl) => //. + funelim (check_gen cls cl) => //. Qed. Lemma check_looping {cls cl v vcls isl} : - check cls cl = IsLooping v vcls isl -> + check_gen cls cl = IsLooping v vcls isl -> ~ (exists m, defined_model_of (levels v) m /\ is_model cls m). Proof. - move/check_entails_looping. + move/check_gen_entails_looping. intros loop [m' [en clssem]]. apply to_entails_all in loop. apply is_model_valid in clssem. @@ -421,7 +380,7 @@ Qed. Lemma check_valid_looping {cls cl m v vcls isl} : is_model cls m -> - check cls cl = IsLooping v vcls isl -> + check_gen cls cl = IsLooping v vcls isl -> defined_model_of (levels v) m -> False. Proof. move=> ism. @@ -429,10 +388,26 @@ Proof. exists m. split => //. Qed. +Lemma model_entails_succ cls m v : + is_model cls m -> + enabled_clauses m cls -> + cls ⊢a v → succ v -> False. +Proof. + move=> mok en. + move/to_entails_all/entails_L_entails_ℋ_equiv. + move/entails_L_rels_entails_L_clauses/completeness_all. + move/(_ Z _ (Z_valuation_of_model m)). + rewrite -!interp_rels_clauses_sem => /fwd. + cbn in *. + eapply valid_clauses_model => //. + move/clauses_sem_leq. + rewrite interp_add_prems. cbn. lia. +Qed. + Theorem check_invalid {cls cl} : - check cls cl = Invalid -> exists m, [/\ is_model cls m, enabled_clause m cl & ~ valid_clause m cl]. + check_gen cls cl = Invalid -> exists m, [/\ is_model cls m, enabled_clause m cl & ~ valid_clause m cl]. Proof. - funelim (check cls cl) => //. + funelim (check_gen cls cl) => //. clear H H0 he. set (V := (clause_levels cl ∪ clauses_levels cls)%levels) in *. destruct cl as [prems [concl k]]. @@ -478,12 +453,93 @@ Proof. Qed. Lemma check_invalid_entails {cls cl} : - check cls cl = Invalid -> ~ entails cls cl. + check_gen cls cl = Invalid -> ~ entails cls cl. Proof. move/check_invalid => [m [ism en nv]]. now move/entails_model_valid/(_ m ism). Qed. +(* For checking to satisfy injectivity rules, + we force the conclusion to be defined by adding it to the premises. + In injective semilattices, we can then remove it. + *) + +Definition pred_expr (le : LevelExpr.t) := + (le.1, le.2 - 1). + +Definition checking_clause (cl : clause) := + let (prems, concl) := cl in + (singleton (pred_expr concl) ∪ prems, concl). + +Definition check_clause cls cl := + check_gen cls (checking_clause cl). +(* +Lemma check_clause_valid_Z : valid_relations *) + + +Definition valid_clause_Z cls cl := + forall v : Level.t -> Z, + positive_valuation v -> + clauses_sem v cls -> clause_sem v cl. + + + +Definition checkb cls cl := + match check_clause cls cl with + | IsLooping _ _ _ => false + | Valid => true + | Invalid => false + end. + +Definition check_clauses (cls : clauses) (cls' : clauses) : bool := + Clauses.for_all (checkb cls) cls'. + +Definition pred (le : LevelExpr.t) := (le.1, le.2 - 1). + +(* Theorem check_entails_all {cls prems concl} : + check cls (prems, concl) = Valid -> + entails cls (union prems (singleton (pred concl)), concl). +Proof. +Admitted. *) + + + Import Semilattice. + Import ISL. + +(* Lemma elim_pred {cls prems concl} : + entails cls (union prems (singleton (pred concl)), concl) -> + entails cls (prems, concl) \/ entails cls (singleton (pred concl), concl). +Proof. + Search entails. + set (SL := init_model (relations_of_clauses cls)). + rewrite -!entails_all_singleton. + rewrite -!to_entails_all. + rewrite -!entails_L_entails_ℋ_equiv. + rewrite -!entails_L_rels_entails_L_clauses. + rewrite !entails_L_relations_of_clauses_le. + rewrite !entails_L_all_tip. + change (le (singleton concl) (prems ∨ singleton (pred concl)) -> + (le (singleton concl) (prems) \/ + le (singleton concl) (singleton (pred concl)))). *) + +(* +Lemma check_complete {cls cl} : + checkb cls cl <-> valid_semilattice_entailment cls cl. +Proof. + unfold checkb. + destruct check eqn:ec. + - split => //. + intros vs. red in vs. + move/check_entails_looping: ec. + rewrite -to_entails_all. + move/entails_ℋ_entails_L. + move/entails_L_rels_entails_L_clauses. + rewrite -completeness_all. + intros vr. red in vr. + red in islooping. specialize (vr Z _ (valuation_of_model m)) *) + + + Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) (prf : clauses_levels cls ⊂_lset V /\ clauses_levels cls' ⊂_lset V /\ only_model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m m _. @@ -533,28 +589,7 @@ Proof. forward ho by now exists v. now right. Qed. -Lemma min_model_map_enabled m cls cls' : - enabled_clauses m cls -> - enabled_clauses (min_model_map m cls') (Clauses.union cls cls'). -Proof. - intros en cl. - rewrite Clauses.union_spec => -[]. - - move/en; rewrite /enabled_clause => -[z hmin]. - have := @min_premise_pres m (min_model_map m cls') (premise cl) => /fwd. - apply min_model_map_acc. - rewrite hmin => h; depelim h. now exists y. - - intros hin; rewrite /enabled_clause. - have [hm [incl hext]] := min_model_map_spec cls' m. - have [hle [minp [inp ->]]] := min_premise_spec (min_model_map m cls') (premise cl). - move: (incl _ hin). move/(_ minp.1) => /fwd. - { apply clause_levels_spec. left. now apply in_levels. } - move=> [k hmap]. - specialize (hm minp.1 k hmap) as [_ hm _]. - destruct minp. - move: hm => /(_ _ hin)/(_ _ inp). intros le; depelim le. - exists (y - z). now rewrite /min_atom_value (level_value_MapsTo hmap). -Qed. - +Section InitModels. Definition init_clause_of_level l := (singleton (l, 0), (Level.zero, if Level.is_global l then 1 else 0)). @@ -563,7 +598,6 @@ Definition declared_init_clause_of_level l cls := if eqb l Level.zero then True else Clauses.In (init_clause_of_level l) cls. -Module CorrectModel. Definition zero_declared m := exists k, LevelMap.MapsTo Level.zero (Some (Z.of_nat (S k))) m. @@ -610,6 +644,10 @@ Module CorrectModel. intros nzero. clsets. Qed. +End InitModels. + +Module CorrectModel. + Record t {V cls} := { initial_model : model; declared_zero : zero_declared initial_model; @@ -770,7 +808,7 @@ Module CorrectModel. case: (eqb_spec l Level.zero). * move=> ->. have := CorrectModel.declared_zero m. - unfold CorrectModel.zero_declared. + unfold zero_declared. now move=> [] k hm; exists (Z.of_nat (S k)). * intros nzero. have he := enabled_model m. @@ -781,322 +819,7 @@ Module CorrectModel. exists z. apply (level_value_MapsTo' hl). Qed. - Definition clause_sem {S} {SL : Semilattice S Q.t} (V : Level.t -> S) (cl : clause) : Prop := - let '(prems, concl) := cl in - le (interp_expr V concl) (interp_nes V prems). - - Definition clauses_sem {S} {SL : Semilattice S Q.t} (V : Level.t -> S) (cls : Clauses.t) : Prop := - Clauses.For_all (clause_sem V) cls. - - Instance clauses_sem_proper {S} {SL : Semilattice S Q.t} : - Proper (Logic.eq ==> Clauses.Equal ==> iff) (clauses_sem (S:=S)). - Proof. - move=> ?? -> ?? h. - rewrite /clauses_sem. - now rewrite h. - Qed. - - Lemma clauses_sem_singleton {S} {SL : Semilattice S Q.t} {V cl} : - clauses_sem (S:=S) V (Clauses.singleton cl) <-> clause_sem V cl. - Proof. - rewrite /clauses_sem /Clauses.For_all. - split; firstorder. apply H. clsets. - apply Clauses.singleton_spec in H0. now subst. - Qed. - - Lemma clauses_sem_add {S} {SL : Semilattice S Q.t} {V cl cls} : - clauses_sem (S:=S) V (Clauses.add cl cls) <-> clause_sem V cl /\ clauses_sem V cls. - Proof. - rewrite /clauses_sem /Clauses.For_all. - split. - - intros hcl. split. - * apply hcl, Clauses.add_spec; now left. - * move=> x hin; apply hcl, Clauses.add_spec; now right. - - move=> [] hcl hcls x /Clauses.add_spec -[]. now subst. - apply hcls. - Qed. - - Lemma clauses_sem_union {S} {SL : Semilattice S Q.t} {V cls cls'} : - clauses_sem (S:=S) V (Clauses.union cls cls') <-> clauses_sem V cls /\ clauses_sem V cls'. - Proof. - rewrite /clauses_sem /Clauses.For_all. - setoid_rewrite Clauses.union_spec. firstorder. - Qed. - - - Definition to_val (v : LevelMap.t nat) l := - match LevelMap.find l v with - | Some n => n - | None => 0%nat - end. - - Definition to_Z_val (v : Level.t -> nat) := fun l => Z.of_nat (v l). - - Definition valuation m := to_val (Model.valuation_of_model m). - - Lemma valuation_range {m l k} : - LevelMap.MapsTo l (Some k) m -> - model_min m <= k <= model_max m. - Proof. - move=> hm. - have mins := model_min_spec m _ _ hm. - have maxs := model_max_spec m _ _ hm. - depelim maxs. lia. - Qed. - - Definition Zopt_semi := opt_semi Zsemilattice. - Existing Instance Zopt_semi. - - Definition valuation_of_value m n := - let max := model_max m in - let min := model_min m in - max - n - min. - - Lemma valuation_of_value_pos {l m n} : - LevelMap.MapsTo l (Some n) m -> valuation_of_value m n >= 0. - Proof. - rewrite /valuation_of_value => hm. - have hmax := model_max_spec m _ _ hm. - have hmin := model_min_spec m _ _ hm. - depelim hmax. - have := model_min_spec2 m. lia. - Qed. - - Definition opt_valuation_of_model (m : LevelMap.t (option Z)) l := - match LevelMap.find l m with - | Some (Some n) => Some (valuation_of_value m n) - | _ => None - end. - - Definition positive_opt_valuation (v : Level.t -> option Z) := - forall l k, v l = Some k -> k >= 0. - - Definition positive_valuation (v : Level.t -> Z) := - forall l, v l >= 0. - - Lemma opt_valuation_of_model_pos {m} : positive_opt_valuation (opt_valuation_of_model m). - Proof. - rewrite /opt_valuation_of_model /positive_valuation => l k'. - case: (find_spec l m) => //. - move=> [k|] hm // [=] <-. - now eapply valuation_of_value_pos. - Qed. - - Definition shift_model n (m : model) := - LevelMap.map (fun k => option_map (fun k => k + n) k) m. - - Lemma level_value_shift_model {n m l} : level_value (shift_model n m) l = option_map (fun v => v + n) (level_value m l). - Proof. - rewrite /shift_model /level_value LevelMapFact.F.map_o. - case: (find_spec l m) => //. - Qed. - - Lemma min_premise_shift {n m k u} : - min_premise (shift_model n m) u = Some k -> - min_premise m u = Some (k - n). - Proof. - move/min_premise_spec_aux => [hf [[minl mink] [hin heq]]]. - rewrite /min_atom_value level_value_shift_model in heq. - have [hf' [[minl' mink'] [hin' heq']]] := min_premise_spec m u. - rewrite /min_atom_value in heq'. - destruct (level_value m minl) eqn:hl => //. - cbn in heq. noconf heq. - specialize (hf' _ hin). - specialize (hf _ hin'). - rewrite /min_atom_value in hf'. - rewrite /min_atom_value level_value_shift_model in hf. - destruct (level_value m minl') eqn:hl'; cbn in *. - - rewrite heq'; f_equal. rewrite heq' in hf'. - rewrite hl in hf'. depelim hf. depelim hf'. lia. - - depelim hf. - Qed. - - Lemma min_premise_shift_inv {n m k u} : - min_premise m u = Some k -> - min_premise (shift_model n m) u = Some (n + k). - Proof. - move/min_premise_spec_aux => [hf [[minl mink] [hin heq]]]. - have [hf' [[minl' mink'] [hin' heq']]] := min_premise_spec (shift_model n m) u. - rewrite /min_atom_value level_value_shift_model in heq'. - destruct (level_value m minl') eqn:hl => //. - rewrite /min_atom_value in heq. - cbn in heq'. noconf heq'. - specialize (hf' _ hin). - specialize (hf _ hin'). - rewrite /min_atom_value in hf'. - rewrite /min_atom_value in hf. - destruct (level_value m minl) eqn:hl'; cbn in *. - - rewrite heq'; f_equal. rewrite heq' level_value_shift_model in hf'. - rewrite hl in hf. noconf heq. rewrite hl' in hf'. depelim hf. depelim hf'. lia. - - noconf heq. - - cbn in heq'. specialize (hf _ hin'). rewrite /min_atom_value hl //= in hf. depelim hf. - Qed. - - Lemma valid_clause_shift {n m cl} : valid_clause m cl <-> valid_clause (shift_model n m) cl. - Proof. - destruct cl as [prems [concl k]]. - split. - - move/valid_clause_elim => hz. - apply valid_clause_intro => z. - move/min_premise_shift /hz. - rewrite level_value_shift_model. - intros hle; depelim hle. rewrite H0 //=. constructor. lia. - - move/valid_clause_elim => hz. - apply valid_clause_intro => z. - move/min_premise_shift_inv /hz. - rewrite level_value_shift_model. - destruct (level_value m concl) => //=; - intros hle; depelim hle. constructor. lia. - Qed. - - Lemma enabled_clause_shift {n m cl} : enabled_clause m cl <-> enabled_clause (shift_model n m) cl. - Proof. - destruct cl as [prems [concl k]]. - split. - - move=> [] z. cbn. move/min_premise_shift_inv. - now eexists. - - move=> [] z; move/min_premise_shift. now eexists. - Qed. - - Lemma shift_model_invariant {n m cls} : - is_model cls m <-> - is_model cls (shift_model n m). - Proof. - rewrite /is_model. - rewrite ![is_true _]Clauses.for_all_spec. - unfold Clauses.For_all. - now setoid_rewrite (@valid_clause_shift n m). - Qed. - - Lemma shift_model_min_pos {m} : model_min (shift_model (- model_min m) m) = 0. - Proof. - destruct (model_has_min (shift_model (- model_min m) m)) => //. - destruct H as [l [k [inshift eq]]]. - move: inshift. - rewrite /shift_model LevelMapFact.F.map_mapsto_iff => -[a [eq' hm]]. - destruct a; cbn in eq' => //. - noconf eq'. rewrite eq. - have msp := model_min_spec _ _ _ hm. - have m0 := model_min_spec2 m. - have m1 := model_min_spec2 (shift_model (- model_min m) m). lia. - Qed. - - Lemma valid_clause_model_opt model cl : - valid_clause model cl -> - clause_sem (opt_valuation_of_model model) cl. - Proof. - unfold valid_clause. - destruct min_premise eqn:hmin => //= => //. - 2:{ move/min_premise_spec_aux: hmin => [hf [[min mink] [inmin hmin]]]. - move=> _. destruct cl as [prems concl]. cbn. - rewrite /min_atom_value in hmin. - set (v := opt_valuation_of_model _). - set (ip := interp_nes _ _). - have -> : ip = None. - { subst ip. move/(interp_nes_ge v): inmin; tea. - have -> : interp_expr v (min, mink) = None. - { cbn. subst v. unfold opt_valuation_of_model. - move: hmin; rewrite /level_value; case: find_spec => //. - move=> k hm. destruct k => //. } - move/le_spec. intros [] => //. - destruct H as [? [? []]]. congruence. } - destruct interp_expr => //=. } - destruct cl as [prems [concl k]]. cbn -[le]. - unfold level_value_above. - destruct level_value eqn:hl => //. - unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. - move/Z.leb_le => hrel. - eapply LevelMap.find_2 in hfind. - have conclm := valuation_of_model_spec _ _ _ hfind. - set (v := (model_max _ - _)) in *. - cbn in conclm. - eapply LevelMap.find_1 in conclm. - subst v. - pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. - rewrite hmin in premeq. - eapply transitivity. 2:{ eapply interp_nes_ge; tea. } - unfold interp_expr. destruct prem as [prem k']. - symmetry in premeq. - move: premeq. unfold min_atom_value. - unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. - destruct o => //. - intros [= <-]. - eapply LevelMap.find_2 in findp. - have premm := valuation_of_model_spec _ _ _ findp. - eapply LevelMap.find_1 in premm. - assert (z1 - k' <= z0 - k). lia. - have [z0min z0max] := valuation_range hfind. - have [z1min z1max] := valuation_range findp. - assert (0 <= model_max model)%Z by apply model_max_spec2. - assert (model_min model <= 0)%Z by apply model_min_spec2. - rewrite /opt_valuation_of_model. rewrite (LevelMap.find_1 findp) (LevelMap.find_1 hfind). - cbn. rewrite /valuation_of_value. lia. - Qed. - - Lemma valid_clauses_model_opt model cls : - is_model cls model -> - clauses_sem (opt_valuation_of_model model) cls. - Proof. - move=> ism cl hin. - apply valid_clause_model_opt. - now move/Clauses.for_all_spec: ism; apply. - Qed. - - (** Enabled and valid clauses are satisfied by valuation. - *) - Lemma valid_clause_model model cl : - enabled_clause model cl -> - valid_clause model cl -> - clause_sem (to_Z_val (to_val (valuation_of_model model))) cl. - Proof. - unfold enabled_clause, valid_clause. - destruct min_premise eqn:hmin => //= => //. - 2:{ intros [k' eq]. congruence. } - intros [k' eq]. noconf eq. - destruct cl as [prems [concl k]]. cbn -[le]. - unfold level_value_above. - destruct level_value eqn:hl => //. - unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. - move/Z.leb_le => hrel. - eapply LevelMap.find_2 in hfind. - have conclm := valuation_of_model_spec _ _ _ hfind. - set (v := (model_max _ - _)) in *. - cbn in conclm. - eapply LevelMap.find_1 in conclm. - subst v. - pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. - rewrite hmin in premeq. - eapply transitivity. 2:{ eapply interp_nes_ge; tea. } - unfold interp_expr. destruct prem as [prem k']. - symmetry in premeq. - move: premeq. unfold min_atom_value. - unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. - destruct o => //. - intros [= <-]. - eapply LevelMap.find_2 in findp. - have premm := valuation_of_model_spec _ _ _ findp. - eapply LevelMap.find_1 in premm. - assert (z1 - k' <= z0 - k). lia. - have [z0min z0max] := valuation_range hfind. - have [z1min z1max] := valuation_range findp. - assert (0 <= model_max model)%Z by apply model_max_spec2. - assert (model_min model <= 0)%Z by apply model_min_spec2. - rewrite /to_Z_val /to_val premm conclm. - cbn. lia. - Qed. - - Lemma valid_clauses_model model cls : - enabled_clauses model cls -> - is_model cls model -> - clauses_sem (to_Z_val (to_val (valuation_of_model model))) cls. - Proof. - move=> en ism cl hin. - apply valid_clause_model. - now apply en. - now move/Clauses.for_all_spec: ism; apply. - Qed. - - Definition model_valuation {V cls} (m : t V cls) : clauses_sem (to_Z_val (valuation (model_of m))) cls. + Definition model_valuation {V cls} (m : t V cls) : clauses_sem (to_Z_val (Model.valuation (model_of m))) cls. Proof. destruct m as []; cbn. apply valid_clauses_model; tea; cbn. @@ -1116,7 +839,7 @@ Module CorrectModel. - move=> [] he heq. now rewrite -heq. - move/[dup]/strictly_updates_only_model_gen. move/(_ _ om) => om' /strictly_updates_incl incl incl'. - have he : (V ∪ W) =_lset V. + have he : (LevelSet.union V W) =_lset V. { lsets. } now rewrite he in om'. Qed. @@ -1212,7 +935,7 @@ Module CorrectModel. apply hv in hin. move: hin; rewrite /clause_sem /init_clause_of_level //=. rewrite interp_nes_singleton //=. - rewrite /to_Z_val /to_val /valuation /to_val. + rewrite /to_Z_val /to_val /Model.valuation /to_val. have vs:= valuation_of_model_spec _ _ _ hm. rewrite (LevelMap.find_1 vs). have [kz [hz hzpos]] := model_zero_level m. @@ -1233,9 +956,9 @@ Module CorrectModel. Lemma model_max_gen {V cls} {m : t V cls} {l k} : LevelMap.MapsTo l (Some k) (model_of m) -> (if Level.is_global l then - (to_val (valuation_of_model (model_of m)) Level.zero) < (to_val (valuation_of_model (model_of m)) l) + (to_val (Model.valuation_of_model (model_of m)) Level.zero) < (to_val (Model.valuation_of_model (model_of m)) l) else - (to_val (valuation_of_model (model_of m)) Level.zero) <= (to_val (valuation_of_model (model_of m)) l))%nat. + (to_val (Model.valuation_of_model (model_of m)) Level.zero) <= (to_val (Model.valuation_of_model (model_of m)) l))%nat. Proof. intros hm. have hab := declared_above_zero m l. @@ -1251,7 +974,7 @@ Module CorrectModel. apply hv in hin. move: hin; rewrite /clause_sem /init_clause_of_level //=. rewrite interp_nes_singleton //=. - rewrite /to_Z_val /to_val /valuation /to_val. + rewrite /to_Z_val /to_val /Model.valuation /to_val. have vs:= valuation_of_model_spec _ _ _ hm. rewrite (LevelMap.find_1 vs). have [kz [hz hzpos]] := model_zero_level m. @@ -1269,7 +992,7 @@ Module CorrectModel. lia. Qed. - Lemma valuation_0 {V cls} {m : t V cls}: to_val (valuation_of_model (model_of m)) Level.zero = 0%nat. + Lemma valuation_0 {V cls} {m : t V cls}: to_val (Model.valuation_of_model (model_of m)) Level.zero = 0%nat. Proof. have mmax := model_max_spec2 m. have mmin := model_min_spec2 m. @@ -1288,7 +1011,7 @@ Module CorrectModel. Qed. Lemma valuation_global {V cls} {m : t V cls} : - forall l, LevelSet.In l V -> Level.is_global l -> (0 < to_val (valuation_of_model (model_of m)) l)%nat. + forall l, LevelSet.In l V -> Level.is_global l -> (0 < to_val (Model.valuation_of_model (model_of m)) l)%nat. Proof. move=> l /(model_levels m) [] k inm isg. have hmax := model_max_gen inm. @@ -1297,7 +1020,7 @@ Module CorrectModel. Qed. Lemma valuation_not_global {V cls} {m : t V cls} : - forall l, LevelSet.In l V -> ~~ Level.is_global l -> (0 <= to_val (valuation_of_model (model_of m)) l)%nat. + forall l, LevelSet.In l V -> ~~ Level.is_global l -> (0 <= to_val (Model.valuation_of_model (model_of m)) l)%nat. Proof. move=> l /(model_levels m) [] k inm isg. have hmax := model_max_gen inm. @@ -1491,7 +1214,7 @@ Module Abstract. Hint Rewrite levels_singleton : set_specs. Lemma clause_levels_init_constraint l : clause_levels (init_clause_of_level l) - =_lset (LevelSet.singleton Level.zero ∪ LevelSet.singleton l). + =_lset (LevelSet.singleton Level.zero ∪ LevelSet.singleton l)%levels. Proof. rewrite /init_clause_of_level //=. intros ?; rewrite clause_levels_spec; rsets; cbn; rsets; cbn. firstorder. @@ -1650,6 +1373,22 @@ Module Abstract. Import I.Model.Model.Clauses.ISL. + Definition entails_loop m cls := + exists u : premises, + NES.levels u ⊂_lset clauses_levels (Clauses.union (clauses m) cls) /\ + Clauses.union (clauses m) cls ⊢ℋ succ u ⋞ u. + + Lemma enforce_clauses_loop_simple m cls u : + enforce_clauses m cls = Some (inr u) -> + entails_loop m cls. + Proof. + funelim (enforce_clauses m cls) => //=. + intros [= <-]. clear -u. + destruct u as [u incl loop]. cbn [loop_univ]. + eapply to_entails_all in loop. + now exists u; split. + Qed. + Lemma enforce_clauses_loop m cls u : enforce_clauses m cls = Some (inr u) -> entails_L_clauses (Clauses.union (clauses m) cls) (loop_univ u ≡ succ_prems (loop_univ u)). @@ -1694,21 +1433,19 @@ Module Abstract. Definition enables_clauses val cls := Clauses.For_all (enables_clause val) cls. - Definition valuation_of_model model := - to_Z_val (to_val (Model.valuation_of_model model)). - Definition consistent_opt_val (val : Level.t -> option Z) (cls : Clauses.t) := (* enables_clauses val cls /\ *) clauses_sem val cls. - Definition consistent_opt cls := exists val : Level.t -> option Z, consistent_opt_val val cls. + Definition consistent_opt cls := + exists val : Level.t -> option Z, consistent_opt_val val cls. Definition consistent cls := exists val : Level.t -> Z, positive_valuation val /\ clauses_sem val cls. (* Lemma opt_valuation_of_model_equiv m l : - option_get 0%Z (opt_valuation_of_model m l) = to_Z_val (to_val (valuation_of_model m)) l. + option_get 0%Z (opt_valuation_of_model m l) = valuation_of_model m l. Proof. rewrite /opt_valuation_of_model /to_Z_val /to_val. case: find_spec. @@ -1809,7 +1546,10 @@ Lemma opt_valuation_of_model_equiv m l : Qed. Lemma clauses_consistent m : consistent (clauses m). - Proof. Admitted. + Proof. exists (Z_valuation_of_model m); split. + - apply valuation_of_model_pos. + - apply model_valuation. + Qed. Definition inconsistent_opt cls := ~ (consistent_opt cls). @@ -1818,134 +1558,13 @@ Lemma opt_valuation_of_model_equiv m l : Definition check_clauses m cls := check_clauses (clauses m) cls. - Instance entails_L_pres_clauses_proper : Proper (Logic.eq ==> Clauses.Equal ==> iff) entails_L_pres_clauses. - Proof. - intros ?? -> ? ? h. - rewrite /entails_L_pres_clauses. now rewrite h. - Qed. - - Lemma entails_L_pres_clauses_union {p cls cls'} : entails_L_pres_clauses p (Clauses.union cls cls') <-> - entails_L_pres_clauses p cls /\ - entails_L_pres_clauses p cls'. - Proof. - rewrite /entails_L_pres_clauses /Clauses.For_all. - setoid_rewrite Clauses.union_spec. by firstorder. - Qed. - - Lemma entails_L_rels_entails_rels p rs : - entails_L_rels p rs <-> entails_L_clauses (clauses_of_relations p) (clauses_of_relations rs). - Proof. - induction rs. - - split => //. - * intros ent cl hin. cbn in hin. clsets. - * cbn. constructor. - - split. - * intros ent; depelim ent. - unfold entails_L_clauses. - destruct a as [l r]. rewrite clauses_of_relations_cons entails_L_pres_clauses_union. split. - now eapply entails_L_clauses_relations, entails_L_pres_clauses_of_relations_eq. - apply IHrs, ent. - * unfold entails_L_clauses. - destruct a as [l r]. rewrite clauses_of_relations_cons entails_L_pres_clauses_union. - move=> [] lr ih. constructor. - apply (proj1 entails_L_pres_clauses_of_relations_eq) in lr. - now apply entails_L_clauses_pres_all in lr. - apply IHrs, ih. - Qed. - - Lemma entails_clauses_of_relations cls : entails_clauses cls (clauses_of_relations (relations_of_clauses cls)). - Proof. - apply entails_ℋ_clauses_of_relations_equiv. apply entails_clauses_tauto. - Qed. - - Lemma entails_clauses_trans {cls cls' cls''} : cls ⊢ℋ cls' -> cls' ⊢ℋ cls'' -> cls ⊢ℋ cls''. - Proof. - intros ent ent'. - eapply entails_clauses_cut; tea. - eapply entails_ℋ_clauses_subset; tea. clsets. - Qed. - - Lemma entails_L_rels_entails_L_clauses cls cls' : - entails_L_rels (relations_of_clauses cls) (relations_of_clauses cls') <-> entails_L_clauses cls cls'. - Proof. - rewrite entails_L_rels_entails_rels. - rewrite !entails_L_entails_ℋ_equiv. - split. - - intros cl. eapply entails_clauses_cut. eapply entails_ℋ_clauses_of_relations. tea. - eapply entails_ℋ_clauses_subset. eapply entails_clauses_tauto. intros cl' hin. - apply clauses_of_relations_relations_of_clauses in hin. - rewrite Clauses.union_spec. now left. - - intros hent. eapply (proj1 entails_ℋ_clauses_of_relations_equiv). - eapply entails_clauses_trans; tea. eapply entails_clauses_of_relations. - Qed. - - Lemma clauses_sem_leq {S} {SL : Semilattice S Q.t} (V : Level.t -> S) l r : - clauses_sem V (l ⋞ r) <-> - (interp_nes V l ≤ interp_nes V r)%sl. - Proof. - move: l. - apply: elim. - - intros le; cbn. - rewrite clauses_of_le_singleton clauses_sem_singleton. - cbn. now rewrite interp_nes_singleton. - - move=> le x xr hnin. - rewrite clauses_of_le_add clauses_sem_add xr. - cbn. rewrite interp_nes_add. - symmetry; apply join_le_left_eq. - Qed. - - Lemma clauses_sem_eq {S} {SL : Semilattice S Q.t} (V : Level.t -> S) l r : - clauses_sem V (l ≡ r) <-> - (interp_nes V l ≡ interp_nes V r)%sl. - Proof. - rewrite /clauses_of_eq clauses_sem_union !clauses_sem_leq. - symmetry; apply eq_antisym. - Qed. - - Definition relation_of_clause cl := (singleton (concl cl) ≤ premise cl). - - Lemma interp_rels_of_clauses {S} {SL : Semilattice S Q.t} {V : Level.t -> S} {cls} : - interp_rels V (relations_of_clauses cls) <-> - forall cl, Clauses.In cl cls -> interp_rel V (relation_of_clause cl). - Proof. - rewrite /interp_rels Forall_forall. - split. - - move=> hx cl /relations_of_clauses_spec_inv. - now move/hx. - - move=> hcl x /relations_of_clauses_spec => -[] prems [] concl. - now move=> [] /hcl hin ->. - Qed. - - Lemma interp_rel_clause_sem {S} {SL : Semilattice S Q.t} {V : Level.t -> S} {cl} : - clause_sem V cl <-> interp_rel V (relation_of_clause cl). + Lemma model_entails_loop m v : + clauses m ⊢a v → succ v -> False. Proof. - destruct cl as [prems concl] => //=. - now rewrite /le interp_nes_union interp_nes_singleton. - Qed. - - Lemma interp_rels_clauses_sem {S} {SL : Semilattice S Q.t} {V : Level.t -> S} {cls} : - clauses_sem V cls <-> interp_rels V (relations_of_clauses cls). - Proof. - rewrite interp_rels_of_clauses. - split. - - move=> sem cl /sem; apply interp_rel_clause_sem. - - move=> hcl cl /hcl /=. apply interp_rel_clause_sem. - Qed. - - Lemma model_entails_succ m v : clauses m ⊢a v → succ v -> False. - Proof. - move/to_entails_all/entails_L_entails_ℋ_equiv. - move/entails_L_rels_entails_L_clauses/completeness_all. - move/(_ Z _ (valuation_of_model m)). - rewrite -!interp_rels_clauses_sem => /fwd. - cbn in *. - have mok := m.(correct_model).(model_valid).(model_ok). - eapply valid_clauses_model. + eapply model_entails_succ; tea. + exact: m.(correct_model).(model_valid).(model_ok). eapply enabled_clauses_ext, m.(correct_model).(enabled_model). now eapply (is_update_of_ext m.(correct_model).(model_valid).(I.model_updates)). - exact mok. - move/clauses_sem_leq. - rewrite interp_add_prems. cbn. lia. Qed. Lemma check_clauses_spec m cls : @@ -1953,13 +1572,13 @@ Lemma opt_valuation_of_model_equiv m l : Proof. split. - rewrite /check_clauses /Deciders.check_clauses. - move/Clauses.for_all_spec => ha cl /ha. - destruct check eqn:ch => // _. - eapply check_entails in ch. now apply ch. + move/Clauses.for_all_spec => ha cl /ha. unfold checkb. + destruct check_clause eqn:ch => // _. + eapply check_gen_entails in ch. now apply ch. - intros hv. rewrite /check_clauses /Deciders.check_clauses. eapply Clauses.for_all_spec; tc => cl hin. - destruct check eqn:hc => //. + unfold checkb; destruct check eqn:hc => //. * exfalso; eapply check_entails_looping in hc; tea. now apply model_entails_succ in hc. * move/check_invalid_entails: hc => he. @@ -1981,118 +1600,29 @@ Lemma opt_valuation_of_model_equiv m l : rewrite !interp_rels_clauses_sem // => vr /vr. Qed. - Lemma enforce_clauses_inconsistent_opt {m cls u} : - enforce_clauses m cls = Some (inr u) -> - inconsistent_opt (Clauses.union (clauses m) cls). - Proof. - move/enforce_clauses_inconsistent_semilattice => ec [v cs]. - move: (ec (option Z) _ v cs). - rewrite clauses_sem_eq //= interp_add_prems //=. - destruct u as [loop incl hloop]. cbn. - admit. - Admitted. - - Lemma enforce_clauses_inconsistent {m cls u} : + Lemma enforce_clauses_inconsistent_loop {m cls u} : enforce_clauses m cls = Some (inr u) -> - inconsistent (Clauses.union (clauses m) cls). + entails_loop m cls. Proof. - move/enforce_clauses_inconsistent_semilattice => ec [v [posv cs]]. - move: (ec Z _ v cs). - rewrite clauses_sem_eq //= interp_add_prems //=. lia. + now move/enforce_clauses_loop_simple. Qed. - (* Lemma enforce_clauses_inconsistent_opt {m cls u} : - enforce_clauses m cls = Some (inr u) -> - inconsistent_opt (Clauses.union (clauses m) cls). - Proof. - move/enforce_clauses_inconsistent_semilattice => ec [v cs]. - red in cs. destruct cs as [en cs]. - move: (ec _ _ v cs). - destruct u as [loop incl eq]. cbn in ec. - rewrite clauses_sem_eq //= interp_add_prems //=. - red in en. unfold enables_clause in en. - rewrite interp_nes_defined. - Qed. *) - - Definition inconsistent_ext m cls := - forall v : Level.t -> Z, positive_valuation v -> clauses_sem v (clauses m) -> ~ clauses_sem v cls. - - Lemma enforce_dec m cls : - clauses_levels cls ⊂_lset levels m -> - { consistent (Clauses.union (clauses m) cls) } + { inconsistent_ext m cls }. - Proof. - intros hm. - destruct (enforce_clauses m cls) eqn:ec. - destruct s as [model|loop]. - - left. move/enforce_clauses_clauses: ec. - intros <-. apply clauses_consistent. - - right. move/enforce_clauses_inconsistent: ec. - intros he v vpos semcs semc. apply he. exists v. split => //. - apply clauses_sem_union. split => //. - - move/enforce_clauses_None: ec. contradiction. - Qed. - - Lemma enforce_dec_opt m cls : - clauses_levels cls ⊂_lset levels m -> - { consistent_opt (Clauses.union (clauses m) cls) } + { ~ consistent_opt (Clauses.union (clauses m) cls) }. - Proof. - intros hm. - destruct (enforce_clauses m cls) eqn:ec. - destruct s as [model|loop]. - - left. move/enforce_clauses_clauses: ec. - intros <-. exact: (clauses_consistent_opt model). - - right. now move/enforce_clauses_inconsistent_opt: ec. - - move/enforce_clauses_None: ec. contradiction. - Qed. - - Definition valid_entailments cls cls' := - forall S (SL : Semilattice S Q.t) (V : Level.t -> S), clauses_sem V cls -> clauses_sem V cls'. + Definition defined_valuation_of {A} V (v : Level.t -> option A) := + forall l, LevelSet.In l V -> exists x, v l = Some x. - Lemma check_clauses_complete m cls : - check_clauses m cls <-> valid_entailments (clauses m) cls. + Instance proper_defined_valuation_of {A} : + Proper (LevelSet.Equal ==> Logic.eq ==> iff) (@defined_valuation_of A). Proof. - rewrite check_clauses_spec. - rewrite -entails_L_entails_ℋ_equiv. - rewrite -entails_L_rels_entails_L_clauses. - rewrite -completeness_all. - split. - - move=> vr s sl v. - move: (vr _ sl v). - rewrite !interp_rels_clauses_sem //. - - intros ve S s v. - move: (ve S s v). - now rewrite //= !interp_rels_clauses_sem. + intros x y ? ?? ->. + rewrite /defined_valuation_of. + now setoid_rewrite H. Qed. - Definition valid_semilattice_entailment {S} (SL : Semilattice S Q.t) cls cl := - (forall (v : Level.t -> S), clauses_sem v cls -> clause_sem v cl). - - Definition valid_semilattice_entailments {S} (SL : Semilattice S Q.t) cls cls' := - (forall (v : Level.t -> S), clauses_sem v cls -> clauses_sem v cls'). - - Infix "⊩Z" := (valid_semilattice_entailments Zsemilattice) (at level 70, no associativity). - - Lemma opt_valuation_of_model_inv {m l k} : - opt_valuation_of_model m l = Some k -> - exists k', LevelMap.MapsTo l (Some k') m /\ k = valuation_of_value m k'. - Proof. - rewrite /opt_valuation_of_model. - destruct (find_spec l m) => //. - destruct k0 => //; intros [= <-]. - exists z. split => //. - Qed. + Definition inconsistent_opt_ext m cls := + forall v : Level.t -> option Z, + defined_valuation_of (clauses_levels cls) v -> + clauses_sem v (Clauses.union (clauses m) cls) -> False. - Lemma valuation_of_model_inv {m l k} : - LevelMap.MapsTo l k (Model.valuation_of_model m) -> - exists k', LevelMap.MapsTo l k' m /\ k = Z.to_nat (valuation_of_value m (option_get 0%Z k')). - Proof. - (* destruct k. *) - (* move/valuation_of_model_spec. - rewrite /valuation_of_model. - destruct (find_spec l m) => //. - destruct k0 => //; intros [= <-]. - exists z. split => //. *) - Admitted. Lemma interp_expr_inv {m le k} : interp_expr (opt_valuation_of_model m) le = Some k -> @@ -2154,6 +1684,88 @@ Lemma opt_valuation_of_model_equiv m l : cbn. now rewrite interp_nes_add. Qed. + Lemma enforce_clauses_inconsistent_opt {m cls u} : + enforce_clauses m cls = Some (inr u) -> + inconsistent_opt_ext m cls. + Proof. + intros ec. red. intros v def csem. + move/enforce_clauses_inconsistent_semilattice: ec => /(_ (option Z) _ v csem). + rewrite clauses_sem_eq //= interp_add_prems //=. + destruct u as [loop incl hl]. cbn. + destruct interp_nes eqn:hi => //=. lia. + red in def. + todo "scoping". + Qed. + + Lemma enforce_clauses_inconsistent {m cls u} : + enforce_clauses m cls = Some (inr u) -> + inconsistent (Clauses.union (clauses m) cls). + Proof. + move/enforce_clauses_inconsistent_semilattice => ec [v [posv cs]]. + move: (ec Z _ v cs). + rewrite clauses_sem_eq //= interp_add_prems //=. lia. + Qed. + + Definition inconsistent_clause_ext m cl := + forall v : Level.t -> Z, positive_valuation v -> clauses_sem v (clauses m) -> ~ clause_sem v cl. + + Definition inconsistent_ext m cls := + forall v : Level.t -> option Z, positive_opt_valuation v -> clauses_sem v (clauses m) -> ~ clauses_sem v cls. + + Lemma enforce_dec m cls : + clauses_levels cls ⊂_lset levels m -> + { consistent (Clauses.union (clauses m) cls) } + + { inconsistent_opt_ext m cls }. + Proof. + intros hm. + destruct (enforce_clauses m cls) eqn:ec. + destruct s as [model|loop]. + - left. move/enforce_clauses_clauses: ec. + intros <-. apply clauses_consistent. + - right. now move/enforce_clauses_inconsistent_opt: ec. + (* intros he v semcs semc. red in he. + specialize (he ) + apply he. red. exists v. split => //. + apply clauses_sem_union. split => //. *) + - move/enforce_clauses_None: ec. contradiction. + Qed. + + Definition valid_entailments cls cls' := + forall S (SL : Semilattice S Q.t) (V : Level.t -> S), clauses_sem V cls -> clauses_sem V cls'. + + Lemma check_clauses_complete m cls : + check_clauses m cls <-> valid_entailments (clauses m) cls. + Proof. + rewrite check_clauses_spec. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -completeness_all. + split. + - move=> vr s sl v. + move: (vr _ sl v). + rewrite !interp_rels_clauses_sem //. + - intros ve S s v. + move: (ve S s v). + now rewrite //= !interp_rels_clauses_sem. + Qed. + + Definition valid_semilattice_entailment {S} (SL : Semilattice S Q.t) cls cl := + (forall (v : Level.t -> S), clauses_sem v cls -> clause_sem v cl). + + Definition valid_semilattice_entailments {S} (SL : Semilattice S Q.t) cls cls' := + (forall (v : Level.t -> S), clauses_sem v cls -> clauses_sem v cls'). + + Lemma opt_valuation_of_model_inv {m l k} : + opt_valuation_of_model m l = Some k -> + exists k', LevelMap.MapsTo l (Some k') m /\ k = valuation_of_value m k'. + Proof. + rewrite /opt_valuation_of_model. + destruct (find_spec l m) => //. + destruct k0 => //; intros [= <-]. + exists z. split => //. + Qed. + + Lemma clause_sem_defined_valid_all {model cl} : defined_model_of (clause_levels cl) model -> clause_sem (valuation_of_model model) cl <-> clause_sem (opt_valuation_of_model model) cl. @@ -2253,13 +1865,18 @@ Lemma opt_valuation_of_model_equiv m l : Theorem check_invalid_valuation {cls cl} : check cls cl = Invalid -> exists v : Level.t -> option Z, - [/\ positive_opt_valuation v, clauses_sem v cls & ~ clause_sem v cl]. + [/\ positive_opt_valuation v, clauses_sem v cls, + defined_valuation_of (clause_levels cl) v & ~ clause_sem v cl]. Proof. - move/check_invalid=> [m' [ism en inval]]. + move/check_invalid=> [m' [ism en inval]].xfMNo have hpos := opt_valuation_of_model_pos. have semcls := valid_clauses_model_opt _ _ ism. - exists (opt_valuation_of_model m'). split => // semcl. - apply clause_sem_valid in semcl. contradiction. + exists (opt_valuation_of_model m'). split => //. + { intros l. + Search valid_clause. + have ve := valid_clause_elim. + todo "valuation of conclusion". } + { move/clause_sem_valid. contradiction. } Qed. Definition valid_clauses cls cls' := @@ -2282,7 +1899,7 @@ Lemma opt_valuation_of_model_equiv m l : - intros sem. unfold check_clauses, Deciders.check_clauses. eapply Clauses.for_all_spec. tc. move=> cl /sem => semcl. - destruct check eqn:hc => //. + unfold checkb; destruct check eqn:hc => //. * move/check_entails_looping : hc. rewrite -to_entails_all. rewrite -entails_L_entails_ℋ_equiv. @@ -2295,7 +1912,8 @@ Lemma opt_valuation_of_model_equiv m l : rewrite clauses_sem_leq. cbn. rewrite interp_add_prems //=. lia. * move/check_invalid_valuation: hc. - move=> [v [hpos semcls ncl]]. specialize (semcl v hpos semcls). now elim ncl. + move=> [v [hpos semcls def ncl]]. specialize (semcl v hpos semcls). + now elim ncl. Qed. Lemma check_clauses_Z_complete m cls : @@ -2313,7 +1931,7 @@ Lemma opt_valuation_of_model_equiv m l : - intros sem. unfold check_clauses, Deciders.check_clauses. eapply Clauses.for_all_spec. tc. move=> cl /sem => semcl. - destruct check eqn:hc => //. + unfold checkb; destruct check eqn:hc => //. * move/check_entails_looping : hc. rewrite -to_entails_all. rewrite -entails_L_entails_ℋ_equiv. @@ -2326,7 +1944,7 @@ Lemma opt_valuation_of_model_equiv m l : rewrite clauses_sem_leq. cbn. rewrite interp_add_prems //=. lia. * move/check_invalid_valuation: hc. - move=> [v [_ semcls ncl]]. specialize (semcl v). elim ncl; now apply semcl. + move=> [v [_ semcls def ncl]]. specialize (semcl v). elim ncl; now apply semcl. Qed. Definition opt_val_of_Z_val (v : Level.t -> Z) : Level.t -> option Z := fun l => Some (v l). @@ -2406,7 +2024,9 @@ Lemma opt_valuation_of_model_equiv m l : Qed. Lemma entails_dec (m : t) cl : - { entails (clauses m) cl } + { ~ entails (clauses m) cl /\ exists v : Level.t -> option Z, [/\ positive_opt_valuation v, clauses_sem v (clauses m) & ~ clause_sem v cl] }. + { entails (clauses m) cl } + { ~ entails (clauses m) cl /\ + exists v : Level.t -> option Z, + [/\ positive_opt_valuation v, clauses_sem v (clauses m), defined_valuation_of (clause_levels cl) v & ~ clause_sem v cl] }. Proof. destruct (check (clauses m) cl) eqn:ch. - move/check_looping: ch; elim. @@ -2417,7 +2037,7 @@ Lemma opt_valuation_of_model_equiv m l : apply clauses_levels_declared. } exact: is_model_of m. - have ci := check_invalid_valuation ch. - move/check_invalid_entails: ch. now right. + move/check_invalid_entails: ch. intros ne. right. split => //. - move/check_entails: ch. now left. Qed. @@ -2426,17 +2046,14 @@ Lemma opt_valuation_of_model_equiv m l : positive_opt_valuation v -> clauses_sem v cls -> clause_sem v cl. - Definition valid_clause_total cls cl := + Definition valid_clauses_Z cls cls' := forall v : Level.t -> Z, positive_valuation v -> - clauses_sem v cls -> clause_sem v cl. + clauses_sem v cls -> clauses_sem v cls'. Definition model_of_valuation V v := LevelSet.fold (fun l => LevelMap.add l (option_map (value_of_valuation V v) (v l))) V (LevelMap.empty _). - Definition to_Z_val (v : Level.t -> option Z) := - fun l => option_get 0 (v l). - Lemma entails_L_completeness {p l r} : (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v p -> interp_nes v l ≡ interp_nes v r)%sl -> p ⊢ℒ l ≡ r. @@ -2448,26 +2065,6 @@ Lemma opt_valuation_of_model_equiv m l : rewrite !interp_triv in hv. exact hv. Qed. -About entails_L_entails_ℋ. - - Lemma entails_L_clause_clauses {cls cl} : entails_L_pres_clause (relations_of_clauses cls) cl <-> entails_L_clauses cls (Clauses.singleton cl). - Proof. - rewrite /entails_L_clauses. - rewrite /entails_L_pres_clauses. - split. - - intros en c; rsets. now subst c. - - rsets. specialize (H cl). forward H; now rsets. - Qed. - - Lemma relations_of_clauses_singleton cl : relations_of_clauses (Clauses.singleton cl) = [relation_of_clause cl]. - Proof. destruct cl; reflexivity. Qed. - - Lemma interp_rels_tip {S} {SL : Semilattice S Q.t} (v : Level.t -> S) r : interp_rels v [r] <-> interp_rel v r. - Proof. - split. - - now intros h; depelim h. - - now constructor. - Qed. Lemma entails_completeness {cls cl} : (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), clauses_sem v cls -> clause_sem v cl)%sl <-> @@ -2541,112 +2138,24 @@ About entails_L_entails_ℋ. Qed. - Lemma neg_inverse (v : Level.t -> Z) (cl : clause) : - ~ (clauses_sem v (inverse_clauses cl)) <-> clause_sem v cl. - Proof. - destruct cl as [prems concl]. - cbn [clause_sem]. rewrite clauses_sem_leq. - rewrite interp_add_prems interp_nes_singleton. cbn; lia. - Qed. - - Lemma neg_inverse_opt (v : Level.t -> option Z) (cl : clause) : + Lemma neg_inverse {S} {SL : Semilattice S Q.t} {TSL : Total S} {TCon : Consistent S} (v : Level.t -> S) (cl : clause) : ~ (clauses_sem v (inverse_clauses cl)) <-> clause_sem v cl. Proof. destruct cl as [prems concl]. cbn [clause_sem]. rewrite clauses_sem_leq. rewrite interp_add_prems interp_nes_singleton. cbn. - destruct (interp_expr v concl) eqn:e => //=; - destruct (interp_nes v prems) eqn:e' => //=. - lia. lia. admit. - Admitted. + split; intros. + destruct (total (interp_expr v concl) (interp_nes v prems)) => //. + intros hadd. + assert (tr := transitivity hadd H). + apply (incon (interp_nes v prems)). + apply eq_antisym. split => //. + red. apply join_sub. + Qed. Definition enforce_inverse m cl := enforce_clauses m (inverse_clauses cl). - (*Lemma not_entails_invalid {m cl} : ~ entails (clauses m) cl -> ~ (forall m', clauses_sem v (clauses m) -> clause_sem v cl). - Proof. - destruct cl as [prems [concl k]]. - intros ne. - move/valid_clause_elim => hz. - - nv. - - [hm [en hv]]. - have ev := entails_model_valid. - destruct (entails_dec m cl). contradiction. - destruct a. destruct H0 as [v []]. apply H2. - - apply ne. - destruct (entails_dec m cl). - destruct - Search entails. *) - - (* Lemma inconsistent_decompose {m cls'} : inconsistent (Clauses.union (clauses m) cls') -> - forall v : Level.t -> Z, clauses_sem v (clauses m) -> clauses_sem v cls' -> False. - Proof. - intros ni v cs cs'. apply ni. exists v. apply clauses_sem_union. split => //. - Qed. *) - - Lemma inconsistent_opt_decompose {m cls'} : inconsistent_opt (Clauses.union (clauses m) cls') -> - forall v : Level.t -> option Z, clauses_sem v (clauses m) -> clauses_sem v cls' -> False. - Proof. - intros ni v cs cs'. apply ni. exists v. red. apply clauses_sem_union. split => //. - Admitted. - - Definition defined_valuation_of V (v : Level.t -> option Z) := - forall l, LevelSet.In l V -> exists x, v l = Some x. - - Definition incon m cls := - forall v : Level.t -> option Z, - defined_valuation_of (clauses_levels cls) v -> - clauses_sem v (clauses m) -> clauses_sem v cls -> False. - - Lemma cl_inverse_consistent_opt {m cl} : incon m (inverse_clauses cl) -> entails (clauses m) cl. - Proof. - move=> i. - have hc : forall v : Level.t -> option Z, - defined_valuation_of (clause_levels cl) v -> - clauses_sem v (clauses m) -> clause_sem v cl. - { intros v def cs. specialize (i v). forward i. admit. - apply neg_inverse_opt in i; tea. } - have hcheck := check_clauses_spec m (Clauses.singleton cl). - have hcheckz := check_clauses_Z_complete m (Clauses.singleton cl). - rewrite hcheck in hcheckz. apply hcheckz. - red. intros v cs cl' hin. eapply Clauses.singleton_spec in hin. subst cl'. - apply hc. admit. exact cs. clsets. - Admitted. - - (* Lemma cl_inverse_consistent {m cl} : inconsistent_opt (Clauses.union (clauses m) (inverse_clauses cl)) -> entails (clauses m) cl. - Proof. - move/inconsistent_decompose => i. - have hc : forall v : Level.t -> Z, clauses_sem v (clauses m) -> clause_sem v cl. - { intros v cs. specialize (i v cs). - now apply neg_inverse in i. } - have hcheck := check_clauses_spec m (Clauses.singleton cl). - have hcheckz := check_clauses_Z_complete m (Clauses.singleton cl). - rewrite hcheck in hcheckz. apply hcheckz. - red. intros v cs cl' hin. eapply Clauses.singleton_spec in hin. subst cl'. - apply hc. - - rewrite -(@entails_completeness (clauses m) cl). - - - destruct (entails_dec m cl). auto. - destruct a as [a _]. - move: (i (valuation_of_model m)) => /fwd. - apply model_valuation. elim. clear i. - destruct cl as [prems concl]; cbn. - rewrite clauses_sem_leq. - rewrite interp_add_prems. - cbn -[le]. rewrite interp_nes_singleton. - rewrite -(@entails_completeness (clauses m) (prems, concl)) in a. - - Search clauses_sem. - Search valuation_of_model. - Admitted. *) - Lemma entails_singleton cls cl : cls ⊢ℋ Clauses.singleton cl <-> entails cls cl. - Proof. Admitted. - Lemma clause_levels_inverse cl : clauses_levels (inverse_clauses cl) =_lset clause_levels cl. Proof. @@ -2675,10 +2184,65 @@ About entails_L_entails_ℋ. apply levels_spec; exists concl.2. destruct concl; cbn. now rsets. Qed. + Search consistent. + + Lemma consistent_dec m cl : + clause_levels cl ⊂_lset levels m -> + { consistent (Clauses.union (clauses m) (Clauses.singleton cl)) } + + { consistent (Clauses.union (clauses m) (inverse_clauses cl)) }. + Proof. + intros hcl. + destruct (enforce_dec m (Clauses.singleton cl)). + admit. + - now left. + - destruct (enforce_dec m (inverse_clauses cl)). + admit. + + now right. + + admit. + (* red in i, i0. + setoid_rewrite neg_inverse in i0. + specialize (i (valuation_of_model m) valuation_of_model_pos (model_valuation m)). + specialize (i0 (valuation_of_model m) valuation_of_model_pos (model_valuation m)). + elim i. now apply clauses_sem_singleton. *) + Admitted. + + Lemma clause_sem_dec (v : Level.t -> option Z) cl : + Decidable.decidable (clause_sem v cl). + Proof. + destruct cl; cbn. + destruct interp_expr eqn:ie; cbn; + destruct interp_nes eqn:ine; cbn. + red. + destruct (Z.eq_dec (Z.max z z0) z0). now left. + now right. now left. now right. now left. + Qed. + + Lemma clauses_sem_dec (v : Level.t -> option Z) cl : + Decidable.decidable (clauses_sem v cl). + Proof. + unfold clauses_sem. + move: cl. + Admitted. + + Instance total_opt : Total (option Z). + Proof. + red. intros [] []; cbn. lia. now left. now right. now left. + Qed. + + Instance con_Z : Consistent Z. + Proof. + intros x; cbn. lia. + Qed. - Lemma validity_decidable m cl : + Instance con_nat : Consistent nat. + Proof. + intros x; cbn. lia. + Qed. + + + Lemma check m cl : clause_levels cl ⊂_lset levels m -> - { valid_clause_total (clauses m) cl } + { ~ valid_clause_total (clauses m) cl }. + { valid_clause_Z (clauses m) cl } + { ~ valid_clause_Z (clauses m) cl }. Proof. intros hwf. (* Check *) @@ -2686,59 +2250,83 @@ About entails_L_entails_ℋ. - left. intros h hpov hsem. rewrite -entails_completeness in e. now apply e. - - destruct a as [a ne]. - have hcheck := check_clauses_spec m (Clauses.singleton cl). - have hcheckz := check_clauses_Z_complete m (Clauses.singleton cl). - (* rewrite entails_singleton in hcheck. *) - (* rewrite -hcheck hcheckz in a. *) - unfold valid_semilattice_entailments in a. - destruct (enforce_dec m (inverse_clauses cl)) => //. + - right. destruct (enforce_dec m (inverse_clauses cl)) => //. * setoid_rewrite <- hwf. now rewrite clause_levels_inverse. - * right. intros vc. + * intros vc. destruct c as [tot [totpos csem]]. apply clauses_sem_union in csem as [cls cinv]. red in vc. move: (vc tot) => /fwd. exact: totpos. move=>/(_ cls) => hcl. now eapply clauses_sem_tot_inverse_false. - * (* the converse m /\ j < i |= is inconsistent, - so i <= j is consistent but not entailed. *) - left. + * intros _. + destruct a as [nent [v [hp semcs def semc]]]. red in i. - red. intros v posv semcs. - specialize (i v posv semcs). now apply neg_inverse in i. + rewrite -neg_inverse in semc. + apply Decidable.not_not in semc. + 2:{ apply clauses_sem_dec. } + specialize (i v). + rewrite clause_levels_inverse in i. + apply i => //. apply clauses_sem_union. + split => //. Qed. - Definition valid_clauses_nat cls cl := - forall v : Level.t -> Z, clauses_sem v cls -> ~ clause_sem v cl. + Lemma nRopt {A} (x y : A) : ~ R_opt Logic.eq (Some x) (Some y) -> x <> y. + Proof. + intros hr heq. apply hr. now cbn. + Qed. +(* + Lemma extend_val m cl : + (exists v : Level.t -> option Z, + [/\ positive_opt_valuation v, clauses_sem v (clauses m), enables_clause v cl & ~ clause_sem v cl]) -> + exists v : Level.t -> option Z, + [/\ positive_opt_valuation v, enables_clauses v (clauses m), clauses_sem v (clauses m), enables_clause v cl & ~ clause_sem v cl]. + Proof. + intros [v [vpos csem en nsem]]. + destruct cl as [prems concl]. cbn in nsem. + red in en. destruct en as [k he]. + rewrite he in nsem. cbn in nsem. + destruct (interp_expr v concl) eqn:hiconcl. + - (* Conclusion is defined but not high enough *) + apply nRopt in nsem. + have hmax : Z.max z k = z /\ k < z. + { destruct (Z.max_spec k z) as [[]|[]]; try lia. split => //. lia. + cbn. lia. } + cbn in he. + exact H. + move/(iffP): nsem. *) - (* Definition full_valuation V v := - forall l, LevelSet.In l V -> exists z, v l = Some z /\ - if l == Level.zero then z = 0 - else if Level.is_global l then z > 0 - else z >= 0. - Definition valid_Z_semilattice_entailments cls cls' := - (forall (v : Level.t -> option Z), full_valuation (clauses_levels cls ∪ clauses_levels cls') v -> - clauses_sem v cls -> clauses_sem v cls'). + Lemma check' m cl : + clause_levels cl ⊂_lset levels m -> + { valid_clause_Z (clauses m) cl } + { ~ valid_clause_Z (clauses m) cl }. + Proof. + intros hwf. + (* Check *) + destruct (entails_dec m cl). + - left. intros h hpov hsem. + rewrite -entails_completeness in e. + now apply e. + - destruct (consistent_dec m cl) => //. + * right; intros vc. red in vc. red in c. destruct a. + admit. + (* * setoid_rewrite <- hwf. + now rewrite clause_levels_inverse. *) + * right. intros vc. + destruct c as [tot [totpos csem]]. + apply clauses_sem_union in csem as [cls cinv]. + red in vc. move: (vc tot) => /fwd. exact: totpos. + move=>/(_ cls) => hcl. + now eapply clauses_sem_tot_inverse_false. + Qed. + + (* Definition check_clauses m cls (decl : clauses_levels cl ⊂_lset levels m) := + { valid_clause_Z (clauses m) cl } + { ~ valid_clause_Z (clauses m) cl }. + Proof. *) - Lemma valid_entail_equiv {cls cls'} : - valid_semilattice_entailments Zopt_semi cls cls' <-> - valid_semilattice_entailments Zsemilattice cls cls'. - Proof. - split. - - intros ent v cs. - specialize (ent (opt_val_of_Z_val v)). - now rewrite !clauses_sem_opt in ent. - - move=> ent v cs. specialize (ent (Z_val_of_opt_val v)). - forward ent. move=> cl /cs. - destruct cl as [prems concl] => //=. - intros hm. rewrite interp_expr_opt interp_nes_opt //=. - move=> cl /ent. destruct cl as [prems concl] => //=. - Qed.*) End Abstract. End Deciders. @@ -2754,6 +2342,7 @@ Module LoopChecking (LS : LevelSets). Definition levels (x : t) := levels x. Definition clauses (x : t) := clauses x. + Definition valuation (x : t) := valuation x. Lemma clauses_levels_declared m : clauses_levels (clauses m) ⊂_lset levels m. Proof. @@ -2825,19 +2414,23 @@ Module LoopChecking (LS : LevelSets). Qed. Import Semilattice. - Lemma enforce_inconsistent {m cls u} : + Lemma enforce_inconsistent_semilattice {m cls u} : enforce m cls = Some (inr u) -> forall S (SL : Semilattice.Semilattice S Q.t) (V : Level.t -> S), clauses_sem V (Clauses.union (clauses m) (to_clauses cls)) -> clauses_sem V (Impl.CorrectModel.loop_univ u ≡ succ (Impl.CorrectModel.loop_univ u)). Proof. rewrite /enforce. + now move/enforce_clauses_inconsistent_semilattice. + Qed. + + Lemma enforce_inconsistent {m cls u} : + enforce m cls = Some (inr u) -> + inconsistent_ext m (to_clauses cls). + Proof. move/enforce_clauses_inconsistent. - rewrite -entails_L_rels_entails_L_clauses. - rewrite -ISL.completeness_all. - move=> vr S SL V. - specialize (vr S SL V). - move: vr. - rewrite !interp_rels_clauses_sem // => vr /vr. + intros incon v vpos clssem csem. + apply incon. exists v. split => //. + apply clauses_sem_union. split => //. Qed. Lemma enforce_clauses {m cls m'} : @@ -2855,6 +2448,13 @@ Module LoopChecking (LS : LevelSets). Definition valid_entailments cls cls' := forall S (SL : Semilattice.Semilattice S Q.t) (V : Level.t -> S), clauses_sem V cls -> clauses_sem V cls'. + (* Definition check m c : + clause_levels (to_clauses c) ⊂_lset levels m -> + { valid_clauses_Z (clauses m) (to_clauses c) } + { ~ valid_clauses_Z (clauses m) (to_clauses c) } := + Impl.check m.(Impl.Abstract.clauses) (to_clauses c). *) + + + (* Returns true is the constraint is valid in the model and all its possible consistent extensions. Returns false if the constraint results in an inconsistent set of constraints or it simply is not valid. *) @@ -2886,6 +2486,11 @@ Module LoopChecking (LS : LevelSets). Lemma above_zero_declared m : Impl.CorrectModel.above_zero_declared (levels m) (clauses m). Proof. eapply above_zero_declared. Qed. + Definition model_valuation m : clauses_sem (to_Z_val (valuation m)) (clauses m). + Proof. + apply model_valuation. + Qed. + Lemma model_valuation_zero m : valuation m Level.zero = 0%nat. Proof. apply valuation_0. Qed. diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 98eabf54e..fdc826839 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -1602,6 +1602,12 @@ Module Clauses (LS : LevelSets). rewrite /succ_expr //=. lia_f_equal. Qed. + Lemma add_assoc le le' prems : add le (add le' prems) = add le' (add le prems). + Proof. + rewrite -!NES.union_add_singleton. + now rewrite !union_assoc (@union_comm (singleton _)). + Qed. + Lemma entails_weak_list {cls prem concl concl'} : cls ⊢ prem → concl -> cls ⊢ add_list concl' prem → concl. @@ -1677,6 +1683,50 @@ Module Clauses (LS : LevelSets). assumption. Qed. +(* + Lemma succ_clauses_equiv_weak cls prems concl : + succ_clauses cls ⊢ NES.add concl (succ_prems prems) → succ_expr concl -> + cls ⊢ prems → concl \/ cls ⊢ singleton concl → succ_expr concl. + Proof. + intros ha; depind ha. + - left. constructor. + move: H. + rewrite add_spec. + move=> -[]. destruct concl1; unfold add; cbn. move=> [=]. lia. + rewrite In_add_prems => [] [le [hin heq]]. + move/add_expr_inj: heq. now intros ->. + - depelim H. + + destruct cl as [prems concl]. noconf H0. + eapply in_add_clauses in H as [[prems' concl'] [hin heq]]. + noconf heq. + apply (incls cls (prems', concl') n) in hin. + specialize (IHha (add (add_expr n concl') prems0) concl1). + forward IHha. + { f_equal. rewrite !add_expr_add_expr. cbn -[Z.add]; + now rewrite add_prems_add add_expr_add_expr Z.add_comm add_assoc. } + rewrite add_prems_add_prems in H1. + destruct IHha. + cbn -[Z.add] in H1. + rewrite Z.add_comm in H1. + rewrite -(add_prems_add_prems 1 n prems') in H1. + eapply (clause_cut _ (add_prems n prems') (add_expr n concl')) in H; tea. + now left. + + 2:{} 2:eapply IHha. + 2: + eapply (@inj_add_prems_sub 1). + rewrite LevelExprSet.add_spec in H1. + + specialize (H0 (x, 1 + k)). forward H0. rewrite Z.add_comm. now apply LevelExprSet.singleton_spec. + eapply In_add_prems in H0 as [[l' k'] [hin heq]]. noconf heq. + cbn -[Z.add] in *. + have eq: k' = k by lia. subst k'. clear H. + eapply clause_cut. 2:eapply IHha. eapply (predcl _ x (k - 1)). + 2:{ intros x'. move/LevelExprSet.singleton_spec => ->. now have -> : k - 1 + 1 = k by lia. } + f_equal. rewrite add_prems_add. f_equal. + rewrite /succ_expr //=. lia_f_equal. + Qed. *) + + Lemma entails_clauses_cut_one {cls cls0 cl} : cls ⊢ℋ cls0 -> entails (Clauses.union cls0 cls) cl -> diff --git a/common/theories/LoopChecking/HornSemilatticeEquiv.v b/common/theories/LoopChecking/HornSemilatticeEquiv.v index 8cd757ecd..db65aa384 100644 --- a/common/theories/LoopChecking/HornSemilatticeEquiv.v +++ b/common/theories/LoopChecking/HornSemilatticeEquiv.v @@ -16,6 +16,8 @@ Module HornSemilattice (LS : LevelSets). Local Open Scope sl_scope. + Notation relation_of_clause cl := (singleton (concl cl) ≤ premise cl). + Definition relations_of_clauses c := Clauses.fold (fun '(prems, concl) acc => (NES.union (singleton concl) prems, prems) :: acc) c []. @@ -660,4 +662,205 @@ Module HornSemilattice (LS : LevelSets). eapply entails_L_le_right. Qed. + Lemma entails_L_clause_clauses {cls cl} : entails_L_pres_clause (relations_of_clauses cls) cl <-> entails_L_clauses cls (Clauses.singleton cl). + Proof. + rewrite /entails_L_clauses. + rewrite /entails_L_pres_clauses. + split. + - intros en c; rsets. now subst c. + - rsets. specialize (H cl). forward H; now rsets. + Qed. + + Lemma relations_of_clauses_singleton cl : relations_of_clauses (Clauses.singleton cl) = [relation_of_clause cl]. + Proof. destruct cl; reflexivity. Qed. + + Instance entails_L_pres_clauses_proper : Proper (Logic.eq ==> Clauses.Equal ==> iff) entails_L_pres_clauses. + Proof. + intros ?? -> ? ? h. + rewrite /entails_L_pres_clauses. now rewrite h. + Qed. + + Lemma entails_L_pres_clauses_union {p cls cls'} : entails_L_pres_clauses p (Clauses.union cls cls') <-> + entails_L_pres_clauses p cls /\ + entails_L_pres_clauses p cls'. + Proof. + rewrite /entails_L_pres_clauses /Clauses.For_all. + setoid_rewrite Clauses.union_spec. by firstorder. + Qed. + + Lemma entails_L_rels_entails_rels p rs : + entails_L_rels p rs <-> entails_L_clauses (clauses_of_relations p) (clauses_of_relations rs). + Proof. + induction rs. + - split => //. + * intros ent cl hin. cbn in hin. clsets. + * cbn. constructor. + - split. + * intros ent; depelim ent. + unfold entails_L_clauses. + destruct a as [l r]. rewrite clauses_of_relations_cons entails_L_pres_clauses_union. split. + now eapply entails_L_clauses_relations, entails_L_pres_clauses_of_relations_eq. + apply IHrs, ent. + * unfold entails_L_clauses. + destruct a as [l r]. rewrite clauses_of_relations_cons entails_L_pres_clauses_union. + move=> [] lr ih. constructor. + apply (proj1 entails_L_pres_clauses_of_relations_eq) in lr. + now apply entails_L_clauses_pres_all in lr. + apply IHrs, ih. + Qed. + + Lemma entails_clauses_of_relations cls : entails_clauses cls (clauses_of_relations (relations_of_clauses cls)). + Proof. + apply entails_ℋ_clauses_of_relations_equiv. apply entails_clauses_tauto. + Qed. + + Lemma entails_clauses_trans {cls cls' cls''} : cls ⊢ℋ cls' -> cls' ⊢ℋ cls'' -> cls ⊢ℋ cls''. + Proof. + intros ent ent'. + eapply entails_clauses_cut; tea. + eapply entails_ℋ_clauses_subset; tea. clsets. + Qed. + + Lemma entails_L_rels_entails_L_clauses cls cls' : + entails_L_rels (relations_of_clauses cls) (relations_of_clauses cls') <-> entails_L_clauses cls cls'. + Proof. + rewrite entails_L_rels_entails_rels. + rewrite !entails_L_entails_ℋ_equiv. + split. + - intros cl. eapply entails_clauses_cut. eapply entails_ℋ_clauses_of_relations. tea. + eapply entails_ℋ_clauses_subset. eapply entails_clauses_tauto. intros cl' hin. + apply clauses_of_relations_relations_of_clauses in hin. + rewrite Clauses.union_spec. now left. + - intros hent. eapply (proj1 entails_ℋ_clauses_of_relations_equiv). + eapply entails_clauses_trans; tea. eapply entails_clauses_of_relations. + Qed. + + Lemma clauses_of_le_singleton le r : + (singleton le ⋞ r)%cls =_clset Clauses.singleton (r, le). + Proof. + intros l. + rewrite Clauses.singleton_spec clauses_of_le_spec. + firstorder. + - subst l. apply LevelExprSet.singleton_spec in H. + now red in H; subst x. + - subst l. exists le. split => //. now apply LevelExprSet.singleton_spec. + Qed. + +Section ClausesSemantics. + Import Semilattice. + + Definition clause_sem {S} {SL : Semilattice S Q.t} (V : Level.t -> S) (cl : clause) : Prop := + let '(prems, concl) := cl in + le (interp_expr V concl) (interp_nes V prems). + + Definition clauses_sem {S} {SL : Semilattice S Q.t} (V : Level.t -> S) (cls : Clauses.t) : Prop := + Clauses.For_all (clause_sem V) cls. + + Instance clauses_sem_proper {S} {SL : Semilattice S Q.t} : + Proper (Logic.eq ==> Clauses.Equal ==> iff) (clauses_sem (S:=S)). + Proof. + move=> ?? -> ?? h. + rewrite /clauses_sem. + now rewrite h. + Qed. + + Lemma clauses_sem_singleton {S} {SL : Semilattice S Q.t} {V cl} : + clauses_sem (S:=S) V (Clauses.singleton cl) <-> clause_sem V cl. + Proof. + rewrite /clauses_sem /Clauses.For_all. + split; firstorder. apply H. clsets. + apply Clauses.singleton_spec in H0. now subst. + Qed. + + Lemma clauses_sem_add {S} {SL : Semilattice S Q.t} {V cl cls} : + clauses_sem (S:=S) V (Clauses.add cl cls) <-> clause_sem V cl /\ clauses_sem V cls. + Proof. + rewrite /clauses_sem /Clauses.For_all. + split. + - intros hcl. split. + * apply hcl, Clauses.add_spec; now left. + * move=> x hin; apply hcl, Clauses.add_spec; now right. + - move=> [] hcl hcls x /Clauses.add_spec -[]. now subst. + apply hcls. + Qed. + + Lemma clauses_sem_union {S} {SL : Semilattice S Q.t} {V cls cls'} : + clauses_sem (S:=S) V (Clauses.union cls cls') <-> clauses_sem V cls /\ clauses_sem V cls'. + Proof. + rewrite /clauses_sem /Clauses.For_all. + setoid_rewrite Clauses.union_spec. firstorder. + Qed. + + Definition valid_semilattice_entailment cls cl := + (forall S (SL : Semilattice S Q.t) (CSL : Consistent S), + forall (v : Level.t -> S), clauses_sem v cls -> clause_sem v cl). + + Lemma clauses_of_le_add le l r : + (NES.add le l ⋞ r)%cls =_clset Clauses.add (r, le) (l ⋞ r). + Proof. + intros cl. + rewrite Clauses.add_spec clauses_of_le_spec. + split. + - move=> [] x [] /LevelExprSet.add_spec; rewrite /LevelExprSet.E.eq. + move=> [->|hin]. now left. + intros ->. right. rewrite clauses_of_le_spec. now exists x. + - move=> [->|]. exists le. split => //. + * now apply LevelExprSet.add_spec; left. + * rewrite clauses_of_le_spec => -[] k [] hin ->. + exists k. split => //. now apply LevelExprSet.add_spec. + Qed. + + Lemma clauses_sem_leq {S} {SL : Semilattice S Q.t} (V : Level.t -> S) l r : + clauses_sem V (l ⋞ r) <-> + (interp_nes V l ≤ interp_nes V r)%sl. + Proof. + move: l. + apply: elim. + - intros le; cbn. + rewrite clauses_of_le_singleton clauses_sem_singleton. + cbn. now rewrite interp_nes_singleton. + - move=> le x xr hnin. + rewrite clauses_of_le_add clauses_sem_add xr. + cbn. rewrite interp_nes_add. + symmetry; apply join_le_left_eq. + Qed. + + Lemma clauses_sem_eq {S} {SL : Semilattice S Q.t} (V : Level.t -> S) l r : + clauses_sem V (l ≡ r) <-> + (interp_nes V l ≡ interp_nes V r)%sl. + Proof. + rewrite /clauses_of_eq clauses_sem_union !clauses_sem_leq. + symmetry; apply eq_antisym. + Qed. + + Lemma interp_rels_of_clauses {S} {SL : Semilattice S Q.t} {V : Level.t -> S} {cls} : + interp_rels V (relations_of_clauses cls) <-> + forall cl, Clauses.In cl cls -> interp_rel V (relation_of_clause cl). + Proof. + rewrite /interp_rels Forall_forall. + split. + - move=> hx cl /relations_of_clauses_spec_inv. + now move/hx. + - move=> hcl x /relations_of_clauses_spec => -[] prems [] concl. + now move=> [] /hcl hin ->. + Qed. + + Lemma interp_rel_clause_sem {S} {SL : Semilattice S Q.t} {V : Level.t -> S} {cl} : + clause_sem V cl <-> interp_rel V (relation_of_clause cl). + Proof. + destruct cl as [prems concl] => //=. + now rewrite /le interp_nes_union interp_nes_singleton. + Qed. + + Lemma interp_rels_clauses_sem {S} {SL : Semilattice S Q.t} {V : Level.t -> S} {cls} : + clauses_sem V cls <-> interp_rels V (relations_of_clauses cls). + Proof. + rewrite interp_rels_of_clauses. + split. + - move=> sem cl /sem; apply interp_rel_clause_sem. + - move=> hcl cl /hcl /=. apply interp_rel_clause_sem. + Qed. + +End ClausesSemantics. + End HornSemilattice. diff --git a/common/theories/LoopChecking/InitialSemilattice.v b/common/theories/LoopChecking/InitialSemilattice.v index c45dee4a5..212d9ff95 100644 --- a/common/theories/LoopChecking/InitialSemilattice.v +++ b/common/theories/LoopChecking/InitialSemilattice.v @@ -609,4 +609,11 @@ Module InitialSemilattice (LS : LevelSets). split; now apply entails_L_all_app. Qed. +Lemma interp_rels_tip {S} {SL : Semilattice.Semilattice S Q.t} (v : Level.t -> S) r : interp_rels v [r] <-> interp_rel v r. +Proof. + split. + - now intros h; depelim h. + - now constructor. +Qed. + End InitialSemilattice. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 6b45c472d..e6e6274c7 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -69,7 +69,7 @@ From Stdlib Require Import ssreflect ssrbool ssrfun ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils. +From MetaRocq.Utils Require Import utils SemiLattice. From MetaRocq.Common Require Universes. From MetaRocq.Common Require Import Common Interfaces HornClauses HornSemilatticeEquiv. @@ -3215,4 +3215,293 @@ Module Model (LS : LevelSets). rewrite hmin in eqmins. noconf eqmins. lia. Qed. + Section ModelShift. + + + Definition shift_model n (m : model) := + LevelMap.map (fun k => option_map (fun k => k + n) k) m. + + Lemma level_value_shift_model {n m l} : level_value (shift_model n m) l = option_map (fun v => v + n) (level_value m l). + Proof. + rewrite /shift_model /level_value LevelMapFact.F.map_o. + case: (find_spec l m) => //. + Qed. + + Lemma min_premise_shift {n m k u} : + min_premise (shift_model n m) u = Some k -> + min_premise m u = Some (k - n). + Proof. + move/min_premise_spec_aux => [hf [[minl mink] [hin heq]]]. + rewrite /min_atom_value level_value_shift_model in heq. + have [hf' [[minl' mink'] [hin' heq']]] := min_premise_spec m u. + rewrite /min_atom_value in heq'. + destruct (level_value m minl) eqn:hl => //. + cbn in heq. noconf heq. + specialize (hf' _ hin). + specialize (hf _ hin'). + rewrite /min_atom_value in hf'. + rewrite /min_atom_value level_value_shift_model in hf. + destruct (level_value m minl') eqn:hl'; cbn in *. + - rewrite heq'; f_equal. rewrite heq' in hf'. + rewrite hl in hf'. depelim hf. depelim hf'. lia. + - depelim hf. + Qed. + + Lemma min_premise_shift_inv {n m k u} : + min_premise m u = Some k -> + min_premise (shift_model n m) u = Some (n + k). + Proof. + move/min_premise_spec_aux => [hf [[minl mink] [hin heq]]]. + have [hf' [[minl' mink'] [hin' heq']]] := min_premise_spec (shift_model n m) u. + rewrite /min_atom_value level_value_shift_model in heq'. + destruct (level_value m minl') eqn:hl => //. + rewrite /min_atom_value in heq. + cbn in heq'. noconf heq'. + specialize (hf' _ hin). + specialize (hf _ hin'). + rewrite /min_atom_value in hf'. + rewrite /min_atom_value in hf. + destruct (level_value m minl) eqn:hl'; cbn in *. + - rewrite heq'; f_equal. rewrite heq' level_value_shift_model in hf'. + rewrite hl in hf. noconf heq. rewrite hl' in hf'. depelim hf. depelim hf'. lia. + - noconf heq. + - cbn in heq'. specialize (hf _ hin'). rewrite /min_atom_value hl //= in hf. depelim hf. + Qed. + + Lemma valid_clause_shift_model {n m cl} : valid_clause m cl <-> valid_clause (shift_model n m) cl. + Proof. + destruct cl as [prems [concl k]]. + split. + - move/valid_clause_elim => hz. + apply valid_clause_intro => z. + move/min_premise_shift /hz. + rewrite level_value_shift_model. + intros hle; depelim hle. rewrite H0 //=. constructor. lia. + - move/valid_clause_elim => hz. + apply valid_clause_intro => z. + move/min_premise_shift_inv /hz. + rewrite level_value_shift_model. + destruct (level_value m concl) => //=; + intros hle; depelim hle. constructor. lia. + Qed. + + Lemma enabled_clause_shift {n m cl} : enabled_clause m cl <-> enabled_clause (shift_model n m) cl. + Proof. + destruct cl as [prems [concl k]]. + split. + - move=> [] z. cbn. move/min_premise_shift_inv. + now eexists. + - move=> [] z; move/min_premise_shift. now eexists. + Qed. + + Lemma shift_model_invariant {n m cls} : + is_model cls m <-> + is_model cls (shift_model n m). + Proof. + rewrite /is_model. + rewrite ![is_true _]Clauses.for_all_spec. + unfold Clauses.For_all. + now setoid_rewrite (@valid_clause_shift_model n m). + Qed. + + Lemma shift_model_min_pos {m} : model_min (shift_model (- model_min m) m) = 0. + Proof. + destruct (model_has_min (shift_model (- model_min m) m)) => //. + destruct H as [l [k [inshift eq]]]. + move: inshift. + rewrite /shift_model LevelMapFact.F.map_mapsto_iff => -[a [eq' hm]]. + destruct a; cbn in eq' => //. + noconf eq'. rewrite eq. + have msp := model_min_spec _ _ _ hm. + have m0 := model_min_spec2 m. + have m1 := model_min_spec2 (shift_model (- model_min m) m). lia. + Qed. + + End ModelShift. + + + + + Definition to_val (v : LevelMap.t nat) l := + match LevelMap.find l v with + | Some n => n + | None => 0%nat + end. + + Definition to_Z_val (v : Level.t -> nat) := fun l => Z.of_nat (v l). + + Definition valuation m := to_val (Model.valuation_of_model m). + + Lemma valuation_range {m l k} : + LevelMap.MapsTo l (Some k) m -> + model_min m <= k <= model_max m. + Proof. + move=> hm. + have mins := model_min_spec m _ _ hm. + have maxs := model_max_spec m _ _ hm. + depelim maxs. lia. + Qed. + + Definition valuation_of_value m n := + let max := model_max m in + let min := model_min m in + max - n - min. + + Lemma valuation_of_value_pos {l m n} : + LevelMap.MapsTo l (Some n) m -> valuation_of_value m n >= 0. + Proof. + rewrite /valuation_of_value => hm. + have hmax := model_max_spec m _ _ hm. + have hmin := model_min_spec m _ _ hm. + depelim hmax. + have := model_min_spec2 m. lia. + Qed. + + Definition opt_valuation_of_model (m : LevelMap.t (option Z)) l := + match LevelMap.find l m with + | Some (Some n) => Some (valuation_of_value m n) + | _ => None + end. + + Definition Z_valuation_of_model model := + to_Z_val (to_val (Model.valuation_of_model model)). + + Definition positive_opt_valuation (v : Level.t -> option Z) := + forall l k, v l = Some k -> k >= 0. + + Definition positive_valuation (v : Level.t -> Z) := + forall l, v l >= 0. + + Lemma opt_valuation_of_model_pos {m} : positive_opt_valuation (opt_valuation_of_model m). + Proof. + rewrite /opt_valuation_of_model /positive_valuation => l k'. + case: (find_spec l m) => //. + move=> [k|] hm // [=] <-. + now eapply valuation_of_value_pos. + Qed. + + Lemma valuation_of_model_pos {m} : positive_valuation (Z_valuation_of_model m). + Proof. + intros l. rewrite /Z_valuation_of_model /to_Z_val /to_val. lia. + Qed. + + Definition Zopt_semi := opt_semi Zsemilattice. + Existing Instance Zopt_semi. + Import Semilattice. + + Lemma valid_clause_model_opt model cl : + valid_clause model cl -> + clause_sem (opt_valuation_of_model model) cl. + Proof. + unfold valid_clause. + destruct min_premise eqn:hmin => //= => //. + 2:{ move/min_premise_spec_aux: hmin => [hf [[min mink] [inmin hmin]]]. + move=> _. destruct cl as [prems concl]. cbn. + rewrite /min_atom_value in hmin. + set (v := opt_valuation_of_model _). + set (ip := interp_nes _ _). + have -> : ip = None. + { subst ip. move/(interp_nes_ge v): inmin; tea. + have -> : interp_expr v (min, mink) = None. + { cbn. subst v. unfold opt_valuation_of_model. + move: hmin; rewrite /level_value; case: find_spec => //. + move=> k hm. destruct k => //. } + move/le_spec. intros [] => //. + destruct H as [? [? []]]. congruence. } + destruct interp_expr => //=. } + destruct cl as [prems [concl k]]. cbn -[Semilattice.le]. + unfold level_value_above. + destruct level_value eqn:hl => //. + unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. + move/Z.leb_le => hrel. + eapply LevelMap.find_2 in hfind. + have conclm := valuation_of_model_spec _ _ _ hfind. + set (v := (model_max _ - _)) in *. + cbn in conclm. + eapply LevelMap.find_1 in conclm. + subst v. + pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. + rewrite hmin in premeq. + eapply transitivity. 2:{ eapply (interp_nes_ge (S := option Z) (SL := Zopt_semi)); tea. } + unfold interp_expr. destruct prem as [prem k']. + symmetry in premeq. + move: premeq. unfold min_atom_value. + unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. + destruct o => //. + intros [= <-]. + eapply LevelMap.find_2 in findp. + have premm := valuation_of_model_spec _ _ _ findp. + eapply LevelMap.find_1 in premm. + assert (z1 - k' <= z0 - k). lia. + have [z0min z0max] := valuation_range hfind. + have [z1min z1max] := valuation_range findp. + assert (0 <= model_max model)%Z by apply model_max_spec2. + assert (model_min model <= 0)%Z by apply model_min_spec2. + rewrite /opt_valuation_of_model. rewrite (LevelMap.find_1 findp) (LevelMap.find_1 hfind). + rewrite /valuation_of_value. cbn. lia. + Qed. + + Lemma valid_clauses_model_opt model cls : + is_model cls model -> + clauses_sem (opt_valuation_of_model model) cls. + Proof. + move=> ism cl hin. + apply valid_clause_model_opt. + now move/Clauses.for_all_spec: ism; apply. + Qed. + + (** Enabled and valid clauses are satisfied by valuation. + *) + Lemma valid_clause_model model cl : + enabled_clause model cl -> + valid_clause model cl -> + clause_sem (Z_valuation_of_model model) cl. + Proof. + unfold enabled_clause, valid_clause. + destruct min_premise eqn:hmin => //= => //. + 2:{ intros [k' eq]. congruence. } + intros [k' eq]. noconf eq. + destruct cl as [prems [concl k]]. cbn -[Semilattice.le]. + unfold level_value_above. + destruct level_value eqn:hl => //. + unfold level_value in hl. destruct LevelMap.find eqn:hfind => //. noconf hl. + move/Z.leb_le => hrel. + eapply LevelMap.find_2 in hfind. + have conclm := valuation_of_model_spec _ _ _ hfind. + set (v := (model_max _ - _)) in *. + cbn in conclm. + eapply LevelMap.find_1 in conclm. + subst v. + pose proof (@min_premise_spec model prems) as [premmin [prem [premin premeq]]]. + rewrite hmin in premeq. + eapply transitivity. 2:{ eapply interp_nes_ge; tea. } + unfold interp_expr. destruct prem as [prem k']. + symmetry in premeq. + move: premeq. unfold min_atom_value. + unfold level_value. destruct (LevelMap.find prem) eqn:findp => //. + destruct o => //. + intros [= <-]. + eapply LevelMap.find_2 in findp. + have premm := valuation_of_model_spec _ _ _ findp. + eapply LevelMap.find_1 in premm. + assert (z1 - k' <= z0 - k). lia. + have [z0min z0max] := valuation_range hfind. + have [z1min z1max] := valuation_range findp. + assert (0 <= model_max model)%Z by apply model_max_spec2. + assert (model_min model <= 0)%Z by apply model_min_spec2. + rewrite /Z_valuation_of_model /to_Z_val /to_val premm conclm. + cbn. lia. + Qed. + + Lemma valid_clauses_model model cls : + enabled_clauses model cls -> + is_model cls model -> + clauses_sem (Z_valuation_of_model model) cls. + Proof. + move=> en ism cl hin. + apply valid_clause_model. + now apply en. + now move/Clauses.for_all_spec: ism; apply. + Qed. + End Model. diff --git a/common/theories/LoopChecking/ModelValuations.v b/common/theories/LoopChecking/ModelValuations.v new file mode 100644 index 000000000..e69de29bb diff --git a/common/theories/LoopChecking/Models.v b/common/theories/LoopChecking/Models.v index 01562388d..f6d4bd47e 100644 --- a/common/theories/LoopChecking/Models.v +++ b/common/theories/LoopChecking/Models.v @@ -3,7 +3,7 @@ for defining satisfiability and validity checking. *) -From Stdlib Require Import ssreflect ssrbool ZArith. +From Stdlib Require Import ssreflect ssrfun ssrbool ZArith. From Stdlib Require Import Program RelationClasses Morphisms. From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. From MetaRocq.Utils Require Import utils. @@ -17,6 +17,53 @@ Module Models (LS : LevelSets). Module Export Model := Model(LS). Local Open Scope Z_scope. + + (* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by + setting a minimal value for the new atoms in [clauses_levels cls \ V] + such that the new clauses [cls] do not hold vacuously. + *) + + Equations add_max (l : Level.t) (k : option Z) (m : model) : model := + add_max l k m with level_value m l := + { | Some k' with check_atom_value k (Some k') := + { | true => m + | false => LevelMap.add l k m } + | None => LevelMap.add l k m }. + + Lemma add_max_spec l l' k k' (m : model) : + LevelMap.MapsTo l k (add_max l' k' m) <-> + (l = l' /\ k = max_opt_of Z.max k' (level_value m l)) \/ + (l <> l' /\ LevelMap.MapsTo l k m). + Proof. + funelim (add_max l' k' m). + - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. firstorder; subst. + left. split => //. rewrite Heq. now rewrite max_opt_of_l. + left. firstorder. now rewrite Heq max_opt_of_l. + - clear Heqcall. + destruct (Level.eq_dec l0 l). + * subst l0. rewrite Heq0. + move/check_atom_value_spec: Heq. + rewrite (maps_to_update (level_value_MapsTo' Heq0)). + firstorder; subst; try left; try split; auto; depelim Heq; cbn; lia_f_equal. + * firstorder. + - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. + have := check_atom_value_spec k (Some k'). rewrite {}Heq. + intros h; depelim h. apply nleq_optZ in H as [z [-> hlt]]. + firstorder; subst. + * left; split => //. rewrite Heq0 //=. lia_f_equal. + * left; split => //. rewrite Heq0 //=. lia_f_equal. + Qed. + + Lemma In_add_max l l' k acc : + LevelMap.In l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). + Proof. + rewrite /LevelMap.In. + rw add_max_spec. firstorder subst. + eexists; left; eauto. + destruct (Level.eq_dec l l'); subst; eexists; eauto. + Qed. + + Definition premises_model_map (m : model) cls : model := let levels := clauses_premises_levels cls in LevelSet.fold (fun l acc => @@ -201,42 +248,6 @@ Module Models (LS : LevelSets). constructor. destruct l; reflexivity. Qed. - (* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by - setting a minimal value for the new atoms in [clauses_levels cls \ V] - such that the new clauses [cls] do not hold vacuously. - *) - - Equations add_max (l : Level.t) (k : option Z) (m : model) : model := - add_max l k m with level_value m l := - { | Some k' with check_atom_value k (Some k') := - { | true => m - | false => LevelMap.add l k m } - | None => LevelMap.add l k m }. - - Lemma add_max_spec l l' k k' (m : model) : - LevelMap.MapsTo l k (add_max l' k' m) <-> - (l = l' /\ k = max_opt_of Z.max k' (level_value m l)) \/ - (l <> l' /\ LevelMap.MapsTo l k m). - Proof. - funelim (add_max l' k' m). - - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. firstorder; subst. - left. split => //. rewrite Heq. now rewrite max_opt_of_l. - left. firstorder. now rewrite Heq max_opt_of_l. - - clear Heqcall. - destruct (Level.eq_dec l0 l). - * subst l0. rewrite Heq0. - move/check_atom_value_spec: Heq. - rewrite (maps_to_update (level_value_MapsTo' Heq0)). - firstorder; subst; try left; try split; auto; depelim Heq; cbn; lia_f_equal. - * firstorder. - - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. - have := check_atom_value_spec k (Some k'). rewrite {}Heq. - intros h; depelim h. apply nleq_optZ in H as [z [-> hlt]]. - firstorder; subst. - * left; split => //. rewrite Heq0 //=. lia_f_equal. - * left; split => //. rewrite Heq0 //=. lia_f_equal. - Qed. - Definition min_model_clause cl m := LevelExprSet.fold (fun '(l, k) acc => add_max l (Some k) acc) (premise cl) (add_max (concl cl).1 None m). @@ -244,15 +255,6 @@ Module Models (LS : LevelSets). Definition min_model_map (m : model) cls : model := Clauses.fold min_model_clause cls m. - Lemma In_add_max l l' k acc : - LevelMap.In l (add_max l' k acc) <-> (l = l' \/ LevelMap.In l acc). - Proof. - rewrite /LevelMap.In. - rw add_max_spec. firstorder subst. - eexists; left; eauto. - destruct (Level.eq_dec l l'); subst; eexists; eauto. - Qed. - Definition max_of_premises l kl n := (forall kl', LevelExprSet.In (l, kl') n -> Some kl' ≤ kl). @@ -561,4 +563,27 @@ Module Models (LS : LevelSets). * rewrite (om l). now exists x. Qed. + Lemma min_model_map_enabled m cls cls' : + enabled_clauses m cls -> + enabled_clauses (min_model_map m cls') (Clauses.union cls cls'). + Proof. + intros en cl. + rewrite Clauses.union_spec => -[]. + - move/en; rewrite /enabled_clause => -[z hmin]. + have := @min_premise_pres m (min_model_map m cls') (premise cl) => /fwd. + apply min_model_map_acc. + rewrite hmin => h; depelim h. now exists y. + - intros hin; rewrite /enabled_clause. + have [hm [incl hext]] := min_model_map_spec cls' m. + have [hle [minp [inp ->]]] := min_premise_spec (min_model_map m cls') (premise cl). + move: (incl _ hin). move/(_ minp.1) => /fwd. + { apply clause_levels_spec. left. now apply in_levels. } + move=> [k hmap]. + specialize (hm minp.1 k hmap) as [_ hm _]. + destruct minp. + move: hm => /(_ _ hin)/(_ _ inp). intros le; depelim le. + exists (y - z). now rewrite /min_atom_value (level_value_MapsTo hmap). + Qed. + + End Models. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index f5acb9f12..812ab4ffe 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -186,6 +186,8 @@ Module UnivLoopChecking. Import LoopCheck.Impl.Abstract. Import LoopCheck.Impl.CorrectModel (clauses_sem, clause_sem, clauses_sem_union). Import LoopCheck.Impl.I. + Import Universes (valuation). + Import LoopCheck. Definition to_atom '(l, k) : LevelExpr.t := (l, Z.of_nat k). @@ -502,7 +504,7 @@ End ZUnivConstraint. Qed. Lemma levels_in_to_atoms l u : - LevelSet.In l (levels (to_atoms u)) <-> Universes.LevelSet.In l (Universe.levels u). + LevelSet.In l (NES.levels (to_atoms u)) <-> Universes.LevelSet.In l (Universe.levels u). Proof. rewrite levels_spec. rewrite /in_to_atoms. @@ -915,21 +917,28 @@ End ZUnivConstraint. - clear H Heqcall. reflexivity. Qed. - Definition valuation_to_Z (v : Universes.valuation) : Level.t -> option Z := - fun l => Some (Z.of_nat (val v l)). + Definition valuation_to_Z (v : Universes.valuation) : Level.t -> Z := + fun l => Z.of_nat (val v l). + + Import LoopCheck.Impl.CorrectModel (Zopt_semi, positive_valuation). + + Lemma positive_valuation_to_Z v : + positive_valuation (valuation_to_Z v). + Proof. + unfold positive_valuation, valuation_to_Z. intros; lia. + Qed. - Import LoopCheck.Impl.CorrectModel (Zopt_semi). Existing Instance Zopt_semi. Lemma interp_nes_valuation_to_Z_to_atoms v u : - interp_nes (valuation_to_Z v) (to_atoms u) = Some (Z.of_nat (Universes.val v u)). + interp_nes (valuation_to_Z v) (to_atoms u) = Z.of_nat (Universes.val v u). Proof. move: u. apply: Universe.elim. - intros [l k]; rewrite to_atoms_singleton interp_nes_singleton //= val_singleton //=. - cbn; lia_f_equal. + rewrite /valuation_to_Z; cbn; lia_f_equal. - intros [l k] x hx hnin. - rewrite to_atoms_add !interp_nes_add_opt_Z //= val_add //= hx; cbn. + rewrite to_atoms_add /valuation_to_Z !interp_nes_add_Z //= val_add //= hx; cbn. lia_f_equal. Qed. @@ -974,7 +983,7 @@ End ZUnivConstraint. apply clauses_sem_satisfies0_equiv in sat. red in sat. now move/sat. Qed. - +(* Lemma interp_nes_valuation_to_Z v u : interp_nes (valuation_to_Z v) u <> None. Proof. @@ -984,7 +993,7 @@ End ZUnivConstraint. - intros [l k] x hx hnin. rewrite !interp_nes_add_opt_Z //=. destruct interp_nes => //. - Qed. + Qed. *) Lemma enforce_inconsistent m (c : UnivConstraint.t) u : UnivLoopChecking.enforce m c = Some (inr u) -> ~ exists v, satisfies v (UnivConstraintSet.add c (constraints m)). @@ -992,17 +1001,16 @@ End ZUnivConstraint. funelim (UnivLoopChecking.enforce m c) => //=. move=> [=]; intros <-; cbn. clear H Heqcall. intros [v sat]. - have he := LoopCheck.enforce_inconsistent eq0 (option Z) Zopt_semi (valuation_to_Z v). - rewrite clauses_sem_union clauses_sem_satisfies0_equiv in he. + have he := LoopCheck.enforce_inconsistent eq0. + specialize (he (valuation_to_Z v)). + forward he. apply positive_valuation_to_Z. + rewrite clauses_sem_satisfies0_equiv in he. rewrite UnivConstraintSetProp.add_union_singleton satisfies_union in sat. destruct sat as [satc satcs]. specialize (satc c). forward satc; try ucsets. forward he. - { split => //. now apply satisfies_clauses_sem_to_Z. } - destruct loop0 as [u hu]. cbn in he. - apply clauses_sem_eq in he. rewrite interp_add_prems in he. cbn -[Z.add] in he. - have hid := interp_nes_valuation_to_Z v u. - destruct interp_nes => //. cbn -[Z.add] in he. lia. + { now apply satisfies_clauses_sem_to_Z. } + destruct loop0 as [u incl hu]. cbn in he. contradiction. Qed. Definition enforce_constraints_aux (g : option univ_model) (cstrs : UnivConstraintSet.t) : option univ_model := @@ -1027,7 +1035,7 @@ End ZUnivConstraint. | None => (m = None) \/ (exists minit, m = Some minit /\ (~ (declared_univ_cstrs_levels (levels minit) cstrs) \/ - ~ (exists v : valuation, satisfies v (UnivConstraintSet.union cstrs (constraints minit))))) + ~ (exists v : Universes.valuation, satisfies v (UnivConstraintSet.union cstrs (constraints minit))))) | Some m' => exists init, m = Some init /\ levels m' = levels init /\ constraints m' =_ucset UnivConstraintSet.union cstrs (constraints init) end. Proof. @@ -1084,7 +1092,7 @@ End ZUnivConstraint. Lemma enforce_constraints_None {m cstrs} : enforce_constraints m cstrs = None -> ~ (declared_univ_cstrs_levels (levels m) cstrs) \/ - ~ (exists v : valuation, satisfies v (UnivConstraintSet.union cstrs (constraints m))). + ~ (exists v : Universes.valuation, satisfies v (UnivConstraintSet.union cstrs (constraints m))). Proof. have := (enforce_constraints_aux_spec (Some m) cstrs). rewrite /enforce_constraints. destruct enforce_constraints_aux. @@ -1152,7 +1160,6 @@ End ZUnivConstraint. | exist None eqc => False_rect _ _ } ; | exist None eqdecl := None }. Proof. - Import LoopCheck.Impl.Abstract LoopCheck. (* - move/LoopCheck.declare_level_levels: eq0 => -[] hnin. move/LoopCheck.enforce_levels: e => eq. rewrite eq. intros ->. have := declared_zero m. lsets. @@ -1199,7 +1206,7 @@ End ZUnivConstraint. Proof. funelim (declare_level m l) => //. - move=> [=] <-. cbn. - clear H H0 Heqcall. + clear H H0 Heqcall. cbn. unfold levels. cbn. move/LoopCheck.declare_level_levels: eq0 => -[] nin eql. split => //. exists c. split => //. - bang. @@ -1345,12 +1352,7 @@ End ZUnivConstraint. let add_val l := LevelMap.add l (val v l) in LevelSet.fold add_val V (LevelMap.empty _). - - - Import LoopCheck (valuation). - Import LoopCheck.Impl.CorrectModel (clauses_sem, clause_sem). - (* Import LoopCheck.Impl.Abstract. *) - + Import LoopCheck.Impl.CorrectModel (to_Z_val, clauses_sem, clause_sem). Definition wf_valuation V v := forall l, LevelSet.In l V -> @@ -1426,8 +1428,8 @@ End ZUnivConstraint. Lemma declared_clauses_levels {m} {l r : Universe.t} {d} : LoopCheck.to_clauses (to_constraint (l, d, r)) ⊂_clset Impl.Abstract.clauses m -> - Universe.levels l ⊂_lset (levels m) /\ - Universe.levels r ⊂_lset (levels m). + Universe.levels l ⊂_lset (Impl.Abstract.levels m) /\ + Universe.levels r ⊂_lset (Impl.Abstract.levels m). Proof. intros; split. 1-2:etransitivity; [|apply clauses_levels_declared]. @@ -1435,7 +1437,7 @@ End ZUnivConstraint. 1-2:intros l';rewrite in_to_clauses_levels in_constraint_levels_to_constraint //=; lsets. Qed. - Lemma wf_model_valuation m : wf_valuation (levels m) (valuation m). + Lemma wf_model_valuation (m : t) : wf_valuation (Impl.Abstract.levels m) (LoopCheck.valuation m). Proof. red. intros []; cbn. - intros hz. rewrite eqb_refl. @@ -1445,21 +1447,21 @@ End ZUnivConstraint. Qed. Lemma model_satisfies (m : univ_model) : - satisfies (to_valuation (LoopCheck.valuation m)) (constraints m). + satisfies (to_valuation (valuation m)) (constraints m). Proof. destruct m as [m cstrs repr repr_inv]. cbn. - have val := LoopCheck.model_valuation m. + have val := model_valuation m. move=> cstr /repr /[dup]/(clauses_sem_subset val) cls incl. destruct cstr as [[l []] r]; cbn. - constructor. cbn in cls. eapply declared_clauses_levels in incl as []. eapply clauses_sem_val_in_clauses; tea. - apply wf_model_valuation. + apply (wf_model_valuation m). - constructor. cbn in cls. rewrite clauses_sem_union in cls. destruct cls as [hl hr]. eapply declared_clauses_levels in incl as []. eapply Nat.le_antisymm; eapply clauses_sem_val_in_clauses; tea. - all:apply wf_model_valuation. + all:apply (wf_model_valuation m). Qed. Lemma of_valuation_spec V v : @@ -1686,9 +1688,9 @@ End ZUnivConstraint. Import Semilattice. Import ISL. - Definition model_val (m : univ_model) := (LoopCheck.valuation m). + Definition model_val (m : univ_model) := valuation m. - Definition model_opt_val (m : univ_model) := (LoopCheck.opt_valuation m). + Definition model_opt_val (m : univ_model) := (LoopCheck.Impl.Abstract.opt_valuation m.(model)). Definition model_Z_val (m : univ_model) := (to_Z_val (LoopCheck.valuation m)). @@ -1701,11 +1703,11 @@ End ZUnivConstraint. have hrepr := repr_constraints m _ hin. destruct cstr as [[l' []] r']; cbn in heq; noconf heq. - rewrite /interp_rel interp_nes_union. cbn in hrepr. - eapply UnivLoopChecking.clauses_sem_subset in hv; tea. + eapply clauses_sem_subset in hv; tea. apply clauses_sem_clauses_of_le in hv. cbn in hv |- *. unfold model_Z_val in *. lia. - cbn in hrepr. - eapply UnivLoopChecking.clauses_sem_subset in hv; tea. + eapply clauses_sem_subset in hv; tea. rewrite /Clauses.clauses_of_eq in hv. eapply clauses_sem_union in hv. destruct hv as [hv hv']. apply clauses_sem_clauses_of_le in hv. @@ -1802,7 +1804,7 @@ End ZUnivConstraint. Import Impl.CorrectModel (positive_valuation, positive_opt_valuation, opt_valuation_of_model_pos). Definition valid_Z_model m c := - (forall (v : Level.t -> option Z), positive_opt_valuation v -> interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + (forall (v : Level.t -> Z), positive_valuation v -> interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). Infix "⊩Z" := valid_Z_model (at level 70, no associativity). @@ -1812,28 +1814,13 @@ End ZUnivConstraint. Definition valid_nat_model m c := (forall (v : Level.t -> option nat), defined_valuation_of (UnivLoopChecking.levels m ∪ univ_constraint_levels c) v -> interp_cstrs v (constraints m) -> interp_nat_cstr v c). -(* - Lemma valid_Z_pos_nat_model m c : valid_Z_model m c <-> valid_nat_model m c. - Proof. - split. - - intros vz v ic. - specialize (vz (fun l => option_map Z.of_nat (v l))). - forward vz. { red. intros. destruct (v l); noconf H. lia. } - Search interp_univ_cstr. - rewrite interp_cstrs_clauses_sem in vz. - rewrite interp_cstr_clauses_sem in vz. - have df := def_clauses_sem_valid. - rewrite -interp_univ_cstr_nat. - Search interp_nat_cstr. - Qed. *) - Theorem check_completeness {m c} : check m c <-> m ⊩Z c. Proof. rewrite LoopCheck.check_Z_complete_positive /valid_Z_model. setoid_rewrite interp_cstrs_clauses_sem; setoid_rewrite interp_cstr_clauses_sem. - now rewrite /valid_clauses. + rewrite /valid_clauses. todo "update". Qed. Lemma interp_univ_cstrs_of_m m : @@ -1846,9 +1833,10 @@ End ZUnivConstraint. (** The current model must already imply the constraint. Note that the converse is not true: a constraint can be satisfied by chance in the model. *) Theorem check_implies {m c} : - check m c -> interp_univ_cstr (opt_valuation m) c. + check m c -> interp_univ_cstr (to_Z_val (valuation m)) c. Proof. - now rewrite check_completeness => /(_ (opt_valuation m) (opt_valuation_of_model_pos) (interp_univ_cstrs_of_m m)). + todo "update". + (* now rewrite check_completeness => /(_ (to_Z_val (opt_valuation m) (opt_valuation_of_model_pos) (interp_univ_cstrs_of_m m)). *) Qed. Definition valid_model m c := @@ -1895,7 +1883,7 @@ End ZUnivConstraint. Proof. etransitivity; [|eapply clauses_levels_declared]. intros l; rewrite univ_constraints_levels_spec => -[] c [] hin. - revert l. change (univ_constraint_levels c ⊂_lset (clauses_levels (clauses m))). + revert l. change (univ_constraint_levels c ⊂_lset (clauses_levels (LoopCheck.clauses m))). etransitivity; [|eapply declared_univ_cstr_levels_spec]. reflexivity. move/repr_constraints: hin => hincl. apply ndecl_nin_levels. now apply clauses_levels_mon. diff --git a/utils/theories/MRInstances.v b/utils/theories/MRInstances.v index 676b90790..734045b51 100644 --- a/utils/theories/MRInstances.v +++ b/utils/theories/MRInstances.v @@ -56,10 +56,16 @@ Section ZSemiLattice. intros x; unfold one, Zadd_is_comm_monoid. lia. Qed. + #[export] Instance con_Z : @Consistent Z _ _ Zsemilattice. + Proof. + intros u; cbn -[Z.add]. lia. + Qed. + End ZSemiLattice. #[export] Existing Instance Zsemilattice. + Section NatSemiLattice. Import Semilattice. @@ -68,6 +74,11 @@ Section NatSemiLattice. join := Nat.max; |}. Solve Obligations with program_simpl; try lia. + #[export] Instance con_nat : @Consistent _ _ _ Natsemilattice. + Proof. + intros u; cbn. lia. + Qed. + End NatSemiLattice. #[export] Existing Instance Natsemilattice. diff --git a/utils/theories/SemiLattice.v b/utils/theories/SemiLattice.v index d2348b689..4a685c9e2 100644 --- a/utils/theories/SemiLattice.v +++ b/utils/theories/SemiLattice.v @@ -31,7 +31,7 @@ Module Semilattice. join_idem x : join x x ≡ x; join_sub x : join x (add 1 x) ≡ add 1 x; add_inj : forall n x y, add n x ≡ add n y -> x ≡ y; - add_join : forall n x y, add n (join x y) ≡ join (add n x) (add n y); + add_join : forall n x y, add n (join x y) ≡ join (add n x) (add n y) }. Notation "x ≡ y" := (eq x y) (at level 70) : sl_scope. @@ -44,8 +44,14 @@ Module Semilattice. Definition lt {A} `{SL : Semilattice A} (x y : A) := add 1 x ≤ y. Infix "<" := lt (at level 70) : sl_scope. - Class JoinDec (carrier : Type) `{SL : Semilattice carrier} := - { join_dec (x y : carrier) : (join x y ≡ x) \/ (join y x ≡ y) }. + Class EqDec (carrier : Type) `{SL : Semilattice carrier} := + eq_dec (x y : carrier) : (x ≡ y) \/ (~ x ≡ y). + + Class Consistent (carrier : Type) `{SL : Semilattice carrier} := + incon : forall u : carrier, ~ u ≡ add 1 u. + + Class Total (S : Type) `{SL : Semilattice S} := + total : forall x y : S, x ≤ y \/ y < x. Local Open Scope sl_scope. Section Derived. @@ -153,17 +159,27 @@ Module Semilattice. now rewrite (join_comm t) -join_assoc le. Qed. - Lemma join_dec_spec {JD : @JoinDec A incr CM SL} (x y : A) : - (x ≤ y /\ join x y ≡ y) \/ (y ≤ x /\ join x y ≡ x). + Lemma le_dec {JD : @EqDec A incr CM SL} (x y : A) : + (x ≤ y) \/ ~ (x ≤ y). Proof. - destruct (join_dec x y). - - right. split => //. - red. now rewrite join_comm H. - - left. split => //. red. - rewrite join_comm H. reflexivity. - rewrite join_comm H. reflexivity. + destruct (eq_dec (join x y) y). + - now left. + - right. intros hle. red in hle. contradiction. Qed. + (* Lemma le_inv {JD : @EqDec A incr CM SL} {ST : @Total A incr CM SL} (x y : A) : + (x ≤ y) \/ (y < x). + Proof. + destruct (le_dec x y). + - now left. + - right. + destruct (total x (add 1 y)). contradiction. + + red. + assert (hi := (incon y)). + unfold le in *. intros hle. red in hle. contradiction. + Qed. *) + Lemma le_add {n} {x y : A} : x ≤ y <-> add n x ≤ add n y. Proof. unfold le. @@ -299,7 +315,8 @@ Section OptSemilattice. Defined. Existing Instance opt_semi. - (* None is greater than any element in this semilattice *) + (* None is greater than any element in this semilattice. + This models implications *) Lemma le_spec {x y : option S} : x ≤ y <-> (y = None) \/ (exists x' y', x = Some x' /\ y = Some y' /\ le x' y'). Proof. From 3861cea6f16ea9cf8c205daf3162564e4ce3e67e Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 6 Oct 2025 00:58:32 +0200 Subject: [PATCH 092/164] Finally proven the theorem for validity in Z, so with arbitrary shifts and injectivity! --- common/theories/LoopChecking/Deciders.v | 501 ++++++++++-------- .../LoopChecking/HornSemilatticeEquiv.v | 41 +- 2 files changed, 323 insertions(+), 219 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index d9402cb1b..7a7aa6448 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -473,35 +473,24 @@ Definition checking_clause (cl : clause) := Definition check_clause cls cl := check_gen cls (checking_clause cl). -(* -Lemma check_clause_valid_Z : valid_relations *) - Definition valid_clause_Z cls cl := forall v : Level.t -> Z, positive_valuation v -> clauses_sem v cls -> clause_sem v cl. - - -Definition checkb cls cl := - match check_clause cls cl with - | IsLooping _ _ _ => false - | Valid => true - | Invalid => false - end. - -Definition check_clauses (cls : clauses) (cls' : clauses) : bool := - Clauses.for_all (checkb cls) cls'. - -Definition pred (le : LevelExpr.t) := (le.1, le.2 - 1). - -(* Theorem check_entails_all {cls prems concl} : - check cls (prems, concl) = Valid -> - entails cls (union prems (singleton (pred concl)), concl). +Lemma check_clause_valid_Z cls cl : + check_clause cls cl = Valid -> valid_clause_Z cls cl. Proof. -Admitted. *) - + unfold check_clause. + move/check_gen_entails. + move=> ent v posv csem. + apply entails_completeness in ent. + move: {ent}(ent Z _ v csem). + destruct cl as [prems [concl k]]. + rewrite //= !interp_nes_union interp_nes_singleton //= /interp_expr //=. + lia. +Qed. Import Semilattice. Import ISL. @@ -1555,9 +1544,6 @@ Lemma opt_valuation_of_model_equiv m l : Definition inconsistent cls := ~ (consistent cls). - Definition check_clauses m cls := - check_clauses (clauses m) cls. - Lemma model_entails_loop m v : clauses m ⊢a v → succ v -> False. Proof. @@ -1567,24 +1553,6 @@ Lemma opt_valuation_of_model_equiv m l : now eapply (is_update_of_ext m.(correct_model).(model_valid).(I.model_updates)). Qed. - Lemma check_clauses_spec m cls : - check_clauses m cls <-> entails_clauses (clauses m) cls. - Proof. - split. - - rewrite /check_clauses /Deciders.check_clauses. - move/Clauses.for_all_spec => ha cl /ha. unfold checkb. - destruct check_clause eqn:ch => // _. - eapply check_gen_entails in ch. now apply ch. - - intros hv. - rewrite /check_clauses /Deciders.check_clauses. - eapply Clauses.for_all_spec; tc => cl hin. - unfold checkb; destruct check eqn:hc => //. - * exfalso; eapply check_entails_looping in hc; tea. - now apply model_entails_succ in hc. - * move/check_invalid_entails: hc => he. - exfalso. elim he. now apply hv. - Qed. - Lemma enforce_clauses_inconsistent_semilattice {m cls u} : enforce_clauses m cls = Some (inr u) -> forall S (SL : Semilattice.Semilattice S Q.t) (V : Level.t -> S), @@ -1637,13 +1605,13 @@ Lemma opt_valuation_of_model_equiv m l : Lemma interp_expr_defined {model} le : defined_model_of (LevelSet.singleton le.1) model -> - interp_expr (opt_valuation_of_model model) le = Some (interp_expr (valuation_of_model model) le). + interp_expr (opt_valuation_of_model model) le = Some (interp_expr (Z_valuation_of_model model) le). Proof. destruct le as [l k]; cbn. move => /(_ l) => /fwd. lsets. move=> [v hm]. have := (@opt_valuation_of_model_pos model l). - rewrite /opt_valuation_of_model /valuation_of_model /to_val /to_Z_val. + rewrite /opt_valuation_of_model /Z_valuation_of_model /to_val /to_Z_val. rewrite (LevelMap.find_1 hm). cbn. eapply Model.valuation_of_model_spec in hm. rewrite (LevelMap.find_1 hm). cbn. @@ -1652,6 +1620,15 @@ Lemma opt_valuation_of_model_equiv m l : f_equal. lia. Qed. + Lemma interp_expr_defined_val (v : Level.t -> option Z) le : + defined_valuation_of (LevelSet.singleton le.1) v -> + exists k, interp_expr v le = Some k. + Proof. + destruct le as [l k]; cbn. + move => /(_ l) => /fwd. lsets. + move=> [x hm]. rewrite hm. now eexists. + Qed. + Lemma R_optP (x y : option Z) : reflectProp (R_opt eq x y) (eqb x y). Proof. destruct (eqb_spec x y); constructor. @@ -1666,9 +1643,30 @@ Lemma opt_valuation_of_model_equiv m l : move/R_optP: ha. move/(eqb_eq _ _). auto. Qed. + + Lemma interp_nes_defined_val v (u : NES.t) : + defined_valuation_of (NES.levels u) v -> + exists u', interp_nes v u = Some u'. + Proof. + move: u. + apply: elim. + - intros [l k] => //= hin. + rewrite !interp_nes_singleton. + rewrite levels_singleton in hin. + now apply interp_expr_defined_val. + - move=> le x eq wf def. + forward eq. move: def. rewrite /defined_model_of. + move=> h l hin. apply h. rewrite levels_add. lsets. + rewrite interp_nes_add_opt_Z. + destruct eq as [? ->]. + have := @interp_expr_defined_val v le => /fwd. + { intros l; move: (def l) => h hin; apply h. rewrite levels_add. rsets. now left. } + intros [k ->]. now eexists. + Qed. + Lemma interp_nes_defined {m} (u : NES.t) : defined_model_of (NES.levels u) m -> - interp_nes (opt_valuation_of_model m) u = Some (interp_nes (valuation_of_model m) u). + interp_nes (opt_valuation_of_model m) u = Some (interp_nes (Z_valuation_of_model m) u). Proof. move: u. apply: elim. @@ -1733,22 +1731,6 @@ Lemma opt_valuation_of_model_equiv m l : Definition valid_entailments cls cls' := forall S (SL : Semilattice S Q.t) (V : Level.t -> S), clauses_sem V cls -> clauses_sem V cls'. - Lemma check_clauses_complete m cls : - check_clauses m cls <-> valid_entailments (clauses m) cls. - Proof. - rewrite check_clauses_spec. - rewrite -entails_L_entails_ℋ_equiv. - rewrite -entails_L_rels_entails_L_clauses. - rewrite -completeness_all. - split. - - move=> vr s sl v. - move: (vr _ sl v). - rewrite !interp_rels_clauses_sem //. - - intros ve S s v. - move: (ve S s v). - now rewrite //= !interp_rels_clauses_sem. - Qed. - Definition valid_semilattice_entailment {S} (SL : Semilattice S Q.t) cls cl := (forall (v : Level.t -> S), clauses_sem v cls -> clause_sem v cl). @@ -1768,7 +1750,7 @@ Lemma opt_valuation_of_model_equiv m l : Lemma clause_sem_defined_valid_all {model cl} : defined_model_of (clause_levels cl) model -> - clause_sem (valuation_of_model model) cl <-> clause_sem (opt_valuation_of_model model) cl. + clause_sem (Z_valuation_of_model model) cl <-> clause_sem (opt_valuation_of_model model) cl. Proof. intros def. destruct cl as [prems [concl k]]. @@ -1781,7 +1763,7 @@ Lemma opt_valuation_of_model_equiv m l : Lemma clauses_sem_def_equiv {model cls} : defined_model_of (clauses_levels cls) model -> - clauses_sem (valuation_of_model model) cls <-> clauses_sem (opt_valuation_of_model model) cls. + clauses_sem (Z_valuation_of_model model) cls <-> clauses_sem (opt_valuation_of_model model) cls. Proof. intros def. rewrite /clauses_sem. red in def. @@ -1846,7 +1828,7 @@ Lemma opt_valuation_of_model_equiv m l : Lemma def_clause_sem_valid {model cl} : defined_model_of (clause_levels cl) model -> - clause_sem (valuation_of_model model) cl <-> valid_clause model cl. + clause_sem (Z_valuation_of_model model) cl <-> valid_clause model cl. Proof. intros def. split. @@ -1856,97 +1838,35 @@ Lemma opt_valuation_of_model_equiv m l : Lemma def_clauses_sem_valid {model cls} : defined_model_of (clauses_levels cls) model -> - clauses_sem (valuation_of_model model) cls <-> is_model cls model. + clauses_sem (Z_valuation_of_model model) cls <-> is_model cls model. Proof. intros def. rewrite clauses_sem_def_equiv //. apply clauses_sem_valid. Qed. + Definition clause_premises_levels cl := NES.levels (premise cl). + Theorem check_invalid_valuation {cls cl} : - check cls cl = Invalid -> + check_gen cls cl = Invalid -> exists v : Level.t -> option Z, [/\ positive_opt_valuation v, clauses_sem v cls, - defined_valuation_of (clause_levels cl) v & ~ clause_sem v cl]. + defined_valuation_of (clause_premises_levels cl) v & ~ clause_sem v cl]. Proof. - move/check_invalid=> [m' [ism en inval]].xfMNo + move/check_invalid=> [m' [ism en inval]]. have hpos := opt_valuation_of_model_pos. have semcls := valid_clauses_model_opt _ _ ism. exists (opt_valuation_of_model m'). split => //. { intros l. - Search valid_clause. - have ve := valid_clause_elim. - todo "valuation of conclusion". } + move: en; rewrite /enabled_clause => -[z hmin]. + eapply min_premise_spec_aux in hmin as [hf _]. + rewrite /clause_premises_levels NES.levels_spec. + move=> [] k /hf. intros le; depelim le. move: H0. + rewrite /opt_valuation_of_model /level_value. + case: (find_spec l m') => //; destruct k0 => //. + move=> hmf [= eq]. subst y. now eexists. } { move/clause_sem_valid. contradiction. } Qed. - Definition valid_clauses cls cls' := - forall v : Level.t -> option Z, - positive_opt_valuation v -> - clauses_sem v cls -> clauses_sem v cls'. - - Lemma check_clauses_Z_positive_complete m cls : - check_clauses m cls <-> valid_clauses (clauses m) cls. - Proof. - split. - - rewrite check_clauses_spec. - rewrite -entails_L_entails_ℋ_equiv. - rewrite -entails_L_rels_entails_L_clauses. - rewrite -completeness_all. - move=> vr v. - red in vr. - move: (vr (option Z) Zopt_semi v). - rewrite !interp_rels_clauses_sem //. - - intros sem. unfold check_clauses, Deciders.check_clauses. - eapply Clauses.for_all_spec. tc. - move=> cl /sem => semcl. - unfold checkb; destruct check eqn:hc => //. - * move/check_entails_looping : hc. - rewrite -to_entails_all. - rewrite -entails_L_entails_ℋ_equiv. - rewrite -entails_L_rels_entails_L_clauses. - rewrite -ISL.completeness_all. - move/(_ Z _ (valuation_of_model m)). - rewrite -interp_rels_clauses_sem. - move/(_ (model_valuation m)). - rewrite -interp_rels_clauses_sem. - rewrite clauses_sem_leq. cbn. - rewrite interp_add_prems //=. lia. - * move/check_invalid_valuation: hc. - move=> [v [hpos semcls def ncl]]. specialize (semcl v hpos semcls). - now elim ncl. - Qed. - - Lemma check_clauses_Z_complete m cls : - check_clauses m cls <-> valid_semilattice_entailments Zopt_semi (clauses m) cls. - Proof. - split. - - rewrite check_clauses_spec. - rewrite -entails_L_entails_ℋ_equiv. - rewrite -entails_L_rels_entails_L_clauses. - rewrite -completeness_all. - move=> vr v. - red in vr. - move: (vr (option Z) Zopt_semi v). - rewrite !interp_rels_clauses_sem //. - - intros sem. unfold check_clauses, Deciders.check_clauses. - eapply Clauses.for_all_spec. tc. - move=> cl /sem => semcl. - unfold checkb; destruct check eqn:hc => //. - * move/check_entails_looping : hc. - rewrite -to_entails_all. - rewrite -entails_L_entails_ℋ_equiv. - rewrite -entails_L_rels_entails_L_clauses. - rewrite -ISL.completeness_all. - move/(_ Z _ (valuation_of_model m)). - rewrite -interp_rels_clauses_sem. - move/(_ (model_valuation m)). - rewrite -interp_rels_clauses_sem. - rewrite clauses_sem_leq. cbn. - rewrite interp_add_prems //=. lia. - * move/check_invalid_valuation: hc. - move=> [v [_ semcls def ncl]]. specialize (semcl v). elim ncl; now apply semcl. - Qed. - Definition opt_val_of_Z_val (v : Level.t -> Z) : Level.t -> option Z := fun l => Some (v l). Definition Z_val_of_opt_val (v : Level.t -> option Z) : Level.t -> Z := fun l => option_get 0 (v l). @@ -2026,9 +1946,9 @@ Lemma opt_valuation_of_model_equiv m l : Lemma entails_dec (m : t) cl : { entails (clauses m) cl } + { ~ entails (clauses m) cl /\ exists v : Level.t -> option Z, - [/\ positive_opt_valuation v, clauses_sem v (clauses m), defined_valuation_of (clause_levels cl) v & ~ clause_sem v cl] }. + [/\ positive_opt_valuation v, clauses_sem v (clauses m), defined_valuation_of (clause_premises_levels cl) v & ~ clause_sem v cl] }. Proof. - destruct (check (clauses m) cl) eqn:ch. + destruct (check_gen (clauses m) cl) eqn:ch. - move/check_looping: ch; elim. exists (model_of m). split. { have dm := defined_model m. @@ -2038,7 +1958,7 @@ Lemma opt_valuation_of_model_equiv m l : exact: is_model_of m. - have ci := check_invalid_valuation ch. move/check_invalid_entails: ch. intros ne. right. split => //. - - move/check_entails: ch. now left. + - move/check_gen_entails: ch. now left. Qed. Definition valid_clause_opt cls cl := @@ -2054,43 +1974,6 @@ Lemma opt_valuation_of_model_equiv m l : Definition model_of_valuation V v := LevelSet.fold (fun l => LevelMap.add l (option_map (value_of_valuation V v) (v l))) V (LevelMap.empty _). - Lemma entails_L_completeness {p l r} : - (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v p -> interp_nes v l ≡ interp_nes v r)%sl -> - p ⊢ℒ l ≡ r. - Proof. - intros hv. - specialize (hv _ (init_model p) (ids p)). - forward hv. - { apply interp_rels_init. } - rewrite !interp_triv in hv. - exact hv. - Qed. - - Lemma entails_completeness {cls cl} : - (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), clauses_sem v cls -> clause_sem v cl)%sl <-> - entails cls cl. - Proof. - split. - - intros hv. - eapply entails_L_entails_ℋ_equiv. - 2:{ now eapply Clauses.singleton_spec. } - intros c. rewrite Clauses.singleton_spec => ->. - red. eapply entails_L_completeness. - intros S SL v. specialize (hv S SL v). - rewrite -interp_rels_clauses_sem. move/hv. - destruct cl; cbn => //. - rewrite interp_nes_union interp_nes_singleton //. - - move/entails_entails_L. - move/entails_L_clause_clauses. - move/entails_L_rels_entails_L_clauses. - move/completeness_all. - unfold valid_relations. - setoid_rewrite interp_rels_clauses_sem. - setoid_rewrite interp_rel_clause_sem. - rewrite relations_of_clauses_singleton. - now setoid_rewrite interp_rels_tip. - Qed. - Lemma contraP P Q : (P -> Q) -> (~ Q -> ~ P). Proof. intros f hp q. apply (hp (f q)). Qed. @@ -2138,19 +2021,21 @@ Lemma opt_valuation_of_model_equiv m l : Qed. - Lemma neg_inverse {S} {SL : Semilattice S Q.t} {TSL : Total S} {TCon : Consistent S} (v : Level.t -> S) (cl : clause) : - ~ (clauses_sem v (inverse_clauses cl)) <-> clause_sem v cl. + Lemma neg_inverse (v : Level.t -> option Z) (cl : clause) : + defined_valuation_of (clause_levels cl) v -> + ~ clause_sem v cl <-> clauses_sem v (inverse_clauses cl). Proof. - destruct cl as [prems concl]. + destruct cl as [prems [concl k]]. cbn [clause_sem]. rewrite clauses_sem_leq. rewrite interp_add_prems interp_nes_singleton. cbn. - split; intros. - destruct (total (interp_expr v concl) (interp_nes v prems)) => //. - intros hadd. - assert (tr := transitivity hadd H). - apply (incon (interp_nes v prems)). - apply eq_antisym. split => //. - red. apply join_sub. + intros def. + have [l|vc hc] := interp_expr_defined_val v (concl, k). + { intros hin; apply def. cbn in *. rsets. apply clause_levels_spec. cbn. + now right. } + have [l|vp hp] := interp_nes_defined_val v prems. + { intros hin; apply def. cbn in *. rsets. apply clause_levels_spec. cbn. + now left. } + cbn in hc. rewrite hc hp //=. lia. Qed. Definition enforce_inverse m cl := @@ -2239,38 +2124,218 @@ Lemma opt_valuation_of_model_equiv m l : intros x; cbn. lia. Qed. + Lemma checking_clause_premise_levels cl : + clause_premises_levels (checking_clause cl) =_lset + clause_levels (checking_clause cl). + Proof. + destruct cl as [prems [concl k]]; rewrite /clause_premises_levels /checking_clause //=. + rewrite /clause_levels. cbn. unfold pred_expr; cbn. + intros l; firstorder. lsets. rsets. + rewrite NES.levels_spec. exists (k - 1). lsets. + Qed. - Lemma check m cl : - clause_levels cl ⊂_lset levels m -> - { valid_clause_Z (clauses m) cl } + { ~ valid_clause_Z (clauses m) cl }. + Lemma checking_clause_levels cl : + clause_levels (checking_clause cl) =_lset clause_levels cl. Proof. - intros hwf. - (* Check *) - destruct (entails_dec m cl). - - left. intros h hpov hsem. - rewrite -entails_completeness in e. - now apply e. - - right. destruct (enforce_dec m (inverse_clauses cl)) => //. - * setoid_rewrite <- hwf. - now rewrite clause_levels_inverse. - * intros vc. - destruct c as [tot [totpos csem]]. - apply clauses_sem_union in csem as [cls cinv]. - red in vc. move: (vc tot) => /fwd. exact: totpos. - move=>/(_ cls) => hcl. - now eapply clauses_sem_tot_inverse_false. - * intros _. - destruct a as [nent [v [hp semcs def semc]]]. - red in i. - rewrite -neg_inverse in semc. - apply Decidable.not_not in semc. - 2:{ apply clauses_sem_dec. } - specialize (i v). - rewrite clause_levels_inverse in i. - apply i => //. apply clauses_sem_union. - split => //. + destruct cl as [prems [concl k]]; rewrite /clause_premises_levels /checking_clause //=. + rewrite /clause_levels. cbn. unfold pred_expr; cbn. + intros l. rewrite LevelSet.union_spec NES.levels_spec. + setoid_rewrite LevelExprSet.union_spec; rewrite LevelSet.union_spec. + setoid_rewrite NES.levels_spec. firstorder rsets. noconf H. + now right. + Qed. + +Lemma check_clause_invalid_valid_Z m cl : + clause_levels cl ⊂_lset (levels m) -> + check_clause (clauses m) cl = Invalid -> ~ valid_clause_Z (clauses m) cl. +Proof. + move=> hwf. + unfold check_clause. + move/[dup]/check_invalid_entails => nent /check_invalid_valuation [v [posv csem def ncheck]]. + intros vcl. red in vcl. + destruct (enforce_dec m (inverse_clauses (checking_clause cl))) => //. + * setoid_rewrite <- hwf. + rewrite clause_levels_inverse. + now rewrite checking_clause_levels. + * destruct c as [tot [totpos csem']]. + apply clauses_sem_union in csem' as [cls cinv]. + move: (vcl tot) => /fwd. exact: totpos. + move=>/(_ cls) => hcl. + eapply clauses_sem_tot_inverse_false; tea. + destruct cl as [prems [concl k]]. + move: hcl; cbn -[Semilattice.le]. + rewrite interp_nes_union interp_nes_singleton /interp_expr. cbn -[Semilattice.le]. cbn; lia. + * clear vcl. apply (i v). + rewrite clause_levels_inverse. + now rewrite checking_clause_premise_levels in def. + apply clauses_sem_union. split => //. + rewrite neg_inverse in ncheck. + { now rewrite checking_clause_premise_levels in def. } + exact ncheck. +Qed. + +Lemma check_clause_looping m cl v vcls isl : + check_clause (clauses m) cl = IsLooping v vcls isl -> False. +Proof. + rewrite /check_clause. + intros. eapply check_valid_looping; tea. + apply m.(model_valid).(model_ok). + eapply defined_model_of_ext. eapply defined_model_of_subset. + 2:{ eapply defined_model. } + now intros ? ?; eapply clauses_levels_declared, vcls. + have hupd := m.(model_valid).(I.model_updates). + now eapply is_update_of_ext in hupd. +Qed. + +Definition check cls cl := + match check_clause cls cl with + | IsLooping _ _ _ => false + | Valid => true + | Invalid => false + end. + +Theorem check_spec m cl : + clause_levels cl ⊂_lset levels m -> + check (clauses m) cl <-> valid_clause_Z (clauses m) cl. +Proof. + unfold check. + destruct check_clause eqn:he; split => //. + - now move/check_clause_looping: he. + - now move/check_clause_invalid_valid_Z: he => /(_ H). + - now move/check_clause_valid_Z: he. +Qed. + +Lemma check_neg_spec m cl : + clause_levels cl ⊂_lset levels m -> + check (clauses m) cl = false <-> ~ valid_clause_Z (clauses m) cl. +Proof. + unfold check. + destruct check_clause eqn:he; split => //. + - now move/check_clause_looping: he. + - now move/check_clause_invalid_valid_Z: he => /(_ H). + - now move/check_clause_valid_Z: he. +Qed. + +Definition check_clauses (cls : clauses) (cls' : clauses) : bool := + Clauses.for_all (checkb cls) cls'. + + + Definition valid_clauses cls cls' := + forall v : Level.t -> option Z, + positive_opt_valuation v -> + clauses_sem v cls -> clauses_sem v cls'. + + + Definition check_clauses m cls := + check_clauses (clauses m) cls. + + + Lemma check_clauses_spec m cls : + check_clauses m cls <-> entails_clauses (clauses m) cls. + Proof. + split. + - rewrite /check_clauses /Deciders.check_clauses. + move/Clauses.for_all_spec => ha cl /ha. unfold checkb. + destruct check_clause eqn:ch => // _. + eapply check_gen_entails in ch. now apply ch. + - intros hv. + rewrite /check_clauses /Deciders.check_clauses. + eapply Clauses.for_all_spec; tc => cl hin. + unfold checkb; destruct check eqn:hc => //. + * exfalso; eapply check_entails_looping in hc; tea. + now apply model_entails_succ in hc. + * move/check_invalid_entails: hc => he. + exfalso. elim he. now apply hv. + Qed. + + Lemma check_clauses_complete m cls : + check_clauses m cls <-> valid_entailments (clauses m) cls. + Proof. + rewrite check_clauses_spec. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -completeness_all. + split. + - move=> vr s sl v. + move: (vr _ sl v). + rewrite !interp_rels_clauses_sem //. + - intros ve S s v. + move: (ve S s v). + now rewrite //= !interp_rels_clauses_sem. Qed. + Lemma check_clauses_Z_positive_complete m cls : + check_clauses m cls <-> valid_clauses (clauses m) cls. + Proof. + split. + - rewrite check_clauses_spec. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -completeness_all. + move=> vr v. + red in vr. + move: (vr (option Z) Zopt_semi v). + rewrite !interp_rels_clauses_sem //. + - intros sem. unfold check_clauses, Deciders.check_clauses. + eapply Clauses.for_all_spec. tc. + move=> cl /sem => semcl. + unfold checkb; destruct check eqn:hc => //. + * move/check_entails_looping : hc. + rewrite -to_entails_all. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -ISL.completeness_all. + move/(_ Z _ (valuation_of_model m)). + rewrite -interp_rels_clauses_sem. + move/(_ (model_valuation m)). + rewrite -interp_rels_clauses_sem. + rewrite clauses_sem_leq. cbn. + rewrite interp_add_prems //=. lia. + * move/check_invalid_valuation: hc. + move=> [v [hpos semcls def ncl]]. specialize (semcl v hpos semcls). + now elim ncl. + Qed. + + Lemma check_clauses_Z_complete m cls : + check_clauses m cls <-> valid_semilattice_entailments Zopt_semi (clauses m) cls. + Proof. + split. + - rewrite check_clauses_spec. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -completeness_all. + move=> vr v. + red in vr. + move: (vr (option Z) Zopt_semi v). + rewrite !interp_rels_clauses_sem //. + - intros sem. unfold check_clauses, Deciders.check_clauses. + eapply Clauses.for_all_spec. tc. + move=> cl /sem => semcl. + unfold checkb; destruct check eqn:hc => //. + * move/check_entails_looping : hc. + rewrite -to_entails_all. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -ISL.completeness_all. + move/(_ Z _ (valuation_of_model m)). + rewrite -interp_rels_clauses_sem. + move/(_ (model_valuation m)). + rewrite -interp_rels_clauses_sem. + rewrite clauses_sem_leq. cbn. + rewrite interp_add_prems //=. lia. + * move/check_invalid_valuation: hc. + move=> [v [_ semcls def ncl]]. specialize (semcl v). elim ncl; now apply semcl. + Qed. + +Definition pred (le : LevelExpr.t) := (le.1, le.2 - 1). + +(* Theorem check_entails_all {cls prems concl} : + check cls (prems, concl) = Valid -> + entails cls (union prems (singleton (pred concl)), concl). +Proof. +Admitted. *) + + Lemma nRopt {A} (x y : A) : ~ R_opt Logic.eq (Some x) (Some y) -> x <> y. Proof. intros hr heq. apply hr. now cbn. diff --git a/common/theories/LoopChecking/HornSemilatticeEquiv.v b/common/theories/LoopChecking/HornSemilatticeEquiv.v index db65aa384..4b46f027d 100644 --- a/common/theories/LoopChecking/HornSemilatticeEquiv.v +++ b/common/theories/LoopChecking/HornSemilatticeEquiv.v @@ -792,7 +792,7 @@ Section ClausesSemantics. Qed. Definition valid_semilattice_entailment cls cl := - (forall S (SL : Semilattice S Q.t) (CSL : Consistent S), + (forall S (SL : Semilattice S Q.t), forall (v : Level.t -> S), clauses_sem v cls -> clause_sem v cl). Lemma clauses_of_le_add le l r : @@ -863,4 +863,43 @@ Section ClausesSemantics. End ClausesSemantics. + + Import Semilattice. + + Lemma entails_L_completeness {p l r} : + (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v p -> interp_nes v l ≡ interp_nes v r)%sl -> + p ⊢ℒ l ≡ r. + Proof. + intros hv. + specialize (hv _ (init_model p) (ids p)). + forward hv. + { apply interp_rels_init. } + rewrite !interp_triv in hv. + exact hv. + Qed. + + Lemma entails_completeness {cls cl} : + entails cls cl <-> valid_semilattice_entailment cls cl. + Proof. + split; revgoals. + - intros hv. + eapply entails_L_entails_ℋ_equiv. + 2:{ now eapply Clauses.singleton_spec. } + intros c. rewrite Clauses.singleton_spec => ->. + red. eapply entails_L_completeness. + intros S SL v. specialize (hv S SL v). + rewrite -interp_rels_clauses_sem. move/hv. + destruct cl; cbn => //. + rewrite interp_nes_union interp_nes_singleton //. + - move/entails_entails_L. + move/entails_L_clause_clauses. + move/entails_L_rels_entails_L_clauses. + move/completeness_all. + unfold valid_relations, valid_semilattice_entailment. + setoid_rewrite interp_rels_clauses_sem. + setoid_rewrite interp_rel_clause_sem. + rewrite relations_of_clauses_singleton. + now setoid_rewrite interp_rels_tip. + Qed. + End HornSemilattice. From f22ac38afcda5e08d7b099d1059bc518b1e2eb4f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 7 Oct 2025 18:19:21 +0200 Subject: [PATCH 093/164] Almost there with minimal model hypothesis --- common/theories/LoopChecking/Deciders.v | 1186 +++++++++++++++++++---- 1 file changed, 1008 insertions(+), 178 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 7a7aa6448..77a6c9c38 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -452,6 +452,640 @@ Proof. lia. Qed. +Lemma valid_clause_satisfies m prems concl : valid_clause m (prems, concl) <-> + min_premise m prems = None \/ + (exists z, min_premise m prems = Some z /\ satisfiable_atom m (add_expr z concl)). +Proof. + destruct concl as [concl k]. + split. + - move/valid_clause_elim. intros hz. + destruct min_premise => //. right. specialize (hz _ eq_refl). depelim hz. + eexists; split; trea. unfold satisfiable_atom. cbn. rewrite H0. apply Z.leb_le. lia. + now left. + - intros disj; apply valid_clause_intro. + intros z hz. + destruct disj. congruence. destruct H as [z0 [hmin hsat]]. + rewrite hmin in hz; noconf hz. + cbn in hsat. destruct level_value => //. constructor. apply Z.leb_le in hsat. lia. +Qed. + +Definition inverse_clauses (cl : clause) := + let (prems, concl) := cl in + clauses_of_le (succ_prems prems) (singleton concl). + +Definition normalize m k := + option_map (fun k => k - model_min m) k. + +Definition lt_value (x y : option Z) := + match x, y with + | Some x, Some y => x < y + | None, Some _ => True + | Some _, None => False + | None, None => False + end. + +Definition is_ext m m' : bool := + LevelMapFact.for_all (fun l k => + match LevelMap.find l m' with + | None => false + | Some k' => check_atom_value k k' + end) m. + +(* Definition extends m m' := + (forall l k, LevelMap.MapsTo l k m -> exists k', LevelMap.MapsTo l k' m' /\ (k ≤ k')%opt). *) + +Lemma is_ext_spec m m' : is_ext m m' <-> m ⩽ m'. +Proof. + split. + - rewrite /is_ext. + rewrite [is_true _]LevelMapFact.for_all_iff => hf l k /hf. + case: (find_spec l m') => //. + move=> k0 hm /check_atom_value_spec hle. exists k0. split => //. + - intros ext. rewrite /is_ext. + rewrite [is_true _]LevelMapFact.for_all_iff => l e /ext. + intros [k' [hm hle]]. + rewrite (LevelMap.find_1 hm). + now apply/check_atom_value_spec. +Qed. + +Lemma dec_ext m m' : Decidable.decidable (m ⩽ m'). +Proof. + red. rewrite -is_ext_spec. now destruct is_ext. +Qed. + +Definition le_inter V m m' := + (forall l k k', LevelSet.In l V -> LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m' -> (k ≤ k')%opt). + +Definition le_values V m m' := + forall l, LevelSet.In l V -> (level_value m l ≤ level_value m' l)%opt. + +Infix "≦[ V ]" := (le_values V) (at level 70, format "x ≦[ V ] y"). + +Lemma dec_le_values V m m' : Decidable.decidable (m ≦[V] m'). +Proof. +Admitted. + +Lemma is_ext_le_inter V m m' : + (m ⩽ m') -> le_inter V m m'. +Proof. + move=> hext l k k' hin /hext [] x [] hm0 hle hm1. + eapply LevelMapFact.F.MapsTo_fun in hm0; tea. now subst. +Qed. + +Lemma is_ext_le_value V m m' : + (m ⩽ m') -> le_values V m m'. +Proof. + move=> hext l. + destruct (@level_valueP m l). eapply hext in H as [k' [hm' le]]. + now rewrite (level_value_MapsTo hm'). + constructor. +Qed. + +Definition has_lt V m m' := + (exists l k k', LevelSet.In l V /\ LevelMap.MapsTo l k m /\ LevelMap.MapsTo l k' m' /\ lt_value k k'). + +Lemma nlt_spec V m m' : ~ has_lt V m m' <-> forall l k k', LevelSet.In l V -> LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m' -> lt_value k k' -> False. +Proof. + split. + - intros nlt l k k' inv hm hm' lt. + apply nlt. red. exists l, k, k'; split => //. + - intros hl [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]. + apply (hl l0 k0 k0') => //. +Qed. + +(* Lemma nsmaller m m' : ~ is_smaller_model m m' <-> + exists l k k', LevelMap.MapsTo l k m /\ LevelMap.MapsTo l k' m' /\ lt_value k' k. +Proof. + split. + - intros hnsm. unfold is_smaller_model in hnsm. + eapply Decidable.not_and in hnsm. destruct hnsm. *) + + +Import LevelMap (MapsTo). + +Lemma mapsto_shift_model {n m k l} : MapsTo l k (shift_model n m) -> MapsTo l (option_map (fun k => k - n) k) m. +Proof. + rewrite /shift_model LevelMapFact.F.map_mapsto_iff. + intros [a [-> hm]]. destruct a; cbn => //. + now have -> : (z + n - n) = z by lia. +Qed. + +Lemma mapsto_shift_model_inv {n m k l} : MapsTo l k m -> MapsTo l (option_map (fun k => k + n) k) (shift_model n m). +Proof. + rewrite /shift_model LevelMapFact.F.map_mapsto_iff. + intros hm; eexists; split; trea. +Qed. + +Definition normalize_model m := shift_model (- model_min m) m. + +Lemma min_premise_None m prems : min_premise m prems = None <-> + (exists le, LevelExprSet.In le prems /\ level_value m le.1 = None). +Proof. + have [hf hex] := min_premise_spec m prems. + destruct min_premise eqn:hmin. + - split => //. + move=> [[minp minpk] [hin' hl]]. + specialize (hf _ hin'). rewrite /min_atom_value hl in hf. + depelim hf. + - split => // _. + destruct hex as [[minp mink] [hin heq]]. + exists (minp, mink). split => //. rewrite /min_atom_value in heq. + destruct level_value; cbn in *; congruence. +Qed. + +Instance model_rel_preorder {R : relation (option Z)} : PreOrder R -> PreOrder (model_rel R). +Proof. + intros []. split; tc. +Qed. + +Instance model_rel_partialorder {R : relation (option Z)} {preo : PreOrder R} : + PartialOrder Logic.eq R -> PartialOrder LevelMap.Equal (model_rel R). +Proof. + intros partialo. + intros m m'. + split. + - intros hm. cbn. split. + * hnf. setoid_rewrite hm. eexists; split; trea. + * hnf. setoid_rewrite hm. eexists; split; trea. + - cbn; unfold flip => -[] le le'. + rewrite LevelMapFact.F.Equal_mapsto_iff => k v. + red in le, le'. split. + * move=> hm. move: (le _ _ hm) => [k' [hm' lek']]. + move: (le' _ _ hm') => [k1 [hk1 lek1]]. + eapply LevelMapFact.F.MapsTo_fun in hm; tea. subst k1. + have eq : v = k'. now apply antisymmetry. now subst k'. + * move=> hm. move: (le' _ _ hm) => [k' [hm' lek']]. + move: (le _ _ hm') => [k1 [hk1 lek1]]. + eapply LevelMapFact.F.MapsTo_fun in hm; tea. subst k1. + have eq : v = k'. now apply antisymmetry. now subst k'. +Qed. + +Instance Z_le_partialorder : PreOrder Z.le. +Proof. + split; tc. +Qed. + +Instance opt_le_preorder {A} (R : relation A) {preo : PreOrder R}: PreOrder (opt_le R). +Proof. + split; tc. +Qed. + +Instance opt_le_partialorder : PartialOrder Logic.eq (opt_le Z.le). +Proof. + red; split; cbn; unfold flip. + * intros ->. split; reflexivity. + * move=> [] le le'. destruct x, x0; cbn in *; depelim le; depelim le'; lia_f_equal. +Qed. + +Lemma le_opt_lt x y z : (lt_value x y)%opt -> (y ≤ z)%opt -> lt_value x z. +Proof. + destruct x, y, z; cbn; intros hle hle'; depelim hle'; lia. +Qed. + +Lemma nlt_opt_le x y : ~ (x ≤ y)%opt -> lt_value y x. +Proof. + destruct (check_atom_value x y) eqn:ca. + - move/check_atom_value_spec: ca. contradiction. + - destruct x, y; cbn in * => //. + intros hne. red in hne. cbn in hne. lia. +Qed. + +Instance lt_irrefl : Irreflexive lt_value. +Proof. + intros []; cbn. red. unfold lt_value. unfold lt; cbn. lia. + now hnf. +Qed. + +Instance le_inter_refl V : Reflexive (le_inter V). +Proof. + intros x l k k' hin m m'. eapply LevelMapFact.F.MapsTo_fun in m; tea. subst. reflexivity. +Qed. + +Instance le_values_refl V : Reflexive (le_values V). +Proof. + intros x l; reflexivity. +Qed. + +Instance le_inter_trans V : Transitive (le_values V). +Proof. + intros x y z h0 h1 l hin. transitivity (level_value y l). apply h0 => //. apply h1 => //. +Qed. + +Instance le_values_preorder V : PreOrder (le_values V). +Proof. + split; tc. +Qed. + +Definition eq_level_values V m m' := + forall l, LevelSet.In l V -> level_value m l = level_value m' l. + +Instance eq_level_values_equiv V : Equivalence (eq_level_values V). +Proof. + split. + - intros x l. reflexivity. + - move=> x y h l. now symmetry. + - move=> x y z h h' l. now transitivity (level_value y l). +Qed. + +Instance le_values_partial_order V : PartialOrder (eq_level_values V) (le_values V). +Proof. + intros m m'. + split. + - intros hm. cbn. split. intros l hin. now rewrite hm. + red. intros l hin; now rewrite hm. + - cbn; unfold flip => -[] le le'. + red. intros l hin. move: (le l hin) (le' l hin). + apply antisymmetry. +Qed. + +Definition is_smaller_model V (m m' : model) := + m ≦[V] m' /\ has_lt V m m'. + +Lemma le_values_inter V m m' : le_values V m m' -> le_inter V m m'. +Proof. + intros hle l hin k k' hm hm'. + move: (hle l). + rewrite (level_value_MapsTo hm). + now rewrite (level_value_MapsTo hm'). +Qed. + +Instance model_rel_strictorder V : StrictOrder (is_smaller_model V). +Proof. + split. + - intros x. red. + unfold is_smaller_model. + move=> [eq hlt]. destruct hlt as [l [k [k' [hin [hm [hm' hlt]]]]]]. + eapply LevelMapFact.F.MapsTo_fun in hm; tea. subst. destruct k; cbn in hlt => //. lia. + - intros x y z [le [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]] [le' _]. + split. + * now transitivity y. + * red. exists l0, k0. apply le_values_inter in le. + specialize (le _ _ _ hin hm0 hm0'). + specialize (le' l0). + rewrite (level_value_MapsTo hm0') in le'. + move: le'. + case: (@level_valueP z l0). + intros k hm le'. exists k. split => //. split => //. split => //. eapply le_opt_lt; tea. + now eapply le'. + intros hnin lenon. specialize (lenon hin). + depelim lenon => //. auto. + now destruct k0 ; cbn in hlt'. +Qed. + +Definition is_smaller_model_dec V m m' : Decidable.decidable (is_smaller_model V m m'). +Proof. Admitted. + +Lemma eq_values_equal V m m' : LevelMap.Equal m m' -> eq_level_values V m m'. +Proof. + move=> eqv l; move: (eqv l). + rewrite /level_value. do 2 destruct LevelMap.find => //; congruence. +Qed. + +Lemma eq_level_values_inter {V m m'} : eq_level_values V m m' -> + forall l k k', LevelSet.In l V -> LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m' -> (k = k')%opt. +Proof. + intros eq l k k' hin hm hm'. + specialize (eq l). move: eq. + rewrite (level_value_MapsTo hm) (level_value_MapsTo hm'). intros ->. reflexivity. auto. +Qed. +Print is_smaller_model. +Lemma nis_smaller_spec V m m' : ~ (is_smaller_model V m m') <-> ~ (m ≦[V] m') \/ ~ has_lt V m m'. +Proof. + rewrite /is_smaller_model. + split. + - move/Decidable.not_and => /fwd. apply dec_le_values. auto. + - intros [] []. now apply H. now apply H. +Qed. + +Lemma le_lt_model V m m' : m ≦[V] m' -> ~ (is_smaller_model V m' m). +Proof. + intros le [lt li]. + eapply antisymmetry in le; tea. + move: li. change (~ has_lt V m' m). rewrite nlt_spec. + intros. + eapply eq_level_values_inter in le; tea. subst k'. + now eapply irreflexivity in H2. +Qed. + +Lemma le_inter_has_lt V m m' : le_inter V m m' <-> ~ has_lt V m' m. +Proof. + split. + - intros hinter [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]. + specialize (hinter _ _ _ hin hm0' hm0). + eapply le_opt_lt in hlt'; tea. + now eapply irreflexivity in hlt'. + - move/nlt_spec => hlt l k k' hin hm hm'. + destruct (check_atom_value_spec k k') => //. exfalso. + apply (hlt l k' k hin) => //. + now apply nlt_opt_le in H. +Qed. + +Lemma nle_inter_has_lt V m m' : ~ le_inter V m m' <-> has_lt V m' m. +Proof. + split. + - intros nle. rewrite le_inter_has_lt in nle. todo "decidability". + - rewrite le_inter_has_lt. auto. +Qed. + +Lemma le_values_has_lt V m m' : le_values V m m' -> ~ has_lt V m' m. +Proof. + intros hinter [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]. + eapply le_values_inter in hinter. + specialize (hinter _ _ _ hin hm0' hm0). + eapply le_opt_lt in hlt'; tea. + now eapply irreflexivity in hlt'. +Qed. + +(* Lemma le_values_inter_inv V m m' : model_of V m -> le_inter V m m' -> m ≦[V] m'. +Proof. + intros mof hle l hin. + specialize (mof l hin). + specialize (hle l hin). + move: hle. + destruct (@level_valueP m l) => //. + intros hle. intros h h'. eapply LevelMapFact.F.MapsTo_fun in H; tea. subst k. + depelim hle. + eapply level_value_MapsTo' in H0. + eapply LevelMapFact.F.MapsTo_fun in H0; tea. subst k'. + now constructor. + constructor. +Qed. *) + +(* +- move/nlt_spec => hlt l. k k' hm hm'. + destruct (check_atom_value_spec k k') => //. exfalso. + apply (hlt l k' k). split => //. split => //. + now apply nlt_opt_le in H. +Qed. *) +(* +Lemma contra A B : Decidable.decidable B -> (A -> ~ B) -> (~ A -> B). +Proof. + intros dec f na. + destruct dec. exact H. *) + +Lemma nle_values_has_lt V m m' : + ~ LevelSet.Empty V -> + model_of V m -> ~ le_values V m m' -> has_lt V m' m. +Proof. + intros hne le. +Admitted. + +(* +Lemma nle_ m m' : ~ m ⩽ m' <-> (LevelMap.Empty m' /\ ~ LevelMap.Empty m) \/ + has_lt m m'. +Proof. + move: m'. apply: LevelMapFact.map_induction. + - intros m' he. split. + intros hne. left; split => //. intros he'. apply hne. + have eq : m =m m'. + { rewrite LevelMapFact.F.Equal_mapsto_iff. firstorder. } + rewrite eq. reflexivity. + intros [[hem hem']|lt]. + * intros le. now apply hem' => l k /le -[k' []] /hem. + * intros hle. destruct lt as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. + now eapply he in hm0'. + - move=> m0 m1 nle l k nin hadd. split. + * intros nle'. right. red. + specialize (hle _ _ hm0) as [k' [hin']]. + eapply LevelMapFact.F.MapsTo_fun in hm0'; tea. subst k0'. *) + +Instance le_values_proper V : Proper (LevelMap.Equal ==> LevelMap.Equal ==> iff) (le_values V). +Proof. + intros ?? h ?? h'; rewrite /le_values //=. + now setoid_rewrite h; setoid_rewrite h'. +Qed. +(* +Lemma nle_lt_model m m' : m ≦ m' <-> ~ has_lt m' m. +Proof. + split. + - intros hm' hlt. + destruct hlt as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. + eapply le_values_inter in hm'. + specialize (hm' l0 _ _ hm0' hm0). + have h := le_opt_lt _ _ _ hlt' hm'. now apply irreflexivity in h. + - intros nlt l. rewrite -le_inter_has_lt in nlt. + red in nlt. + + Search has_lt. +*) +(* + move: m m'. apply: LevelMapFact.map_induction. + - intros m he m'. split. + intros hne. elim hne. intros l. + destruct (@level_valueP m l). now eapply he in H. constructor. + unfold has_lt. intros [l [k [k' [hm [hm' _]]]]]. + now eapply he in hm'. + - intros m m0 h x k hnin hadd m'. + apply levelmap_add_spec in hadd. + rewrite /has_lt. + split. + intros hle. setoid_rewrite hadd in hle. + destruct () + + + left; split => //. intros he'. apply hne. + have eq : m =m m'. + { rewrite LevelMapFact.F.Equal_mapsto_iff. firstorder. } + rewrite eq. reflexivity. + intros [[hem hem']|lt]. + * intros le. now apply hem' => l k /le -[k' []] /hem. + * intros hle. destruct lt as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. + now eapply he in hm0'. + - move=> m0 m1 nle l k nin hadd. split. + * intros nle'. right. red. + specialize (hle _ _ hm0) as [k' [hin']]. + + + intros nle. + destruct (dec_le_values m' m). split => //. + eapply nle_values_has_lt. in H. + apply nle_inter_has_lt. + intros lei. apply nle. + red in H, lei. intros l. specialize (H l). + destruct (@level_valueP m l). + destruct (@level_valueP m' l). + specialize (lei _ _ _ H0 H1). auto. + + Search le_inter. + eapply is_ext_le_inter in H. + eapply antisymmetry in H;. + + + destruct (is_smaller_model_dec m' m) => //. + [lt li]. + have eq : m =m m'. + now apply antisymmetry. + setoid_rewrite eq in li. + destruct li as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. + eapply LevelMapFact.F.MapsTo_fun in hm0; tea. subst. + now apply irreflexivity in hlt'. +Qed. *) + + +(* +Lemma minimal_unique cls m m' : + minimal cls m -> is_model cls m -> minimal cls m' -> is_model cls m' -> (normalize_model m) ⩽ (normalize_model m'). +Proof. + intros min ism. + rewrite minimal_forall in min. + intros min' ism'. + rewrite minimal_forall in min'. + specialize (min _ ism'). + specialize (min' _ ism). + destruct (is_smaller_model_dec (normalize_model m) (normalize_model m')). apply H. + assert (sirr := irreflexivity (R := is_smaller_model) (normalize_model m)). + + destruct (dec_ext (normalize_model m) (normalize_model m')) => //. +Qed. *) +Print has_lt. +Lemma nle_values V m m' : + ~ LevelSet.Empty V -> + model_of V m -> + ~ (le_values V m m') -> + exists l, LevelSet.In l V /\ lt_value (level_value m' l) (level_value m l). +Proof. + intros hne mof leq. + have := (nle_values_has_lt V m m' hne mof leq). + intros [l [k [k' []]]]. destruct H0 as [? []]. + exists l; split => //. + now rewrite (level_value_MapsTo H0) (level_value_MapsTo H1). +Qed. + +(* Lemma minimal_le cls m m' : + minimal cls m -> is_model cls m' -> model_of (clauses_levels cls) m' -> + model_of (clauses_levels cls) m -> + is_smaller_model (clauses_levels cls) (normalize_model m) (normalize_model m'). +Proof. + intros nex ism mof mof'. + rewrite minimal_forall in nex. + specialize (nex _ ism). + destruct (is_smaller_model_dec (clauses_levels cls) (normalize_model m) (normalize_model m')) => //. +Abort. *) + + + +(* Lemma minimal_forall cls cls' m : minimal cls cls' m <-> + forall m', is_model cls m' -> is_smaller_model (clauses_levels cls) (normalize_model m') (normalize_model m) -> False. +Proof. + split. + - intros hmin m' ism issm. apply hmin. exists m'. split => //. + - intros hm' [m' [issm ism]]. apply (hm' m' ism issm). +Qed. *) + +(* Lemma minimal_mapsto cls m m' : + minimal cls cls' m -> is_model cls m' -> is_smaller_model (clauses_levels cls) (normalize_model m') (normalize_model m) -> False. +Proof. + intros nex ism. + rewrite minimal_forall in nex. + now specialize (nex _ ism). +Qed. *) + +(* Lemma minimal_model_unique cls minit m m' : + minimal_above minit cls m -> minimal_above minit cls m' -> is_model cls m -> is_model cls m' -> + normalize_model m =m normalize_model m'. +Abort. *) + +Lemma model_of_level_value {V m} l : + model_of V m -> + LevelSet.In l V -> + exists k, LevelMap.MapsTo l k m /\ level_value m l = k. +Proof. + intros mof hin. + specialize (mof l hin). + destruct mof as [k hin']. exists k. split => //. + now rewrite (level_value_MapsTo hin'). +Qed. + + +Definition minimal_above cls minit m := + forall m', minit ⩽ m' -> is_model cls m' -> m ⩽ m'. + +Hint Rewrite clause_levels_spec levels_spec : set_specs. + +Theorem check_invalid_allm {cls cl} : + check_gen cls cl = Invalid -> + forall m, is_model cls m -> + model_of (clauses_levels cls ∪ clause_levels cl) m -> + (premises_model (clauses_levels cls) cl).2 ⩽ m -> + valid_clause m cl -> False. +Proof. + move/check_invalid => [m [ism encl invcl]]. + intros m' ism' mof. + set (pmodel := (premises_model _ _).2). + have minm : minimal_above cls pmodel m. todo "minimal infered". + have pmodelm : pmodel ⩽ m. todo "ext inferred". + intros ext' vm'. + specialize (minm m' ext' ism'). + destruct cl as [prems concl]. + rewrite valid_clause_satisfies in invcl. red in encl. + destruct encl as [minp eqminp]. + rewrite eqminp in invcl. + have nsat : ~ satisfiable_atom m (add_expr minp concl). + { intros s; elim invcl. + right. eexists; split; trea. } + clear invcl. cbn in eqminp. + have [minmf [[minpl minpk] [hin heq]]] := min_premise_spec_aux _ _ _ eqminp. + cbn in heq. destruct (level_value m minpl) as [minpmv|] => //. noconf heq. + (* destruct enclm' as [minp' eqminp']. *) + destruct concl as [concl k]. + destruct (min_premise m' prems) as [minp'|] eqn:minm';revgoals. + { (* Clause is vacuously true in m', so some level in the premises + is undefined in m'. That's a contradiction to minimality of m. + + *) + apply min_premise_None in minm' as [[minm' minm'k] [inminm' undef]]. cbn in undef. + move/min_premise_spec_aux: eqminp => -[hf _]. + specialize (hf _ inminm'). rewrite /min_atom_value in hf. + destruct (level_value m minm') eqn:hl' => //. 2:{ depelim hf. } + depelim hf. specialize (minm minm'). + move: minm. + have [|km' [hm hl]] := (model_of_level_value minm' mof). + { repeat (rsets; cbn); firstorder. } + eapply level_value_MapsTo' in hl'. + (* eapply (mapsto_shift_model_inv) in hl'. *) + (* rewrite /normalize_model. *) + rewrite undef in hl; subst km'. + move/(_ _ hl'). + intros [k' []]. + (* eapply (mapsto_shift_model_inv) in hm. *) + eapply LevelMapFact.F.MapsTo_fun in hm; tea. subst k'. + cbn in H1. depelim H1. } + { (* Clause is not vacuously true in m'. *) + move/valid_clause_elim: vm'. rewrite minm'. + move/(_ _ eq_refl) => hle. + depelim hle. rename H into leminp'; rename H0 into conclm'. + rename y into m'conclv. + unfold satisfiable_atom in nsat. cbn in nsat. + destruct (level_value m concl) as [mconclv|] eqn:hl => //=. + rewrite [is_true _]Z.leb_le in nsat. + move: (minm concl). + (* { repeat (rsets; cbn). firstorder. } *) + apply level_value_MapsTo' in hl. + (* eapply (mapsto_shift_model_inv (n := - model_min m)) in hl. *) + move/(_ _ hl). + apply level_value_MapsTo' in conclm'. + (* eapply (mapsto_shift_model_inv (n := - model_min m')) in conclm'. *) + intros [k' [hm hleq]]. + eapply LevelMapFact.F.MapsTo_fun in conclm'; tea. subst k'. + cbn in hleq. + move/check_atom_value_spec: hleq; cbn. + move/Z.leb_le. + have [minm'f minm'ex] := min_premise_spec_aux _ _ _ minm'. + cbn in hl. + destruct minm'ex as [[minpm' minpm'k] [inmin' eqmin']]. + rewrite /min_atom_value in eqmin'. destruct (level_value m' minpm') as [minpm'v|] eqn:hlx => //. + noconf eqmin'. specialize (minm'f _ hin). + eapply level_value_MapsTo' in hlx. + unfold min_atom_value in minm'f. destruct (level_value m' minpl). + move/check_atom_value_spec: minm'f; cbn. move/Z.leb_le. + specialize (minmf _ inmin'). unfold min_atom_value in minmf. + depelim minmf. + destruct (level_value m minpm') as [minpm'mv|] eqn:hlx' => //. noconf H0. + have hpres : (min_premise m prems ≤ min_premise m' prems)%opt. admit. + rewrite eqminp minm' in hpres. depelim hpres. + intros. lia. + Qed. + Lemma check_invalid_entails {cls cl} : check_gen cls cl = Invalid -> ~ entails cls cl. Proof. @@ -464,33 +1098,6 @@ Qed. In injective semilattices, we can then remove it. *) -Definition pred_expr (le : LevelExpr.t) := - (le.1, le.2 - 1). - -Definition checking_clause (cl : clause) := - let (prems, concl) := cl in - (singleton (pred_expr concl) ∪ prems, concl). - -Definition check_clause cls cl := - check_gen cls (checking_clause cl). - -Definition valid_clause_Z cls cl := - forall v : Level.t -> Z, - positive_valuation v -> - clauses_sem v cls -> clause_sem v cl. - -Lemma check_clause_valid_Z cls cl : - check_clause cls cl = Valid -> valid_clause_Z cls cl. -Proof. - unfold check_clause. - move/check_gen_entails. - move=> ent v posv csem. - apply entails_completeness in ent. - move: {ent}(ent Z _ v csem). - destruct cl as [prems [concl k]]. - rewrite //= !interp_nes_union interp_nes_singleton //= /interp_expr //=. - lia. -Qed. Import Semilattice. Import ISL. @@ -1587,9 +2194,10 @@ Lemma opt_valuation_of_model_equiv m l : Qed. Definition inconsistent_opt_ext m cls := - forall v : Level.t -> option Z, - defined_valuation_of (clauses_levels cls) v -> - clauses_sem v (Clauses.union (clauses m) cls) -> False. + entails_loop m cls. + (* forall v : Level.t -> option Z, + defined_valuation_of (clauses_levels (Clauses.union (clauses m) cls)) v -> + clauses_sem v (Clauses.union (clauses m) cls) -> False. *) Lemma interp_expr_inv {m le k} : @@ -1682,17 +2290,28 @@ Lemma opt_valuation_of_model_equiv m l : cbn. now rewrite interp_nes_add. Qed. + Lemma defined_model (m : t) : defined_model_of (levels m) (model_of m). + Proof. + intros l hin. + have [k hm] := declared_pos_model_of m l hin. + now exists (Z.of_nat k). + Qed. + Lemma enforce_clauses_inconsistent_opt {m cls u} : enforce_clauses m cls = Some (inr u) -> inconsistent_opt_ext m cls. Proof. - intros ec. red. intros v def csem. + intros ec. red. + now move/enforce_clauses_inconsistent_loop: ec. + (* unfold entails_loop. move/enforce_clauses_inconsistent_semilattice: ec => /(_ (option Z) _ v csem). rewrite clauses_sem_eq //= interp_add_prems //=. destruct u as [loop incl hl]. cbn. destruct interp_nes eqn:hi => //=. lia. red in def. - todo "scoping". + have [l|hd] := interp_nes_defined_val v loop. + { move/incl. apply def. } + congruence. *) Qed. Lemma enforce_clauses_inconsistent {m cls u} : @@ -1713,14 +2332,14 @@ Lemma opt_valuation_of_model_equiv m l : Lemma enforce_dec m cls : clauses_levels cls ⊂_lset levels m -> { consistent (Clauses.union (clauses m) cls) } + - { inconsistent_opt_ext m cls }. + { inconsistent (Clauses.union (clauses m) cls) }. Proof. intros hm. destruct (enforce_clauses m cls) eqn:ec. destruct s as [model|loop]. - left. move/enforce_clauses_clauses: ec. intros <-. apply clauses_consistent. - - right. now move/enforce_clauses_inconsistent_opt: ec. + - right. now move/enforce_clauses_inconsistent: ec. (* intros he v semcs semc. red in he. specialize (he ) apply he. red. exists v. split => //. @@ -1928,14 +2547,6 @@ Lemma opt_valuation_of_model_equiv m l : now split; move => h cl /h; rewrite clause_sem_opt. Qed. - - Lemma defined_model (m : t) : defined_model_of (levels m) (model_of m). - Proof. - intros l hin. - have [k hm] := declared_pos_model_of m l hin. - now exists (Z.of_nat k). - Qed. - Definition declared_clauses_levels V cls := LevelSet.Subset (clauses_levels cls) V. Lemma defined_model_of_subset {V V' m} : LevelSet.Subset V V' -> defined_model_of V' m -> defined_model_of V m. @@ -1961,6 +2572,27 @@ Lemma opt_valuation_of_model_equiv m l : - move/check_gen_entails: ch. now left. Qed. + Lemma entails_dec_clauses (m : t) cls : + { entails_clauses (clauses m) cls } + { ~ entails_clauses (clauses m) cls /\ + forall cl, Clauses.In cl cls -> + exists v : Level.t -> option Z, + [/\ positive_opt_valuation v, clauses_sem v (clauses m), defined_valuation_of (clause_premises_levels cl) v & ~ clause_sem v cl] }. + Proof. + Admitted. + (* destruct (check_gen (clauses m) cl) eqn:ch. + - move/check_looping: ch; elim. + exists (model_of m). split. + { have dm := defined_model m. + eapply defined_model_of_subset; tea. + eapply defined_model_of_subset; tea. + apply clauses_levels_declared. } + exact: is_model_of m. + - have ci := check_invalid_valuation ch. + move/check_invalid_entails: ch. intros ne. right. split => //. + - move/check_gen_entails: ch. now left. + Qed. + *) + Definition valid_clause_opt cls cl := forall v : Level.t -> option Z, positive_opt_valuation v -> @@ -1977,10 +2609,6 @@ Lemma opt_valuation_of_model_equiv m l : Lemma contraP P Q : (P -> Q) -> (~ Q -> ~ P). Proof. intros f hp q. apply (hp (f q)). Qed. - Definition inverse_clauses (cl : clause) := - let (prems, concl) := cl in - clauses_of_le (succ_prems prems) (singleton concl). - Lemma clauses_sem_subset {S} {SL : Semilattice.Semilattice S Q.t} {v : Level.t -> S} {cls cls'} : clauses_sem v cls -> cls' ⊂_clset cls -> clauses_sem v cls'. Proof. now move=> hall hsub cl /hsub. @@ -2069,28 +2697,6 @@ Lemma opt_valuation_of_model_equiv m l : apply levels_spec; exists concl.2. destruct concl; cbn. now rsets. Qed. - Search consistent. - - Lemma consistent_dec m cl : - clause_levels cl ⊂_lset levels m -> - { consistent (Clauses.union (clauses m) (Clauses.singleton cl)) } + - { consistent (Clauses.union (clauses m) (inverse_clauses cl)) }. - Proof. - intros hcl. - destruct (enforce_dec m (Clauses.singleton cl)). - admit. - - now left. - - destruct (enforce_dec m (inverse_clauses cl)). - admit. - + now right. - + admit. - (* red in i, i0. - setoid_rewrite neg_inverse in i0. - specialize (i (valuation_of_model m) valuation_of_model_pos (model_valuation m)). - specialize (i0 (valuation_of_model m) valuation_of_model_pos (model_valuation m)). - elim i. now apply clauses_sem_singleton. *) - Admitted. - Lemma clause_sem_dec (v : Level.t -> option Z) cl : Decidable.decidable (clause_sem v cl). Proof. @@ -2102,13 +2708,6 @@ Lemma opt_valuation_of_model_equiv m l : now right. now left. now right. now left. Qed. - Lemma clauses_sem_dec (v : Level.t -> option Z) cl : - Decidable.decidable (clauses_sem v cl). - Proof. - unfold clauses_sem. - move: cl. - Admitted. - Instance total_opt : Total (option Z). Proof. red. intros [] []; cbn. lia. now left. now right. now left. @@ -2124,6 +2723,14 @@ Lemma opt_valuation_of_model_equiv m l : intros x; cbn. lia. Qed. + +Definition pred_expr (le : LevelExpr.t) := + (le.1, le.2 - 1). + +Definition checking_clause (cl : clause) := + let (prems, concl) := cl in + (singleton (pred_expr concl) ∪ prems, concl). + Lemma checking_clause_premise_levels cl : clause_premises_levels (checking_clause cl) =_lset clause_levels (checking_clause cl). @@ -2145,13 +2752,217 @@ Lemma opt_valuation_of_model_equiv m l : now right. Qed. +Definition check_genb cls cl := + match check_gen cls cl with + | IsLooping _ _ _ => false + | Valid => true + | Invalid => false + end. + +Lemma check_gen_model_looping m cl v vcls isl : + check_gen (clauses m) cl = IsLooping v vcls isl -> False. +Proof. + intros. eapply check_valid_looping; tea. + apply m.(model_valid).(model_ok). + eapply defined_model_of_ext. eapply defined_model_of_subset. + 2:{ eapply defined_model. } + now intros ? ?; eapply clauses_levels_declared, vcls. + have hupd := m.(model_valid).(I.model_updates). + now eapply is_update_of_ext in hupd. +Qed. + +Lemma checkb_entails m cl : + check_genb (clauses m) cl <-> entails (clauses m) cl. +Proof. + unfold check_genb. + destruct (check_gen) eqn:ec. + - now move/check_gen_model_looping: ec. + - split => //. + now move/check_invalid_entails: ec. + - now move/check_gen_entails: ec. +Qed. + +Lemma check_gen_model m cl : + check_genb (clauses m) cl <-> (forall m', is_model (clauses m) m' -> valid_clause m' cl). +Proof. + unfold check_genb. + destruct (check_gen) eqn:ec. + - now move/check_gen_model_looping: ec. + - split => //. + move/check_invalid: ec. + intros [m' []]. move/(_ m' H). contradiction. + - split => // _. + intros m' ism. + move/check_gen_entails: ec => ent. + eapply entails_model_valid; tea. +Qed. + +Definition valid_model_clause m cl := + (forall m', is_model (clauses m) m' -> valid_clause m' cl). + +Lemma entails_models m cl : entails (clauses m) cl <-> valid_model_clause m cl. +Proof. + now rewrite -checkb_entails check_gen_model. +Qed. + +Definition valid_all_model_clauses m cls := + (forall m', is_model (clauses m) m' -> enabled_clauses m' cls -> valid_clauses m' cls). + +Definition valid_model_clauses m cls := + (forall m', is_model (clauses m) m' -> + forall cl, Clauses.In cl cls -> valid_clause m' cl). + +Lemma entails_all_models m cls : clauses m ⊢ℋ cls -> valid_all_model_clauses m cls. +Proof. + rewrite /entails_clauses. + intros ha m' ism en. + move=> cl hin. specialize (ha _ hin). + specialize (en _ hin). + now move/entails_models/(_ _ ism): ha. +Qed. + +Lemma entails_all_models_inv m cls : valid_model_clauses m cls <-> clauses m ⊢ℋ cls. +Proof. + split. + - rewrite /entails_clauses. + move=> ha cl /ha hall. + now rewrite entails_models. + - rewrite /entails_clauses. + intros ha m' ism cl. move=> /ha. + move/entails_models=> vm. now apply vm. +Qed. + +(* + - move=> hv cl ha. rewrite entails_models => m' ism en. + red in hv. + apply h; tea. apply + + + intros; red; eauto. + now rewrite -checkb_entails check_gen_model. +Qed. *) + +Lemma check_gen_exists_model m cl : + check_genb (clauses m) cl -> exists m', [/\ is_model (clauses m) m', enabled_clause m' cl & valid_clause m' cl]. +Proof. + unfold check_genb. + funelim (check_gen (clauses m) cl) => // _. + clear H H0. symmetry in Heqcall. + move/check_gen_entails: Heqcall => ent. + exists v.(model_model). split. apply model_ok. todo "enabled". + eapply entails_model_valid; tea. + apply model_ok. +Qed. + + +Lemma check_gen_neg_exists_model m cl : + check_genb (clauses m) cl = false <-> + exists m', [/\ is_model (clauses m) m', enabled_clause m' cl & ~ valid_clause m' cl]. +Proof. + unfold check_genb. + funelim (check_gen (clauses m) cl) => //. + - clear H. symmetry in Heqcall. + now move/check_gen_model_looping: Heqcall. + - clear H H0. symmetry in Heqcall. split => //. + move/check_gen_entails: Heqcall => ent. + intros [m' []]; exfalso. + eapply entails_model_valid in ent; tea. contradiction. + - clear H H0. symmetry in Heqcall. split => //. + now move/check_invalid: Heqcall => ent. +Qed. + +Lemma negb_iff (b : bool) : ~ b <-> ~~ b. +Proof. destruct b; intuition. Qed. + +Lemma nentails_model m cl : + ~ entails (clauses m) cl <-> + exists m', [/\ is_model (clauses m) m', enabled_clause m' cl & ~ valid_clause m' cl]. +Proof. + rewrite -checkb_entails. + rewrite negb_iff /is_true negb_true_iff. + apply check_gen_neg_exists_model. +Qed. + +Definition check_clause m cl := + check_genb (clauses m) (checking_clause cl). + +Definition consistent_clauses cls := + exists val : Level.t -> Z, positive_valuation val /\ clauses_sem val cls. +(* +Lemma consistent_dec m cl : + clause_levels cl ⊂_lset levels m -> + { consistent_clauses (Clauses.union (clauses m) (Clauses.singleton cl)) } + + { consistent_clauses (Clauses.union (clauses m) (inverse_clauses cl)) }. +Proof. + intros hcl. + destruct (enforce_dec m (Clauses.singleton cl)). + admit. + - now left. + - destruct (enforce_dec m (inverse_clauses cl)). + admit. + + now right. + + red in i, i0. + setoid_rewrite neg_inverse in i0. + specialize (i (valuation_of_model m) valuation_of_model_pos (model_valuation m)). + specialize (i0 (valuation_of_model m) valuation_of_model_pos (model_valuation m)). + elim i. now apply clauses_sem_singleton. *) +(* Admitted. *) + + +Lemma valid_enabled_inverse m cl : + enabled_clause m (checking_clause cl) -> + valid_clause m (checking_clause cl) = false -> + valid_clauses m (inverse_clauses (checking_clause cl)). +Proof. + destruct cl as [prems [concl kconcl]]. + intros en vcl cl hin. + unfold inverse_clauses in hin. + eapply clauses_of_le_spec in hin as [[l k] [hin heq]]. subst cl. + apply valid_clause_intro. + move=> z hmin. red in en. cbn in en. + destruct en as [z' hz]. + eapply min_premise_spec_aux in hz as [hf hex]. + rewrite min_premise_singleton in hmin. + rewrite /min_atom_value in hmin. + rewrite add_prems_union in hin. + rewrite add_prems_singleton in hin. + rewrite LevelExprSet.union_spec /singleton //= in hin. + destruct hin. rsets. noconf H. + rewrite /min_atom_value in hmin. + destruct (level_value m concl) eqn:hl => //. noconf hmin. constructor. lia. + rewrite map_levelexprset_spec in H. destruct H as [[l' k'] [hin heq]]. + noconf heq. + move: vcl. + unfold valid_clause. cbn. + destruct min_premise eqn:hmin'. + rewrite /level_value_above. rewrite /min_atom_value in hmin. + destruct level_value eqn:hl => //. noconf hmin. + move: hmin'. + rewrite union_comm NES.union_add_singleton min_premise_add. + rewrite /min_atom_value //= hl. + destruct (min_premise m prems) eqn:hmprems => //=. + intros [= <-]. + apply min_premise_spec_aux in hmprems as [hfp exp]. + specialize (hfp _ hin). rewrite /min_atom_value in hfp. + destruct (level_value m l) eqn:hl'. depelim hfp. + move/Z.leb_gt => h. constructor. lia. + depelim hfp. + move=> //. +Qed. + +Definition valid_clause_Z cls cl := + forall v : Level.t -> Z, + positive_valuation v -> + clauses_sem v cls -> clause_sem v cl. + + Lemma check_clause_invalid_valid_Z m cl : clause_levels cl ⊂_lset (levels m) -> - check_clause (clauses m) cl = Invalid -> ~ valid_clause_Z (clauses m) cl. + check_gen (clauses m) cl = Invalid -> ~ valid_clause_Z (clauses m) cl. Proof. move=> hwf. unfold check_clause. - move/[dup]/check_invalid_entails => nent /check_invalid_valuation [v [posv csem def ncheck]]. + move/[dup]/check_invalid_entails => nent /check_invalid [m' [ism en inval]]. intros vcl. red in vcl. destruct (enforce_dec m (inverse_clauses (checking_clause cl))) => //. * setoid_rewrite <- hwf. @@ -2165,34 +2976,133 @@ Proof. destruct cl as [prems [concl k]]. move: hcl; cbn -[Semilattice.le]. rewrite interp_nes_union interp_nes_singleton /interp_expr. cbn -[Semilattice.le]. cbn; lia. - * clear vcl. apply (i v). + * clear vcl. rewrite neg_inverse in ncheck. + { now rewrite checking_clause_premise_levels in def. } + destruct i as [loop incl hloop]. red in i. red in i. apply (i v). rewrite clause_levels_inverse. now rewrite checking_clause_premise_levels in def. apply clauses_sem_union. split => //. - rewrite neg_inverse in ncheck. - { now rewrite checking_clause_premise_levels in def. } + exact ncheck. Qed. -Lemma check_clause_looping m cl v vcls isl : - check_clause (clauses m) cl = IsLooping v vcls isl -> False. + +Lemma check_clause_valid_Z m cl : + check_clause m cl <-> valid_clause_Z (clauses m) cl. Proof. - rewrite /check_clause. - intros. eapply check_valid_looping; tea. - apply m.(model_valid).(model_ok). - eapply defined_model_of_ext. eapply defined_model_of_subset. - 2:{ eapply defined_model. } - now intros ? ?; eapply clauses_levels_declared, vcls. - have hupd := m.(model_valid).(I.model_updates). - now eapply is_update_of_ext in hupd. + unfold check_clause. + split. + - rewrite checkb_entails. + move=> ent v posv csem. + apply entails_completeness in ent. + red in ent. + move: {ent}(ent Z _ v csem). + destruct cl as [prems [concl k]]. + rewrite //= !interp_nes_union interp_nes_singleton //= /interp_expr //=. + lia. + - intros vc. + destruct (check_genb) eqn:ec => //. + apply (ssrbool.introT (@negPf _)) in ec. + move/negP: ec. rewrite checkb_entails => ent. + destruct (entails_dec_clauses m (inverse_clauses (checking_clause cl))). + * (* Contradiction: valid in Z but invalid in the Horn clauses *) + destruct cl as [prems concl]; cbn in *. + unfold inverse_clauses in e. + rewrite entails_ℋ_clauses_of_relations_equiv in e. + apply entails_L_entails_ℋ_equiv in e. + (* eapply entails_L_clauses_pres_le in e. *) + eapply entails_L_rels_entails_L_clauses in e. + Search relations_of_clauses. + eapply completeness_all in e. + red in e. specialize (e Z _ (Z_valuation_of_model m)). red in vc. cbn in vc. + admit. + (* eapply entails_L_completeness in e. *) + Search entails_L_clauses clauses_of_le. + * destruct a as [inval hvals]. + (* The new clause is independent from the old ones, + we can construct a complete model refuting it. + + *) + rewrite entails_models in ent. clear hvals. + rewrite -entails_all_models_inv in inval. + destruct (enforce_dec m (inverse_clauses (checking_clause cl))). + admit. + red in c. admit. + red in i. red in i. + exfalso. apply ent. red. + intros m' ism en. red in vc. + destruct (valid_clause m' (checking_clause cl)) eqn:he => //. + eapply valid_enabled_inverse in he. + unfold consistent in i. + (* exfalso; apply i. red. *) + exfalso. eapply inval. + red. + intros. + eapply entails_en + + + + rewrite to_entails_all in e. + eapply completeness_all in e. + red in e. + +Search (_ = false). + + destruct (checkb ) + + + intros m' ism en. + red in vc. + specialize (vc (Z_valuation_of_model m)). forward vc. apply valuation_of_model_pos. + specialize (vc (model_valuation m)). + destruct (eq) + intros S. Qed. -Definition check cls cl := - match check_clause cls cl with - | IsLooping _ _ _ => false - | Valid => true - | Invalid => false - end. + +Lemma check_entails m cl : + check (clauses m) cl <-> entails (clauses m) cl. +Proof. + unfold check. + destruct (check_clause) eqn:ec. + - now move/check_clause_looping: ec. + - split => //. unfold check_clause in ec. + move/check_invalid_entails: ec. + intros ne ent. + exfalso; apply ne. + destruct cl as [prems [concl k]]; cbn. + now eapply entails_weak_union. + - unfold check_clause in ec. + move/check_gen_entails: ec. + intros ent; split => // _. + destruct cl as [prems [concl k]]; cbn in *. + Search entails. + now eapply entails_weak_union. + + +Qed. + +Definition check_clauses (cls : Clauses.t) (cls' : Clauses.t) : bool := + Clauses.for_all (check cls) cls'. + +Lemma check_clauses_spec cls cls' : + check_clauses cls cls' <-> entails_clauses cls cls'. +Proof. + split. + - rewrite /check_clauses /Deciders.check_clauses. + move/Clauses.for_all_spec => ha cl /ha. unfold checkb. + destruct check_clause eqn:ch => // _. + eapply check_gen_entails in ch. now apply ch. + - intros hv. + rewrite /check_clauses /Deciders.check_clauses. + eapply Clauses.for_all_spec; tc => cl hin. + unfold checkb; destruct check eqn:hc => //. + * exfalso; eapply check_entails_looping in hc; tea. + now apply model_entails_succ in hc. + * move/check_invalid_entails: hc => he. + exfalso. elim he. now apply hv. + Qed. + Theorem check_spec m cl : clause_levels cl ⊂_lset levels m -> @@ -2216,10 +3126,6 @@ Proof. - now move/check_clause_valid_Z: he. Qed. -Definition check_clauses (cls : clauses) (cls' : clauses) : bool := - Clauses.for_all (checkb cls) cls'. - - Definition valid_clauses cls cls' := forall v : Level.t -> option Z, positive_opt_valuation v -> @@ -2230,24 +3136,6 @@ Definition check_clauses (cls : clauses) (cls' : clauses) : bool := check_clauses (clauses m) cls. - Lemma check_clauses_spec m cls : - check_clauses m cls <-> entails_clauses (clauses m) cls. - Proof. - split. - - rewrite /check_clauses /Deciders.check_clauses. - move/Clauses.for_all_spec => ha cl /ha. unfold checkb. - destruct check_clause eqn:ch => // _. - eapply check_gen_entails in ch. now apply ch. - - intros hv. - rewrite /check_clauses /Deciders.check_clauses. - eapply Clauses.for_all_spec; tc => cl hin. - unfold checkb; destruct check eqn:hc => //. - * exfalso; eapply check_entails_looping in hc; tea. - now apply model_entails_succ in hc. - * move/check_invalid_entails: hc => he. - exfalso. elim he. now apply hv. - Qed. - Lemma check_clauses_complete m cls : check_clauses m cls <-> valid_entailments (clauses m) cls. Proof. @@ -2325,72 +3213,14 @@ Definition check_clauses (cls : clauses) (cls' : clauses) : bool := rewrite interp_add_prems //=. lia. * move/check_invalid_valuation: hc. move=> [v [_ semcls def ncl]]. specialize (semcl v). elim ncl; now apply semcl. - Qed. - -Definition pred (le : LevelExpr.t) := (le.1, le.2 - 1). - -(* Theorem check_entails_all {cls prems concl} : - check cls (prems, concl) = Valid -> - entails cls (union prems (singleton (pred concl)), concl). -Proof. -Admitted. *) + Qed. + Definition pred (le : LevelExpr.t) := (le.1, le.2 - 1). Lemma nRopt {A} (x y : A) : ~ R_opt Logic.eq (Some x) (Some y) -> x <> y. Proof. intros hr heq. apply hr. now cbn. Qed. -(* - Lemma extend_val m cl : - (exists v : Level.t -> option Z, - [/\ positive_opt_valuation v, clauses_sem v (clauses m), enables_clause v cl & ~ clause_sem v cl]) -> - exists v : Level.t -> option Z, - [/\ positive_opt_valuation v, enables_clauses v (clauses m), clauses_sem v (clauses m), enables_clause v cl & ~ clause_sem v cl]. - Proof. - intros [v [vpos csem en nsem]]. - destruct cl as [prems concl]. cbn in nsem. - red in en. destruct en as [k he]. - rewrite he in nsem. cbn in nsem. - destruct (interp_expr v concl) eqn:hiconcl. - - (* Conclusion is defined but not high enough *) - apply nRopt in nsem. - have hmax : Z.max z k = z /\ k < z. - { destruct (Z.max_spec k z) as [[]|[]]; try lia. split => //. lia. - cbn. lia. } - cbn in he. - exact H. - move/(iffP): nsem. *) - - - - - Lemma check' m cl : - clause_levels cl ⊂_lset levels m -> - { valid_clause_Z (clauses m) cl } + { ~ valid_clause_Z (clauses m) cl }. - Proof. - intros hwf. - (* Check *) - destruct (entails_dec m cl). - - left. intros h hpov hsem. - rewrite -entails_completeness in e. - now apply e. - - destruct (consistent_dec m cl) => //. - * right; intros vc. red in vc. red in c. destruct a. - admit. - (* * setoid_rewrite <- hwf. - now rewrite clause_levels_inverse. *) - * right. intros vc. - destruct c as [tot [totpos csem]]. - apply clauses_sem_union in csem as [cls cinv]. - red in vc. move: (vc tot) => /fwd. exact: totpos. - move=>/(_ cls) => hcl. - now eapply clauses_sem_tot_inverse_false. - Qed. - - (* Definition check_clauses m cls (decl : clauses_levels cl ⊂_lset levels m) := - { valid_clause_Z (clauses m) cl } + { ~ valid_clause_Z (clauses m) cl }. - Proof. *) - End Abstract. End Deciders. From 0d521e7265de1f2fe91d040939c022eee99a7430 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 7 Oct 2025 20:48:42 +0200 Subject: [PATCH 094/164] Finished proof, up-to assumptions on inference --- common/theories/LoopChecking/Deciders.v | 163 ++++++++++++------------ 1 file changed, 84 insertions(+), 79 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 77a6c9c38..f080444e1 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -513,8 +513,8 @@ Proof. red. rewrite -is_ext_spec. now destruct is_ext. Qed. -Definition le_inter V m m' := - (forall l k k', LevelSet.In l V -> LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m' -> (k ≤ k')%opt). +Definition le_inter m m' := + (forall l k k', LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m' -> (k ≤ k')%opt). Definition le_values V m m' := forall l, LevelSet.In l V -> (level_value m l ≤ level_value m' l)%opt. @@ -525,10 +525,10 @@ Lemma dec_le_values V m m' : Decidable.decidable (m ≦[V] m'). Proof. Admitted. -Lemma is_ext_le_inter V m m' : - (m ⩽ m') -> le_inter V m m'. +Lemma is_ext_le_inter m m' : + (m ⩽ m') -> le_inter m m'. Proof. - move=> hext l k k' hin /hext [] x [] hm0 hle hm1. + move=> hext l k k' /hext [] x [] hm0 hle hm1. eapply LevelMapFact.F.MapsTo_fun in hm0; tea. now subst. Qed. @@ -656,9 +656,9 @@ Proof. now hnf. Qed. -Instance le_inter_refl V : Reflexive (le_inter V). +Instance le_inter_refl : Reflexive le_inter. Proof. - intros x l k k' hin m m'. eapply LevelMapFact.F.MapsTo_fun in m; tea. subst. reflexivity. + intros x l k k' m m'. eapply LevelMapFact.F.MapsTo_fun in m; tea. subst. reflexivity. Qed. Instance le_values_refl V : Reflexive (le_values V). @@ -701,15 +701,15 @@ Qed. Definition is_smaller_model V (m m' : model) := m ≦[V] m' /\ has_lt V m m'. -Lemma le_values_inter V m m' : le_values V m m' -> le_inter V m m'. +(* Lemma le_values_inter V m m' : le_values V m m' -> le_inter m m'. Proof. - intros hle l hin k k' hm hm'. + intros hle l k k' hm hm'. move: (hle l). rewrite (level_value_MapsTo hm). now rewrite (level_value_MapsTo hm'). -Qed. +Qed. *) -Instance model_rel_strictorder V : StrictOrder (is_smaller_model V). +(* Instance model_rel_strictorder V : StrictOrder (is_smaller_model V). Proof. split. - intros x. red. @@ -730,8 +730,8 @@ Proof. intros hnin lenon. specialize (lenon hin). depelim lenon => //. auto. now destruct k0 ; cbn in hlt'. -Qed. - +Qed. *) +(* Definition is_smaller_model_dec V m m' : Decidable.decidable (is_smaller_model V m m'). Proof. Admitted. @@ -767,14 +767,14 @@ Proof. now eapply irreflexivity in H2. Qed. -Lemma le_inter_has_lt V m m' : le_inter V m m' <-> ~ has_lt V m' m. +Lemma le_inter_has_lt V m m' : le_inter m m' <-> ~ has_lt V m' m. Proof. split. - intros hinter [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]. - specialize (hinter _ _ _ hin hm0' hm0). + specialize (hinter _ _ _ hm0' hm0). eapply le_opt_lt in hlt'; tea. now eapply irreflexivity in hlt'. - - move/nlt_spec => hlt l k k' hin hm hm'. + - move/nlt_spec => hlt l k k' hm hm'. destruct (check_atom_value_spec k k') => //. exfalso. apply (hlt l k' k hin) => //. now apply nlt_opt_le in H. @@ -794,7 +794,7 @@ Proof. specialize (hinter _ _ _ hin hm0' hm0). eapply le_opt_lt in hlt'; tea. now eapply irreflexivity in hlt'. -Qed. +Qed. *) (* Lemma le_values_inter_inv V m m' : model_of V m -> le_inter V m m' -> m ≦[V] m'. Proof. @@ -996,22 +996,63 @@ Proof. now rewrite (level_value_MapsTo hin'). Qed. - Definition minimal_above cls minit m := forall m', minit ⩽ m' -> is_model cls m' -> m ⩽ m'. +Lemma Some_leq x y : (Some x ≤ y)%opt -> exists y', y = Some y' /\ (x <= y')%Z. +Proof. + intros h; depelim h. now eexists. +Qed. + +Lemma strictly_updates_minimal_above cls W m m' : + strictly_updates cls W m m' -> + minimal_above cls m m'. +Proof. + move: W m m'. + apply: (strictly_updates_elim cls). + - intros l l' h ? ? x ? ? y. subst x0 x1. + unfold minimal_above. reflexivity. + - destruct cl as [prems [concl k]]. + move=> m' hin [minp [hmin habove]]. + rewrite /minimal_above. intros h; setoid_rewrite h. + move=> mf ext ism. + eapply is_model_valid in ism. + specialize (ism _ hin). cbn in ism. + move/valid_clause_elim: ism. + intros hz. + have := @min_premise_pres m mf prems ext. + rewrite hmin. move/Some_leq => -[minmf] [] /hz /Some_leq [mfconcl] [] vmconcl leq' leq. + move=> l k'. rsets. destruct H as [[<- <-]|[neq mt]]. + * exists (Some mfconcl). split => //. now eapply level_value_MapsTo'. + constructor. lia. + * now apply ext. + - intros * su ma su' ma'. + intros mf extinit ism. + move: (ma mf extinit ism) => hext. + exact (ma' mf hext ism). +Qed. + Hint Rewrite clause_levels_spec levels_spec : set_specs. +Lemma nge_lt x y : (~ x <= y) -> y < x. +Proof. intros n. unfold lt; cbn. lia. Qed. + +Definition check_init_model cls cl := + (premises_model (clauses_levels cls) cl).2. + Theorem check_invalid_allm {cls cl} : check_gen cls cl = Invalid -> forall m, is_model cls m -> + let minit := check_init_model cls cl in + minimal_above cls minit m -> model_of (clauses_levels cls ∪ clause_levels cl) m -> - (premises_model (clauses_levels cls) cl).2 ⩽ m -> + minit ⩽ m -> valid_clause m cl -> False. Proof. move/check_invalid => [m [ism encl invcl]]. - intros m' ism' mof. - set (pmodel := (premises_model _ _).2). + intros m' ism' pmodel minm' mof. + have mofm : model_of (clauses_levels cls ∪ clause_levels cl) m. + todo "model of". have minm : minimal_above cls pmodel m. todo "minimal infered". have pmodelm : pmodel ⩽ m. todo "ext inferred". intros ext' vm'. @@ -1026,65 +1067,29 @@ Proof. clear invcl. cbn in eqminp. have [minmf [[minpl minpk] [hin heq]]] := min_premise_spec_aux _ _ _ eqminp. cbn in heq. destruct (level_value m minpl) as [minpmv|] => //. noconf heq. - (* destruct enclm' as [minp' eqminp']. *) destruct concl as [concl k]. - destruct (min_premise m' prems) as [minp'|] eqn:minm';revgoals. - { (* Clause is vacuously true in m', so some level in the premises - is undefined in m'. That's a contradiction to minimality of m. - - *) - apply min_premise_None in minm' as [[minm' minm'k] [inminm' undef]]. cbn in undef. - move/min_premise_spec_aux: eqminp => -[hf _]. - specialize (hf _ inminm'). rewrite /min_atom_value in hf. - destruct (level_value m minm') eqn:hl' => //. 2:{ depelim hf. } - depelim hf. specialize (minm minm'). - move: minm. - have [|km' [hm hl]] := (model_of_level_value minm' mof). - { repeat (rsets; cbn); firstorder. } - eapply level_value_MapsTo' in hl'. - (* eapply (mapsto_shift_model_inv) in hl'. *) - (* rewrite /normalize_model. *) - rewrite undef in hl; subst km'. - move/(_ _ hl'). - intros [k' []]. - (* eapply (mapsto_shift_model_inv) in hm. *) - eapply LevelMapFact.F.MapsTo_fun in hm; tea. subst k'. - cbn in H1. depelim H1. } - { (* Clause is not vacuously true in m'. *) - move/valid_clause_elim: vm'. rewrite minm'. - move/(_ _ eq_refl) => hle. - depelim hle. rename H into leminp'; rename H0 into conclm'. - rename y into m'conclv. - unfold satisfiable_atom in nsat. cbn in nsat. - destruct (level_value m concl) as [mconclv|] eqn:hl => //=. - rewrite [is_true _]Z.leb_le in nsat. - move: (minm concl). - (* { repeat (rsets; cbn). firstorder. } *) - apply level_value_MapsTo' in hl. - (* eapply (mapsto_shift_model_inv (n := - model_min m)) in hl. *) - move/(_ _ hl). - apply level_value_MapsTo' in conclm'. - (* eapply (mapsto_shift_model_inv (n := - model_min m')) in conclm'. *) - intros [k' [hm hleq]]. - eapply LevelMapFact.F.MapsTo_fun in conclm'; tea. subst k'. - cbn in hleq. - move/check_atom_value_spec: hleq; cbn. - move/Z.leb_le. - have [minm'f minm'ex] := min_premise_spec_aux _ _ _ minm'. - cbn in hl. - destruct minm'ex as [[minpm' minpm'k] [inmin' eqmin']]. - rewrite /min_atom_value in eqmin'. destruct (level_value m' minpm') as [minpm'v|] eqn:hlx => //. - noconf eqmin'. specialize (minm'f _ hin). - eapply level_value_MapsTo' in hlx. - unfold min_atom_value in minm'f. destruct (level_value m' minpl). - move/check_atom_value_spec: minm'f; cbn. move/Z.leb_le. - specialize (minmf _ inmin'). unfold min_atom_value in minmf. - depelim minmf. - destruct (level_value m minpm') as [minpm'mv|] eqn:hlx' => //. noconf H0. - have hpres : (min_premise m prems ≤ min_premise m' prems)%opt. admit. - rewrite eqminp minm' in hpres. depelim hpres. - intros. lia. - Qed. + have hpres : (min_premise m prems ≤ min_premise m' prems)%opt. + { now eapply min_premise_pres. } + rewrite eqminp in hpres. depelim hpres. + rename y into minpm'. rename H into minpm'minpm. + rename H0 into minpm'eq. + (* Clause is not vacuously true in m'. *) + move/valid_clause_elim: vm'. + move/(_ _ minpm'eq) => hle. + depelim hle. rename H into leminp'; rename H0 into conclm'. + rename y into m'conclv. + unfold satisfiable_atom in nsat. cbn in nsat. + destruct (model_of_level_value concl mofm) as [conclv [hm hl]]. + { repeat (rsets; cbn). now right. } + eapply level_value_MapsTo' in conclm'. + move: (minm' m pmodelm ism). move/is_ext_le_inter => /(_ concl _ _ conclm' hm) + /check_atom_value_spec //=. + destruct conclv as [conclv|] => //. move/Z.leb_le => concllt. + rewrite hl in nsat. move/Z.leb_le in nsat. + have hmconcl : (conclv < minpmv - minpk + k)%Z by lia. + move/is_ext_le_inter: minm => /(_ concl _ _ hm conclm') /check_atom_value_spec //=. + move/Z.leb_le. lia. +Qed. Lemma check_invalid_entails {cls cl} : check_gen cls cl = Invalid -> ~ entails cls cl. From e1cdf393bb7e2b3b155962c40c2988a29aed54d9 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 7 Oct 2025 21:28:18 +0200 Subject: [PATCH 095/164] Finally, the proof method with the minimal model assumption works for valuations in Z. --- common/theories/LoopChecking/Deciders.v | 63 +++++++++++++++---------- 1 file changed, 38 insertions(+), 25 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index f080444e1..ed8b78170 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -1032,7 +1032,16 @@ Proof. exact (ma' mf hext ism). Qed. -Hint Rewrite clause_levels_spec levels_spec : set_specs. +Lemma is_update_of_minimal_above cls W m m' : + is_update_of cls W m m' -> + minimal_above cls m m'. +Proof. + move/is_update_of_case => [[emp eq]|su]. + - rewrite /minimal_above => m0. now rewrite eq. + - now eapply strictly_updates_minimal_above. +Qed. + +Hint Rewrite clause_levels_spec levels_spec : set_specs'. Lemma nge_lt x y : (~ x <= y) -> y < x. Proof. intros n. unfold lt; cbn. lia. Qed. @@ -1080,7 +1089,7 @@ Proof. rename y into m'conclv. unfold satisfiable_atom in nsat. cbn in nsat. destruct (model_of_level_value concl mofm) as [conclv [hm hl]]. - { repeat (rsets; cbn). now right. } + { repeat (autorewrite with set_specs set_specs'; cbn). now right. } eapply level_value_MapsTo' in conclm'. move: (minm' m pmodelm ism). move/is_ext_le_inter => /(_ concl _ _ conclm' hm) /check_atom_value_spec //=. @@ -1258,7 +1267,8 @@ Module CorrectModel. only_model_of_V : only_model_of V initial_model; model_updates : LevelSet.t; clauses_declared : clauses_levels cls ⊂_lset V; - model_valid : valid_model V model_updates initial_model cls }. + model_valid : valid_model V model_updates initial_model cls + }. Arguments t : clear implicits. Definition model_of {V cls} (x : t V cls) := x.(model_valid).(model_model). @@ -1267,6 +1277,12 @@ Module CorrectModel. Lemma is_model_of {V cls} (x : t V cls) : is_model cls (model_of x). Proof. apply x.(model_valid). Qed. + Lemma model_minimal {V cls} (x : t V cls) : minimal_above cls (initial_model x) (model_of x). + Proof. + have upd := I.model_updates x.(model_valid). + now eapply is_update_of_minimal_above in upd. + Qed. + Lemma declared_zero_model_of {V cls} (x :t V cls) : zero_declared (model_of x). Proof. have h := declared_zero x. @@ -2967,28 +2983,25 @@ Lemma check_clause_invalid_valid_Z m cl : Proof. move=> hwf. unfold check_clause. - move/[dup]/check_invalid_entails => nent /check_invalid [m' [ism en inval]]. - intros vcl. red in vcl. - destruct (enforce_dec m (inverse_clauses (checking_clause cl))) => //. - * setoid_rewrite <- hwf. - rewrite clause_levels_inverse. - now rewrite checking_clause_levels. - * destruct c as [tot [totpos csem']]. - apply clauses_sem_union in csem' as [cls cinv]. - move: (vcl tot) => /fwd. exact: totpos. - move=>/(_ cls) => hcl. - eapply clauses_sem_tot_inverse_false; tea. - destruct cl as [prems [concl k]]. - move: hcl; cbn -[Semilattice.le]. - rewrite interp_nes_union interp_nes_singleton /interp_expr. cbn -[Semilattice.le]. cbn; lia. - * clear vcl. rewrite neg_inverse in ncheck. - { now rewrite checking_clause_premise_levels in def. } - destruct i as [loop incl hloop]. red in i. red in i. apply (i v). - rewrite clause_levels_inverse. - now rewrite checking_clause_premise_levels in def. - apply clauses_sem_union. split => //. - - exact ncheck. + move/check_invalid_allm => /(_ (model m) (model_ok (model_valid m))). + set (minit := check_init_model _ _). + move=> /fwd. + Locate model_updates. + { have minimal := model_minimal m. + red. red in minimal. + move=> m' initle ism. eapply minimal. + admit. exact ism. } + move=> /fwd. + { move=> k hin. have he := model_levels m k. admit. } + move=> /fwd. + { admit. } + move=> invalidc vc. apply invalidc. + red in vc. move: (vc (Z_valuation_of_model m)) => /fwd. + eapply valuation_of_model_pos. + move/(_ (model_valuation m)). + rewrite def_clause_sem_valid //. + { eapply defined_model_of_subset; tea. + eapply defined_model. } Qed. From 66041ea4e2ebc3c93d98178ce224fe0511ef64a0 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 7 Oct 2025 22:50:56 +0200 Subject: [PATCH 096/164] Refactorings and cleanups, generalizing the invalidity proof --- common/theories/LoopChecking/Deciders.v | 27 +++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index ed8b78170..344f74e39 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -999,6 +999,12 @@ Qed. Definition minimal_above cls minit m := forall m', minit ⩽ m' -> is_model cls m' -> m ⩽ m'. +Lemma minimal_above_refl cls m : minimal_above cls m m. +Proof. + red. + now intros m'. +Qed. + Lemma Some_leq x y : (Some x ≤ y)%opt -> exists y', y = Some y' /\ (x <= y')%Z. Proof. intros h; depelim h. now eexists. @@ -1051,19 +1057,19 @@ Definition check_init_model cls cl := Theorem check_invalid_allm {cls cl} : check_gen cls cl = Invalid -> - forall m, is_model cls m -> - let minit := check_init_model cls cl in + forall minit m, is_model cls m -> minimal_above cls minit m -> model_of (clauses_levels cls ∪ clause_levels cl) m -> minit ⩽ m -> valid_clause m cl -> False. Proof. move/check_invalid => [m [ism encl invcl]]. - intros m' ism' pmodel minm' mof. + intros minit m' ism' minm' mof. have mofm : model_of (clauses_levels cls ∪ clause_levels cl) m. todo "model of". - have minm : minimal_above cls pmodel m. todo "minimal infered". - have pmodelm : pmodel ⩽ m. todo "ext inferred". + have minm : minimal_above cls minit m. + { todo "minimal infered". } + have pmodelm : minit ⩽ m. todo "ext inferred". intros ext' vm'. specialize (minm m' ext' ism'). destruct cl as [prems concl]. @@ -1099,6 +1105,16 @@ Proof. move/is_ext_le_inter: minm => /(_ concl _ _ hm conclm') /check_atom_value_spec //=. move/Z.leb_le. lia. Qed. +(* +Lemma check_invalid_allm_zero {cls cl} : + check_gen cls cl = Invalid -> + forall m, is_model cls m -> + minimal_above cls (zero_model (clauses )) m -> + model_of (clauses_levels cls ∪ clause_levels cl) m -> + minit ⩽ m -> + valid_clause m cl -> False. +Proof. *) + Lemma check_invalid_entails {cls cl} : check_gen cls cl = Invalid -> ~ entails cls cl. @@ -2986,7 +3002,6 @@ Proof. move/check_invalid_allm => /(_ (model m) (model_ok (model_valid m))). set (minit := check_init_model _ _). move=> /fwd. - Locate model_updates. { have minimal := model_minimal m. red. red in minimal. move=> m' initle ism. eapply minimal. From daa3e8e7facb89fe798d171eae1e829e309a4764 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 9 Oct 2025 11:19:38 +0200 Subject: [PATCH 097/164] Make deciders compile again --- .vscode/metarocq.code-workspace | 2 +- common/theories/LoopChecking/Deciders.v | 1252 ++++++++--------- .../LoopChecking/HornSemilatticeEquiv.v | 28 +- template-rocq/theories/Junk.v | 428 ++++++ 4 files changed, 1045 insertions(+), 665 deletions(-) diff --git a/.vscode/metarocq.code-workspace b/.vscode/metarocq.code-workspace index 8efb022e3..329bee370 100644 --- a/.vscode/metarocq.code-workspace +++ b/.vscode/metarocq.code-workspace @@ -123,7 +123,7 @@ "coq-lsp.show_universes_on_hover": false, "coq-lsp.pp_type": 1, "coq-lsp.heatmap.enabled": true, - "coq-lsp.goal_after_tactic": true, + "coq-lsp.goal_after_tactic": false, "coq-lsp.messages_follow_goal": false, "coq-lsp.send_perf_data": false, "coq-lsp.admit_on_bad_qed": false, diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 344f74e39..56a4e8cfb 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -303,7 +303,7 @@ Qed. Variant check_result {cls} := | IsLooping (v : premises) (hincl : NES.levels v ⊂_lset clauses_levels cls) (islooping : loop_on_univ cls v) - | Invalid + | Invalid (m : model) | Valid. Arguments check_result : clear implicits. @@ -326,7 +326,7 @@ check_gen cls cl with inspect (loop_check cls cl) := | exist (Model W v _) he with inspect (LevelMap.find (concl cl).1 v.(model_model)) := { | exist (Some val) he' with check_atom_value (Some (concl cl).2) val := { | true => Valid - | false => Invalid } + | false => Invalid v.(model_model) } | exist None he' with valid_model_find v he' := {} } }. @@ -404,193 +404,21 @@ Proof. rewrite interp_add_prems. cbn. lia. Qed. -Theorem check_invalid {cls cl} : - check_gen cls cl = Invalid -> exists m, [/\ is_model cls m, enabled_clause m cl & ~ valid_clause m cl]. -Proof. - funelim (check_gen cls cl) => //. - clear H H0 he. - set (V := (clause_levels cl ∪ clauses_levels cls)%levels) in *. - destruct cl as [prems [concl k]]. - rename val into conclval_v => _. - clear Heqcall prf. - move: (check_atom_value_spec (Some k) conclval_v). rewrite Heq. - intros r; depelim r. rename H into nent. - have vmupd := model_updates v. - have vmok := model_ok v. - set (pm := premises_model_map _ _) in *. - set (cl := (prems, _)) in V. - have nepm : defined_map pm. - { apply premises_model_map_defined. - move/(_ cl). rewrite Clauses.singleton_spec /cl. congruence. } - have nev : defined_map (model_model v). - by apply (is_update_of_defined_map nepm vmupd). - move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. - exists (model_model v). - have en : enabled_clause (model_model v) cl. - { apply (@enabled_clause_ext pm). - exact: is_update_of_ext (model_updates v). - red; cbn. - have hcl : Clauses.In cl (Clauses.singleton cl). - { now eapply Clauses.singleton_spec. } - have hs:= @premises_model_map_min_premise_inv V _ _ hcl. firstorder. } - split => //. - destruct en as [z minp]. - move/valid_clause_elim/(_ z minp). - cbn in minp. - cbn in he'. - rewrite /level_value he' => h; depelim h. apply nent. - constructor. cbn -[check_atom_value] in Heq. - have posz : 0 <= z. - { have hsu := model_updates v. - eapply is_update_of_ext in hsu. - have hs := min_premise_pres prems hsu. - rewrite minp in hs. - have hmin := @premises_model_map_min_premise_inv V (Clauses.singleton cl) cl. - forward hmin. now apply Clauses.singleton_spec. - destruct hmin as [minp' [hmineq hpos]]. - rewrite hmineq in hs. depelim hs. lia. } - lia. -Qed. - -Lemma valid_clause_satisfies m prems concl : valid_clause m (prems, concl) <-> - min_premise m prems = None \/ - (exists z, min_premise m prems = Some z /\ satisfiable_atom m (add_expr z concl)). -Proof. - destruct concl as [concl k]. - split. - - move/valid_clause_elim. intros hz. - destruct min_premise => //. right. specialize (hz _ eq_refl). depelim hz. - eexists; split; trea. unfold satisfiable_atom. cbn. rewrite H0. apply Z.leb_le. lia. - now left. - - intros disj; apply valid_clause_intro. - intros z hz. - destruct disj. congruence. destruct H as [z0 [hmin hsat]]. - rewrite hmin in hz; noconf hz. - cbn in hsat. destruct level_value => //. constructor. apply Z.leb_le in hsat. lia. -Qed. - -Definition inverse_clauses (cl : clause) := - let (prems, concl) := cl in - clauses_of_le (succ_prems prems) (singleton concl). - -Definition normalize m k := - option_map (fun k => k - model_min m) k. - -Definition lt_value (x y : option Z) := - match x, y with - | Some x, Some y => x < y - | None, Some _ => True - | Some _, None => False - | None, None => False - end. - -Definition is_ext m m' : bool := - LevelMapFact.for_all (fun l k => - match LevelMap.find l m' with - | None => false - | Some k' => check_atom_value k k' - end) m. - -(* Definition extends m m' := - (forall l k, LevelMap.MapsTo l k m -> exists k', LevelMap.MapsTo l k' m' /\ (k ≤ k')%opt). *) - -Lemma is_ext_spec m m' : is_ext m m' <-> m ⩽ m'. -Proof. - split. - - rewrite /is_ext. - rewrite [is_true _]LevelMapFact.for_all_iff => hf l k /hf. - case: (find_spec l m') => //. - move=> k0 hm /check_atom_value_spec hle. exists k0. split => //. - - intros ext. rewrite /is_ext. - rewrite [is_true _]LevelMapFact.for_all_iff => l e /ext. - intros [k' [hm hle]]. - rewrite (LevelMap.find_1 hm). - now apply/check_atom_value_spec. -Qed. - -Lemma dec_ext m m' : Decidable.decidable (m ⩽ m'). -Proof. - red. rewrite -is_ext_spec. now destruct is_ext. -Qed. - -Definition le_inter m m' := - (forall l k k', LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m' -> (k ≤ k')%opt). - -Definition le_values V m m' := - forall l, LevelSet.In l V -> (level_value m l ≤ level_value m' l)%opt. - -Infix "≦[ V ]" := (le_values V) (at level 70, format "x ≦[ V ] y"). - -Lemma dec_le_values V m m' : Decidable.decidable (m ≦[V] m'). -Proof. -Admitted. - -Lemma is_ext_le_inter m m' : - (m ⩽ m') -> le_inter m m'. -Proof. - move=> hext l k k' /hext [] x [] hm0 hle hm1. - eapply LevelMapFact.F.MapsTo_fun in hm0; tea. now subst. -Qed. - -Lemma is_ext_le_value V m m' : - (m ⩽ m') -> le_values V m m'. -Proof. - move=> hext l. - destruct (@level_valueP m l). eapply hext in H as [k' [hm' le]]. - now rewrite (level_value_MapsTo hm'). - constructor. -Qed. - -Definition has_lt V m m' := - (exists l k k', LevelSet.In l V /\ LevelMap.MapsTo l k m /\ LevelMap.MapsTo l k' m' /\ lt_value k k'). - -Lemma nlt_spec V m m' : ~ has_lt V m m' <-> forall l k k', LevelSet.In l V -> LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m' -> lt_value k k' -> False. -Proof. - split. - - intros nlt l k k' inv hm hm' lt. - apply nlt. red. exists l, k, k'; split => //. - - intros hl [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]. - apply (hl l0 k0 k0') => //. -Qed. - -(* Lemma nsmaller m m' : ~ is_smaller_model m m' <-> - exists l k k', LevelMap.MapsTo l k m /\ LevelMap.MapsTo l k' m' /\ lt_value k' k. -Proof. - split. - - intros hnsm. unfold is_smaller_model in hnsm. - eapply Decidable.not_and in hnsm. destruct hnsm. *) - - -Import LevelMap (MapsTo). - -Lemma mapsto_shift_model {n m k l} : MapsTo l k (shift_model n m) -> MapsTo l (option_map (fun k => k - n) k) m. +Instance Z_le_partialorder : PreOrder Z.le. Proof. - rewrite /shift_model LevelMapFact.F.map_mapsto_iff. - intros [a [-> hm]]. destruct a; cbn => //. - now have -> : (z + n - n) = z by lia. + split; tc. Qed. -Lemma mapsto_shift_model_inv {n m k l} : MapsTo l k m -> MapsTo l (option_map (fun k => k + n) k) (shift_model n m). +Instance opt_le_preorder {A} (R : relation A) {preo : PreOrder R}: PreOrder (opt_le R). Proof. - rewrite /shift_model LevelMapFact.F.map_mapsto_iff. - intros hm; eexists; split; trea. + split; tc. Qed. -Definition normalize_model m := shift_model (- model_min m) m. - -Lemma min_premise_None m prems : min_premise m prems = None <-> - (exists le, LevelExprSet.In le prems /\ level_value m le.1 = None). +Instance opt_le_partialorder : PartialOrder Logic.eq (opt_le Z.le). Proof. - have [hf hex] := min_premise_spec m prems. - destruct min_premise eqn:hmin. - - split => //. - move=> [[minp minpk] [hin' hl]]. - specialize (hf _ hin'). rewrite /min_atom_value hl in hf. - depelim hf. - - split => // _. - destruct hex as [[minp mink] [hin heq]]. - exists (minp, mink). split => //. rewrite /min_atom_value in heq. - destruct level_value; cbn in *; congruence. + red; split; cbn; unfold flip. + * intros ->. split; reflexivity. + * move=> [] le le'. destruct x, x0; cbn in *; depelim le; depelim le'; lia_f_equal. Qed. Instance model_rel_preorder {R : relation (option Z)} : PreOrder R -> PreOrder (model_rel R). @@ -620,384 +448,259 @@ Proof. have eq : v = k'. now apply antisymmetry. now subst k'. Qed. -Instance Z_le_partialorder : PreOrder Z.le. -Proof. - split; tc. -Qed. +Definition updates cls m m' := exists W, is_update_of cls W m m'. -Instance opt_le_preorder {A} (R : relation A) {preo : PreOrder R}: PreOrder (opt_le R). +Lemma updates_ext {cls m m'} : updates cls m m' -> m ⩽ m'. Proof. - split; tc. + now move=> [W] /is_update_of_ext. Qed. -Instance opt_le_partialorder : PartialOrder Logic.eq (opt_le Z.le). +Instance updates_proper : Proper (Clauses.Equal ==> LevelMap.Equal ==> LevelMap.Equal ==> iff) updates. Proof. - red; split; cbn; unfold flip. - * intros ->. split; reflexivity. - * move=> [] le le'. destruct x, x0; cbn in *; depelim le; depelim le'; lia_f_equal. + intros ? ? cls ? ? hm ?? hm'. unfold updates. + setoid_rewrite cls. setoid_rewrite hm. now setoid_rewrite hm'. Qed. -Lemma le_opt_lt x y z : (lt_value x y)%opt -> (y ≤ z)%opt -> lt_value x z. -Proof. - destruct x, y, z; cbn; intros hle hle'; depelim hle'; lia. -Qed. - -Lemma nlt_opt_le x y : ~ (x ≤ y)%opt -> lt_value y x. -Proof. - destruct (check_atom_value x y) eqn:ca. - - move/check_atom_value_spec: ca. contradiction. - - destruct x, y; cbn in * => //. - intros hne. red in hne. cbn in hne. lia. -Qed. - -Instance lt_irrefl : Irreflexive lt_value. -Proof. - intros []; cbn. red. unfold lt_value. unfold lt; cbn. lia. - now hnf. -Qed. +Definition minimal_above_updates cls minit m := + forall m', updates cls minit m' -> + is_model cls m' -> + updates cls m m'. -Instance le_inter_refl : Reflexive le_inter. +Lemma Some_leq x y : (Some x ≤ y)%opt -> exists y', y = Some y' /\ (x <= y')%Z. Proof. - intros x l k k' m m'. eapply LevelMapFact.F.MapsTo_fun in m; tea. subst. reflexivity. + intros h; depelim h. now eexists. Qed. -Instance le_values_refl V : Reflexive (le_values V). +Lemma not_value_above m l k : ~~ level_value_above m l k <-> opt_le Z.lt (level_value m l) (Some k). Proof. - intros x l; reflexivity. + split. + now move/negbTE/level_value_not_above_spec. + intros h; depelim h; rewrite /level_value_above. + - rewrite H0. apply/negP => /Z.leb_le. lia. + - now rewrite H. Qed. -Instance le_inter_trans V : Transitive (le_values V). +Lemma levelset_is_empty_empty : LevelSet.is_empty LevelSet.empty. Proof. - intros x y z h0 h1 l hin. transitivity (level_value y l). apply h0 => //. apply h1 => //. + eapply LevelSet.is_empty_spec. lsets. Qed. -Instance le_values_preorder V : PreOrder (le_values V). +Lemma levelset_is_empty_singleton x : LevelSet.is_empty (LevelSet.singleton x) = false. Proof. - split; tc. + rewrite levelset_not_Empty_is_empty. intros he; specialize (he x). lsets. Qed. -Definition eq_level_values V m m' := - forall l, LevelSet.In l V -> level_value m l = level_value m' l. +Lemma strictly_updates_update cls W m m' : + strictly_updates cls W m m' -> + forall prems concl k minp, + Clauses.In (prems, (concl, k)) cls -> + min_premise m prems = Some minp -> + opt_le Z.lt (level_value m concl) (Some (k + minp)) -> + (Some (k + minp) ≤ level_value m' concl)%opt -> + updates cls m (LevelMap.add concl (Some (k + minp)) m) /\ + updates cls (LevelMap.add concl (Some (k + minp)) m) m'. +Proof. + move: W m m'. apply: strictly_updates_elim. + - intros l l' h ? ? x ? ? y. subst x0 x1. + unfold updates, is_update_of. + reflexivity. + - intros m [prems [concl k]] m' hin su prems' concl' k' minp hin' eqminp lt le'. + destruct su as [z [minp' nabove]]. + move/not_value_above: nabove => nabove. + cbn. + destruct (Classes.eq_dec concl concl'). + { (* Updates the same level *) + subst concl'. + (* have eql : LevelSet.add concl (LevelSet.singleton concl) =_lset LevelSet.singleton concl. *) + (* { rsets. lsets. } *) + (* rewrite eql. *) + rewrite H. rewrite H in le'. + rewrite level_value_add in le'. depelim le'. + destruct (Z.eq_dec (k' + minp) (k + z))%Z. + { (* No real update *) + cbn in e; rewrite e. + split. + * exists (LevelSet.singleton concl). + rewrite /is_update_of levelset_is_empty_singleton. + apply (one_update (cl := (prems, (concl, k)))); tea. + cbn. exists z. split => //. + now apply/not_value_above. + * exists LevelSet.empty. + rewrite /is_update_of levelset_is_empty_empty. + reflexivity. } + { (* Real updates to compose *) + cbn in n. + have hlt : (k' + minp < k + z)%Z by lia. + clear n H0. split. + * exists (LevelSet.singleton concl). + rewrite /is_update_of levelset_is_empty_singleton. + eapply (one_update (cl := (prems', (concl, k')))). exact hin'. + cbn. exists minp. split => //. + now apply/not_value_above. + * exists (LevelSet.singleton concl). + rewrite /is_update_of levelset_is_empty_singleton. + eapply (one_update (cl := (prems, (concl, k)))). exact hin. + cbn. exists z. split => //. 2:{ apply/not_value_above. rewrite level_value_add. + constructor => //. } + have [hf hex] := min_premise_spec_aux _ _ _ minp'. + destruct hex as [[minpl minpk] [inmin eqmin]]. + unfold min_atom_value in eqmin. + destruct (level_value m minpl) as [minpv|] eqn:hl => //. noconf eqmin. + destruct (Classes.eq_dec minpl concl). subst minpl. + rewrite hl in lt. depelim lt. rewrite hl in nabove. depelim nabove. + have hk : (minpk < k)%Z by lia. + have hk' : (k' + minp - minpk = minpv - minpk). +Admitted. + (* rewrite min_premise_add_down + rewrite level_value_add. -Instance eq_level_values_equiv V : Equivalence (eq_level_values V). -Proof. - split. - - intros x l. reflexivity. - - move=> x y h l. now symmetry. - - move=> x y z h h' l. now transitivity (level_value y l). -Qed. + have [hf' hex'] := min_premise_spec_aux _ _ _ eqminp. + destruct hex' as [[minpl' minpk'] [inmin' eqmin']]. + unfold min_atom_value in eqmin'. + destruct (level_value m minpl') as [minpv'|] eqn:hl' => //. noconf eqmin'. + destruct (Classes.eq_dec minpl' concl). subst minpl'. + rewrite hl in hl'. noconf hl'. +Admitted.*) + (* rewrite hl in lt. depelim lt. rewrite hl in nabove. depelim nabove. -Instance le_values_partial_order V : PartialOrder (eq_level_values V) (le_values V). -Proof. - intros m m'. - split. - - intros hm. cbn. split. intros l hin. now rewrite hm. - red. intros l hin; now rewrite hm. - - cbn; unfold flip => -[] le le'. - red. intros l hin. move: (le l hin) (le' l hin). - apply antisymmetry. -Qed. -Definition is_smaller_model V (m m' : model) := - m ≦[V] m' /\ has_lt V m m'. + rewrite -eql. + rewrite -(union_idem cls). + rewrite LevelSetProp.add_union_singleton. + eapply strictly_updates_trans. -(* Lemma le_values_inter V m m' : le_values V m m' -> le_inter m m'. -Proof. - intros hle l k k' hm hm'. - move: (hle l). - rewrite (level_value_MapsTo hm). - now rewrite (level_value_MapsTo hm'). -Qed. *) -(* Instance model_rel_strictorder V : StrictOrder (is_smaller_model V). -Proof. - split. - - intros x. red. - unfold is_smaller_model. - move=> [eq hlt]. destruct hlt as [l [k [k' [hin [hm [hm' hlt]]]]]]. - eapply LevelMapFact.F.MapsTo_fun in hm; tea. subst. destruct k; cbn in hlt => //. lia. - - intros x y z [le [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]] [le' _]. - split. - * now transitivity y. - * red. exists l0, k0. apply le_values_inter in le. - specialize (le _ _ _ hin hm0 hm0'). - specialize (le' l0). - rewrite (level_value_MapsTo hm0') in le'. - move: le'. - case: (@level_valueP z l0). - intros k hm le'. exists k. split => //. split => //. split => //. eapply le_opt_lt; tea. - now eapply le'. - intros hnin lenon. specialize (lenon hin). - depelim lenon => //. auto. - now destruct k0 ; cbn in hlt'. -Qed. *) -(* -Definition is_smaller_model_dec V m m' : Decidable.decidable (is_smaller_model V m m'). -Proof. Admitted. -Lemma eq_values_equal V m m' : LevelMap.Equal m m' -> eq_level_values V m m'. -Proof. - move=> eqv l; move: (eqv l). - rewrite /level_value. do 2 destruct LevelMap.find => //; congruence. -Qed. - -Lemma eq_level_values_inter {V m m'} : eq_level_values V m m' -> - forall l k k', LevelSet.In l V -> LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m' -> (k = k')%opt. -Proof. - intros eq l k k' hin hm hm'. - specialize (eq l). move: eq. - rewrite (level_value_MapsTo hm) (level_value_MapsTo hm'). intros ->. reflexivity. auto. -Qed. -Print is_smaller_model. -Lemma nis_smaller_spec V m m' : ~ (is_smaller_model V m m') <-> ~ (m ≦[V] m') \/ ~ has_lt V m m'. -Proof. - rewrite /is_smaller_model. - split. - - move/Decidable.not_and => /fwd. apply dec_le_values. auto. - - intros [] []. now apply H. now apply H. -Qed. -Lemma le_lt_model V m m' : m ≦[V] m' -> ~ (is_smaller_model V m' m). -Proof. - intros le [lt li]. - eapply antisymmetry in le; tea. - move: li. change (~ has_lt V m' m). rewrite nlt_spec. - intros. - eapply eq_level_values_inter in le; tea. subst k'. - now eapply irreflexivity in H2. -Qed. + } -Lemma le_inter_has_lt V m m' : le_inter m m' <-> ~ has_lt V m' m. -Proof. - split. - - intros hinter [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]. - specialize (hinter _ _ _ hm0' hm0). - eapply le_opt_lt in hlt'; tea. - now eapply irreflexivity in hlt'. - - move/nlt_spec => hlt l k k' hm hm'. - destruct (check_atom_value_spec k k') => //. exfalso. - apply (hlt l k' k hin) => //. - now apply nlt_opt_le in H. -Qed. -Lemma nle_inter_has_lt V m m' : ~ le_inter V m m' <-> has_lt V m' m. + Admitted. *) +(* +Lemma strictly_updates_use_ext cls W m m' m0 : + strictly_updates cls W m m' -> + m ⩽ m0 -> + m0 ⩽ m' -> + updates cls m0 m'. Proof. - split. - - intros nle. rewrite le_inter_has_lt in nle. todo "decidability". - - rewrite le_inter_has_lt. auto. -Qed. + move: W m m'. + apply: (strictly_updates_elim cls). + - intros l l' h ? ? x ? ? y. subst x0 x1. + unfold updates. reflexivity. + - destruct cl as [prems [concl k]]. + move=> m' hin [minp [hmin /not_value_above habove]]. + rewrite /updates. intros h. setoid_rewrite h. + move=> ext ext'. + have := @min_premise_pres m m0 prems ext. + rewrite hmin; move/Some_leq => -[minm0] [] minp0 hle. + exists (LevelSet.singleton concl). + rewrite /is_update_of levelset_is_empty_singleton. -Lemma le_values_has_lt V m m' : le_values V m m' -> ~ has_lt V m' m. -Proof. - intros hinter [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]. - eapply le_values_inter in hinter. - specialize (hinter _ _ _ hin hm0' hm0). - eapply le_opt_lt in hlt'; tea. - now eapply irreflexivity in hlt'. -Qed. *) + /hz /Some_leq [mfconcl] [] vmconcl leq' leq. hle. -(* Lemma le_values_inter_inv V m m' : model_of V m -> le_inter V m m' -> m ≦[V] m'. -Proof. - intros mof hle l hin. - specialize (mof l hin). - specialize (hle l hin). - move: hle. - destruct (@level_valueP m l) => //. - intros hle. intros h h'. eapply LevelMapFact.F.MapsTo_fun in H; tea. subst k. - depelim hle. - eapply level_value_MapsTo' in H0. - eapply LevelMapFact.F.MapsTo_fun in H0; tea. subst k'. - now constructor. - constructor. -Qed. *) -(* -- move/nlt_spec => hlt l. k k' hm hm'. - destruct (check_atom_value_spec k k') => //. exfalso. - apply (hlt l k' k). split => //. split => //. - now apply nlt_opt_le in H. -Qed. *) -(* -Lemma contra A B : Decidable.decidable B -> (A -> ~ B) -> (~ A -> B). -Proof. - intros dec f na. - destruct dec. exact H. *) + eapply is_model_valid in ism. + specialize (ism _ hin). cbn in ism. + move/valid_clause_elim: ism. + intros hz. -Lemma nle_values_has_lt V m m' : - ~ LevelSet.Empty V -> - model_of V m -> ~ le_values V m m' -> has_lt V m' m. -Proof. - intros hne le. -Admitted. -(* -Lemma nle_ m m' : ~ m ⩽ m' <-> (LevelMap.Empty m' /\ ~ LevelMap.Empty m) \/ - has_lt m m'. -Proof. - move: m'. apply: LevelMapFact.map_induction. - - intros m' he. split. - intros hne. left; split => //. intros he'. apply hne. - have eq : m =m m'. - { rewrite LevelMapFact.F.Equal_mapsto_iff. firstorder. } - rewrite eq. reflexivity. - intros [[hem hem']|lt]. - * intros le. now apply hem' => l k /le -[k' []] /hem. - * intros hle. destruct lt as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. - now eapply he in hm0'. - - move=> m0 m1 nle l k nin hadd. split. - * intros nle'. right. red. - specialize (hle _ _ hm0) as [k' [hin']]. - eapply LevelMapFact.F.MapsTo_fun in hm0'; tea. subst k0'. *) - -Instance le_values_proper V : Proper (LevelMap.Equal ==> LevelMap.Equal ==> iff) (le_values V). -Proof. - intros ?? h ?? h'; rewrite /le_values //=. - now setoid_rewrite h; setoid_rewrite h'. Qed. -(* -Lemma nle_lt_model m m' : m ≦ m' <-> ~ has_lt m' m. -Proof. - split. - - intros hm' hlt. - destruct hlt as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. - eapply le_values_inter in hm'. - specialize (hm' l0 _ _ hm0' hm0). - have h := le_opt_lt _ _ _ hlt' hm'. now apply irreflexivity in h. - - intros nlt l. rewrite -le_inter_has_lt in nlt. - red in nlt. - - Search has_lt. *) -(* - move: m m'. apply: LevelMapFact.map_induction. - - intros m he m'. split. - intros hne. elim hne. intros l. - destruct (@level_valueP m l). now eapply he in H. constructor. - unfold has_lt. intros [l [k [k' [hm [hm' _]]]]]. - now eapply he in hm'. - - intros m m0 h x k hnin hadd m'. - apply levelmap_add_spec in hadd. - rewrite /has_lt. - split. - intros hle. setoid_rewrite hadd in hle. - destruct () - - - left; split => //. intros he'. apply hne. - have eq : m =m m'. - { rewrite LevelMapFact.F.Equal_mapsto_iff. firstorder. } - rewrite eq. reflexivity. - intros [[hem hem']|lt]. - * intros le. now apply hem' => l k /le -[k' []] /hem. - * intros hle. destruct lt as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. - now eapply he in hm0'. - - move=> m0 m1 nle l k nin hadd. split. - * intros nle'. right. red. - specialize (hle _ _ hm0) as [k' [hin']]. - - - intros nle. - destruct (dec_le_values m' m). split => //. - eapply nle_values_has_lt. in H. - apply nle_inter_has_lt. - intros lei. apply nle. - red in H, lei. intros l. specialize (H l). - destruct (@level_valueP m l). - destruct (@level_valueP m' l). - specialize (lei _ _ _ H0 H1). auto. - - Search le_inter. - eapply is_ext_le_inter in H. - eapply antisymmetry in H;. - - - destruct (is_smaller_model_dec m' m) => //. - [lt li]. - have eq : m =m m'. - now apply antisymmetry. - setoid_rewrite eq in li. - destruct li as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. - eapply LevelMapFact.F.MapsTo_fun in hm0; tea. subst. - now apply irreflexivity in hlt'. -Qed. *) - - -(* -Lemma minimal_unique cls m m' : - minimal cls m -> is_model cls m -> minimal cls m' -> is_model cls m' -> (normalize_model m) ⩽ (normalize_model m'). -Proof. - intros min ism. - rewrite minimal_forall in min. - intros min' ism'. - rewrite minimal_forall in min'. - specialize (min _ ism'). - specialize (min' _ ism). - destruct (is_smaller_model_dec (normalize_model m) (normalize_model m')). apply H. - assert (sirr := irreflexivity (R := is_smaller_model) (normalize_model m)). - - destruct (dec_ext (normalize_model m) (normalize_model m')) => //. -Qed. *) -Print has_lt. -Lemma nle_values V m m' : - ~ LevelSet.Empty V -> - model_of V m -> - ~ (le_values V m m') -> - exists l, LevelSet.In l V /\ lt_value (level_value m' l) (level_value m l). +Lemma minimal_above_updates_updates cls W m m' : + strictly_updates cls W m m' -> + minimal_above_updates cls m m'. Proof. - intros hne mof leq. - have := (nle_values_has_lt V m m' hne mof leq). - intros [l [k [k' []]]]. destruct H0 as [? []]. - exists l; split => //. - now rewrite (level_value_MapsTo H0) (level_value_MapsTo H1). + move: W m m'. + apply: (strictly_updates_elim cls). + - intros l l' h ? ? x ? ? y. subst x0 x1. + unfold minimal_above_updates. reflexivity. + - destruct cl as [prems [concl k]]. + move=> m' hin [minp [hmin habove]]. + rewrite /minimal_above_updates. intros h. setoid_rewrite h. + move=> mf ext ism. + eapply is_model_valid in ism. + specialize (ism _ hin). cbn in ism. + move/valid_clause_elim: ism. + intros hz. + have := @min_premise_pres m mf prems (updates_ext ext). + rewrite hmin. move/Some_leq => -[minmf] [] /hz /Some_leq [mfconcl] [] vmconcl leq' leq. + destruct ext as [W ext]. + exists (LevelSet.add concl W). red. + destruct LevelSet.is_empty eqn:ise. + { exfalso. eapply LevelSet.is_empty_spec in ise. apply (ise concl). lsets. } + move/is_update_of_case: ext => -[[emp eq]|su]. + { exfalso. move: vmconcl habove. rewrite -eq. + move=> hl /not_value_above. rewrite hl => hlt. + depelim hlt. lia. } + { move/not_value_above: habove => hlt. + (* The conclusion is higher in mf. *) + todo "commutation". } + (* eapply strictly_updates_update; tea. *) + + + (* rewrite vmconcl. constructor. lia. } *) + - intros * su ma su' ma'. + intros mf extinit ism. + move: (ma mf extinit ism) => hext. + exact (ma' mf hext ism). Qed. -(* Lemma minimal_le cls m m' : - minimal cls m -> is_model cls m' -> model_of (clauses_levels cls) m' -> - model_of (clauses_levels cls) m -> - is_smaller_model (clauses_levels cls) (normalize_model m) (normalize_model m'). -Proof. - intros nex ism mof mof'. - rewrite minimal_forall in nex. - specialize (nex _ ism). - destruct (is_smaller_model_dec (clauses_levels cls) (normalize_model m) (normalize_model m')) => //. -Abort. *) +Lemma updates_extends {cls m m'} : updates cls m m' -> m ⩽ m'. +Admitted. +(* Lemma minimal_above_valid cls minit m : + minimal_above_updates cls minit m -> + updates cls minit m -> + forall cl, valid_clause m cl -> + forall m', updates cls m m' -> is_model cls m' -> valid_clause m' cl. +Proof. + intros hmin hupd [prems [concl k]]. + move/valid_clause_elim => hz m' ext ism. + unfold valid_clause. cbn. + destruct (min_premise m' prems) eqn:hminp => //. + specialize (hmin m' ext ism). + destruct (min_premise m prems) eqn:hl. + specialize (hz _ eq_refl). + have minp := min_premise_pres prems (updates_extends hmin). + rewrite hl in minp. rewrite hminp in minp. depelim minp. + depelim hz. rewrite /level_value_above. + have mle := model_le_values concl (updates_extends hmin). + rewrite H0 in mle. depelim mle. rewrite H3. apply Z.leb_le. + specialize (min' m). + Search level_value. + Search valid_clause. *) -(* Lemma minimal_forall cls cls' m : minimal cls cls' m <-> - forall m', is_model cls m' -> is_smaller_model (clauses_levels cls) (normalize_model m') (normalize_model m) -> False. -Proof. - split. - - intros hmin m' ism issm. apply hmin. exists m'. split => //. - - intros hm' [m' [issm ism]]. apply (hm' m' ism issm). -Qed. *) +Definition minimal_above cls minit m := + forall m', minit ⩽ m' -> is_model cls m' -> m ⩽ m'. -(* Lemma minimal_mapsto cls m m' : - minimal cls cls' m -> is_model cls m' -> is_smaller_model (clauses_levels cls) (normalize_model m') (normalize_model m) -> False. + +(* +Lemma minimal_above_valid cls minit m : minimal_above cls minit m -> + forall cl, valid_clause m cl -> forall m', minit ⩽ m' -> is_model cls m' -> + minimal_above cls minit m' -> valid_clause m' cl. Proof. - intros nex ism. - rewrite minimal_forall in nex. - now specialize (nex _ ism). -Qed. *) + intros hmin [prems [concl k]]. + move/valid_clause_elim => hz m' ext ism min'. + unfold valid_clause. cbn. + destruct (min_premise m' prems) eqn:hminp => //. + red in hmin. specialize (hmin _ ext ism). + destruct (min_premise m prems) eqn:hl. + specialize (hz _ eq_refl). + have minp := min_premise_pres prems hmin. + rewrite hl in minp. rewrite hminp in minp. depelim minp. + depelim hz. rewrite /level_value_above. + have mle := model_le_values concl hmin. + rewrite H0 in mle. depelim mle. rewrite H3. apply Z.leb_le. + specialize (min' m). + Search level_value. + Search valid_clause. *) -(* Lemma minimal_model_unique cls minit m m' : - minimal_above minit cls m -> minimal_above minit cls m' -> is_model cls m -> is_model cls m' -> - normalize_model m =m normalize_model m'. -Abort. *) -Lemma model_of_level_value {V m} l : - model_of V m -> - LevelSet.In l V -> - exists k, LevelMap.MapsTo l k m /\ level_value m l = k. -Proof. - intros mof hin. - specialize (mof l hin). - destruct mof as [k hin']. exists k. split => //. - now rewrite (level_value_MapsTo hin'). -Qed. +Definition check_init_model cls cl := + (premises_model (clauses_levels cls) cl).2. -Definition minimal_above cls minit m := - forall m', minit ⩽ m' -> is_model cls m' -> m ⩽ m'. Lemma minimal_above_refl cls m : minimal_above cls m m. Proof. @@ -1005,9 +708,12 @@ Proof. now intros m'. Qed. -Lemma Some_leq x y : (Some x ≤ y)%opt -> exists y', y = Some y' /\ (x <= y')%Z. +Lemma minimal_above_trans cls m m' m'' : minimal_above cls m m' -> minimal_above cls m' m'' -> + minimal_above cls m m''. Proof. - intros h; depelim h. now eexists. + red. intros min min' m0 ext hin. + red in min. specialize (min _ ext hin). + exact (min' m0 min hin). Qed. Lemma strictly_updates_minimal_above cls W m m' : @@ -1020,7 +726,7 @@ Proof. unfold minimal_above. reflexivity. - destruct cl as [prems [concl k]]. move=> m' hin [minp [hmin habove]]. - rewrite /minimal_above. intros h; setoid_rewrite h. + rewrite /minimal_above. intros h. setoid_rewrite h. move=> mf ext ism. eapply is_model_valid in ism. specialize (ism _ hin). cbn in ism. @@ -1033,12 +739,10 @@ Proof. constructor. lia. * now apply ext. - intros * su ma su' ma'. - intros mf extinit ism. - move: (ma mf extinit ism) => hext. - exact (ma' mf hext ism). + now eapply minimal_above_trans; tea. Qed. -Lemma is_update_of_minimal_above cls W m m' : +Lemma is_update_of_minimal_above {cls W m m'} : is_update_of cls W m m' -> minimal_above cls m m'. Proof. @@ -1047,43 +751,171 @@ Proof. - now eapply strictly_updates_minimal_above. Qed. +Theorem check_invalid {cls cl m} : + check_gen cls cl = Invalid m -> + [/\ is_model cls m, + model_of (clauses_levels cls ∪ clause_levels cl) m, + minimal_above cls (check_init_model cls cl) m, + enabled_clause m cl & ~ valid_clause m cl]. +Proof. + funelim (check_gen cls cl) => //. + clear H H0 he. + set (V := (clause_levels cl ∪ clauses_levels cls)%levels) in *. + destruct cl as [prems [concl k]]. + rename val into conclval_v => [=] eq. subst m. + clear Heqcall prf. + move: (check_atom_value_spec (Some k) conclval_v). rewrite Heq. + intros r; depelim r. rename H into nent. + have vmupd := model_updates v. + have vmok := model_ok v. + set (pm := premises_model_map _ _) in *. + set (cl := (prems, _)) in V. + have nepm : defined_map pm. + { apply premises_model_map_defined. + move/(_ cl). rewrite Clauses.singleton_spec /cl. congruence. } + have nev : defined_map (model_model v). + by apply (is_update_of_defined_map nepm vmupd). + move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. + have en : enabled_clause (model_model v) cl. + { apply (@enabled_clause_ext pm). + exact: is_update_of_ext (model_updates v). + red; cbn. + have hcl : Clauses.In cl (Clauses.singleton cl). + { now eapply Clauses.singleton_spec. } + have hs:= @premises_model_map_min_premise_inv V _ _ hcl. firstorder. } + split => //. + { have hv := model_of_V v. clear -hv. + subst V. cbn. now rewrite LevelSetProp.union_sym. + } + { eapply (is_update_of_minimal_above (model_updates v)). } + destruct en as [z minp]. + move/valid_clause_elim/(_ z minp). + cbn in minp. + cbn in he'. + rewrite /level_value he' => h; depelim h. apply nent. + constructor. cbn -[check_atom_value] in Heq. + have posz : 0 <= z. + { have hsu := model_updates v. + eapply is_update_of_ext in hsu. + have hs := min_premise_pres prems hsu. + rewrite minp in hs. + have hmin := @premises_model_map_min_premise_inv V (Clauses.singleton cl) cl. + forward hmin. now apply Clauses.singleton_spec. + destruct hmin as [minp' [hmineq hpos]]. + rewrite hmineq in hs. depelim hs. lia. } + lia. +Qed. + +Lemma valid_clause_satisfies m prems concl : valid_clause m (prems, concl) <-> + min_premise m prems = None \/ + (exists z, min_premise m prems = Some z /\ satisfiable_atom m (add_expr z concl)). +Proof. + destruct concl as [concl k]. + split. + - move/valid_clause_elim. intros hz. + destruct min_premise => //. right. specialize (hz _ eq_refl). depelim hz. + eexists; split; trea. unfold satisfiable_atom. cbn. rewrite H0. apply Z.leb_le. lia. + now left. + - intros disj; apply valid_clause_intro. + intros z hz. + destruct disj. congruence. destruct H as [z0 [hmin hsat]]. + rewrite hmin in hz; noconf hz. + cbn in hsat. destruct level_value => //. constructor. apply Z.leb_le in hsat. lia. +Qed. + +Definition inverse_clauses (cl : clause) := + let (prems, concl) := cl in + clauses_of_le (succ_prems prems) (singleton concl). + +Definition normalize m k := + option_map (fun k => k - model_min m) k. + +Definition le_inter m m' := + (forall l k k', LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m' -> (k ≤ k')%opt). + +Lemma is_ext_le_inter m m' : + (m ⩽ m') -> le_inter m m'. +Proof. + move=> hext l k k' /hext [] x [] hm0 hle hm1. + eapply LevelMapFact.F.MapsTo_fun in hm0; tea. now subst. +Qed. + +Import LevelMap (MapsTo). + +Lemma mapsto_shift_model {n m k l} : MapsTo l k (shift_model n m) -> MapsTo l (option_map (fun k => k - n) k) m. +Proof. + rewrite /shift_model LevelMapFact.F.map_mapsto_iff. + intros [a [-> hm]]. destruct a; cbn => //. + now have -> : (z + n - n) = z by lia. +Qed. + +Lemma mapsto_shift_model_inv {n m k l} : MapsTo l k m -> MapsTo l (option_map (fun k => k + n) k) (shift_model n m). +Proof. + rewrite /shift_model LevelMapFact.F.map_mapsto_iff. + intros hm; eexists; split; trea. +Qed. + +Definition normalize_model m := shift_model (- model_min m) m. + +Lemma min_premise_None m prems : min_premise m prems = None <-> + (exists le, LevelExprSet.In le prems /\ level_value m le.1 = None). +Proof. + have [hf hex] := min_premise_spec m prems. + destruct min_premise eqn:hmin. + - split => //. + move=> [[minp minpk] [hin' hl]]. + specialize (hf _ hin'). rewrite /min_atom_value hl in hf. + depelim hf. + - split => // _. + destruct hex as [[minp mink] [hin heq]]. + exists (minp, mink). split => //. rewrite /min_atom_value in heq. + destruct level_value; cbn in *; congruence. +Qed. + + +Lemma model_of_level_value {V m} l : + model_of V m -> + LevelSet.In l V -> + exists k, LevelMap.MapsTo l k m /\ level_value m l = k. +Proof. + intros mof hin. + specialize (mof l hin). + destruct mof as [k hin']. exists k. split => //. + now rewrite (level_value_MapsTo hin'). +Qed. + + Hint Rewrite clause_levels_spec levels_spec : set_specs'. Lemma nge_lt x y : (~ x <= y) -> y < x. Proof. intros n. unfold lt; cbn. lia. Qed. -Definition check_init_model cls cl := - (premises_model (clauses_levels cls) cl).2. - -Theorem check_invalid_allm {cls cl} : - check_gen cls cl = Invalid -> - forall minit m, is_model cls m -> - minimal_above cls minit m -> +Theorem check_invalid_allm {cls cl mcheck} : + check_gen cls cl = Invalid mcheck -> + let minit := check_init_model cls cl in + forall m, is_model cls m -> + minimal_above cls mcheck m -> + (* (level_value m (concl cl).1 ≤ level_value mcheck (concl cl).1)%opt -> *) model_of (clauses_levels cls ∪ clause_levels cl) m -> minit ⩽ m -> valid_clause m cl -> False. Proof. - move/check_invalid => [m [ism encl invcl]]. + move/check_invalid => [ism mofm minm encl invcl]. intros minit m' ism' minm' mof. - have mofm : model_of (clauses_levels cls ∪ clause_levels cl) m. - todo "model of". - have minm : minimal_above cls minit m. - { todo "minimal infered". } - have pmodelm : minit ⩽ m. todo "ext inferred". + have pmodelm : minit ⩽ mcheck. todo "ext inferred". intros ext' vm'. - specialize (minm m' ext' ism'). destruct cl as [prems concl]. rewrite valid_clause_satisfies in invcl. red in encl. destruct encl as [minp eqminp]. rewrite eqminp in invcl. - have nsat : ~ satisfiable_atom m (add_expr minp concl). + have nsat : ~ satisfiable_atom mcheck (add_expr minp concl). { intros s; elim invcl. right. eexists; split; trea. } clear invcl. cbn in eqminp. have [minmf [[minpl minpk] [hin heq]]] := min_premise_spec_aux _ _ _ eqminp. - cbn in heq. destruct (level_value m minpl) as [minpmv|] => //. noconf heq. + cbn in heq. destruct (level_value mcheck minpl) as [minpmv|] => //. noconf heq. destruct concl as [concl k]. - have hpres : (min_premise m prems ≤ min_premise m' prems)%opt. + have hpres : (min_premise mcheck prems ≤ min_premise m' prems)%opt. { now eapply min_premise_pres. } rewrite eqminp in hpres. depelim hpres. rename y into minpm'. rename H into minpm'minpm. @@ -1097,14 +929,16 @@ Proof. destruct (model_of_level_value concl mofm) as [conclv [hm hl]]. { repeat (autorewrite with set_specs set_specs'; cbn). now right. } eapply level_value_MapsTo' in conclm'. - move: (minm' m pmodelm ism). move/is_ext_le_inter => /(_ concl _ _ conclm' hm) - /check_atom_value_spec //=. - destruct conclv as [conclv|] => //. move/Z.leb_le => concllt. - rewrite hl in nsat. move/Z.leb_le in nsat. - have hmconcl : (conclv < minpmv - minpk + k)%Z by lia. - move/is_ext_le_inter: minm => /(_ concl _ _ hm conclm') /check_atom_value_spec //=. - move/Z.leb_le. lia. + rewrite hl in nsat. + move:(minm' mcheck) => /fwd. reflexivity. + move/(_ ism). move/is_ext_le_inter/(_ concl _ _ conclm' hm) => /check_atom_value_spec //=. + move/negP: nsat. + destruct conclv as [conclv|]. + case: Z.leb_spec => //= hlt _ /Z.leb_le. lia. + auto. Qed. + + (* Lemma check_invalid_allm_zero {cls cl} : check_gen cls cl = Invalid -> @@ -1116,10 +950,10 @@ Lemma check_invalid_allm_zero {cls cl} : Proof. *) -Lemma check_invalid_entails {cls cl} : - check_gen cls cl = Invalid -> ~ entails cls cl. +Lemma check_invalid_entails {cls cl m} : + check_gen cls cl = Invalid m -> ~ entails cls cl. Proof. - move/check_invalid => [m [ism en nv]]. + move/check_invalid => [ism mof mabove en nv]. now move/entails_model_valid/(_ m ism). Qed. @@ -2149,13 +1983,17 @@ Lemma opt_valuation_of_model_equiv m l : + move/H0 => [k' [hm [hle hle']]]. eexists; split; tea. lia. } Qed. - Lemma opt_valuation_enables m : enables_clauses (opt_valuation m) (clauses m). + Lemma model_enabled m : enabled_clauses (model m) (clauses m). Proof. have hen := enabled_model m. have hupd := I.model_updates m.(model_valid). eapply is_update_of_ext in hupd. eapply enabled_clauses_ext in hen; tea. - move: hen. + Qed. + + Lemma opt_valuation_enables m : enables_clauses (opt_valuation m) (clauses m). + Proof. + move: (model_enabled m). cbn. rewrite /opt_valuation /opt_valuation_of_model /model /model_of. generalize (model_model (model_valid m)). generalize (clauses m). @@ -2360,8 +2198,8 @@ Lemma opt_valuation_of_model_equiv m l : rewrite clauses_sem_eq //= interp_add_prems //=. lia. Qed. - Definition inconsistent_clause_ext m cl := - forall v : Level.t -> Z, positive_valuation v -> clauses_sem v (clauses m) -> ~ clause_sem v cl. + Definition inconsistent_ext_Z m cls := + forall v : Level.t -> Z, positive_valuation v -> clauses_sem v (clauses m) -> ~ clauses_sem v cls. Definition inconsistent_ext m cls := forall v : Level.t -> option Z, positive_opt_valuation v -> clauses_sem v (clauses m) -> ~ clauses_sem v cls. @@ -2502,23 +2340,23 @@ Lemma opt_valuation_of_model_equiv m l : Definition clause_premises_levels cl := NES.levels (premise cl). - Theorem check_invalid_valuation {cls cl} : - check_gen cls cl = Invalid -> - exists v : Level.t -> option Z, + Theorem check_invalid_valuation {cls cl m} : + check_gen cls cl = Invalid m -> + let v := opt_valuation_of_model m in [/\ positive_opt_valuation v, clauses_sem v cls, defined_valuation_of (clause_premises_levels cl) v & ~ clause_sem v cl]. Proof. - move/check_invalid=> [m' [ism en inval]]. + move/check_invalid=> [ism _ _ en inval]. have hpos := opt_valuation_of_model_pos. have semcls := valid_clauses_model_opt _ _ ism. - exists (opt_valuation_of_model m'). split => //. + split => //. { intros l. move: en; rewrite /enabled_clause => -[z hmin]. eapply min_premise_spec_aux in hmin as [hf _]. rewrite /clause_premises_levels NES.levels_spec. move=> [] k /hf. intros le; depelim le. move: H0. rewrite /opt_valuation_of_model /level_value. - case: (find_spec l m') => //; destruct k0 => //. + case: (find_spec l m) => //; destruct k0 => //. move=> hmf [= eq]. subst y. now eexists. } { move/clause_sem_valid. contradiction. } Qed. @@ -2592,9 +2430,7 @@ Lemma opt_valuation_of_model_equiv m l : Qed. Lemma entails_dec (m : t) cl : - { entails (clauses m) cl } + { ~ entails (clauses m) cl /\ - exists v : Level.t -> option Z, - [/\ positive_opt_valuation v, clauses_sem v (clauses m), defined_valuation_of (clause_premises_levels cl) v & ~ clause_sem v cl] }. + { entails (clauses m) cl } + { ~ entails (clauses m) cl }. Proof. destruct (check_gen (clauses m) cl) eqn:ch. - move/check_looping: ch; elim. @@ -2604,8 +2440,7 @@ Lemma opt_valuation_of_model_equiv m l : eapply defined_model_of_subset; tea. apply clauses_levels_declared. } exact: is_model_of m. - - have ci := check_invalid_valuation ch. - move/check_invalid_entails: ch. intros ne. right. split => //. + - move/check_invalid_entails: ch. intros ne. now right. - move/check_gen_entails: ch. now left. Qed. @@ -2793,7 +2628,7 @@ Definition check_genb cls cl := match check_gen cls cl with | IsLooping _ _ _ => false | Valid => true - | Invalid => false + | Invalid _ => false end. Lemma check_gen_model_looping m cl v vcls isl : @@ -2820,22 +2655,23 @@ Proof. Qed. Lemma check_gen_model m cl : - check_genb (clauses m) cl <-> (forall m', is_model (clauses m) m' -> valid_clause m' cl). + check_genb (clauses m) cl <-> (forall m', is_model (clauses m) m' -> enabled_clause m' cl -> valid_clause m' cl). Proof. unfold check_genb. destruct (check_gen) eqn:ec. - now move/check_gen_model_looping: ec. - split => //. move/check_invalid: ec. - intros [m' []]. move/(_ m' H). contradiction. + intros [ism mof hmin en inval]. move/(_ m0 ism en). contradiction. - split => // _. intros m' ism. move/check_gen_entails: ec => ent. + intros _. eapply entails_model_valid; tea. Qed. Definition valid_model_clause m cl := - (forall m', is_model (clauses m) m' -> valid_clause m' cl). + (forall m', is_model (clauses m) m' -> enabled_clause m' cl -> valid_clause m' cl). Lemma entails_models m cl : entails (clauses m) cl <-> valid_model_clause m cl. Proof. @@ -2847,7 +2683,7 @@ Definition valid_all_model_clauses m cls := Definition valid_model_clauses m cls := (forall m', is_model (clauses m) m' -> - forall cl, Clauses.In cl cls -> valid_clause m' cl). + forall cl, Clauses.In cl cls -> enabled_clause m' cl -> valid_clause m' cl). Lemma entails_all_models m cls : clauses m ⊢ℋ cls -> valid_all_model_clauses m cls. Proof. @@ -2905,7 +2741,7 @@ Proof. intros [m' []]; exfalso. eapply entails_model_valid in ent; tea. contradiction. - clear H H0. symmetry in Heqcall. split => //. - now move/check_invalid: Heqcall => ent. + move/check_invalid: Heqcall => -[]. now eexists; split => //. Qed. Lemma negb_iff (b : bool) : ~ b <-> ~~ b. @@ -2925,6 +2761,69 @@ Definition check_clause m cl := Definition consistent_clauses cls := exists val : Level.t -> Z, positive_valuation val /\ clauses_sem val cls. + +Definition is_enabled_clause m cl := + isSome (min_premise m (premise cl)). + +Lemma reflect_enabled m cl : reflect (enabled_clause m cl) (is_enabled_clause m cl). +Proof. + rewrite /is_enabled_clause /enabled_clause. + destruct min_premise => //=. + constructor; now eexists. + constructor. intros [z eq] => //. +Qed. + +Definition split_clauses m cls := + Clauses.partition (is_enabled_clause m) cls. + +Definition enabled_clauses m cls := (split_clauses m cls).1. +Definition disabled_clauses m cls := (split_clauses m cls).2. + +Lemma split_clauses_spec_1 m cls : + cls =_clset Clauses.union (enabled_clauses m cls) (disabled_clauses m cls). +Proof. Admitted. + +Lemma enabled_clauses_spec m cl cls : Clauses.In cl (enabled_clauses m cls) <-> Clauses.In cl cls /\ enabled_clause m cl. +Admitted. + +Lemma disabled_clauses_spec m cl cls : Clauses.In cl (disabled_clauses m cls) <-> Clauses.In cl cls /\ ~ enabled_clause m cl. +Admitted. + +Lemma nenabled_clause m cl : ~ enabled_clause m cl <-> min_premise m (premise cl) = None. +Proof. + case: (reflect_enabled m cl) => //. + split => //. red in p. firstorder. congruence. + firstorder. cbn in H. destruct min_premise => //. + destruct (H _ eq_refl). +Qed. + +Definition is_total_model m cls := + Model.enabled_clauses m cls /\ is_model cls m. + +Lemma is_model_split m cls : + is_model cls m <-> (is_total_model m (enabled_clauses m cls)). +Proof. + split. + - move/Clauses.for_all_spec => ism. + split. + intros cl. now rewrite enabled_clauses_spec. tc. + apply Clauses.for_all_spec. tc. + move=> cl /enabled_clauses_spec => -[] /ism //. + - move=> -[]. intros en. red in en. red in en. + intros ism. rewrite (split_clauses_spec_1 m cls). + eapply is_model_union. auto. + eapply Clauses.for_all_spec. tc. + move=> [prems [concl k]] /disabled_clauses_spec -[] hin hen. + Search enabled_clause. + apply valid_clause_intro. + now move/nenabled_clause: hen => ->. +Qed. + +Lemma equiv_all_models cls cl : + (forall m, is_model cls m -> enabled_clause m cl -> valid_clause m cl) <-> + (forall m, is_total_model m (enabled_clauses m cls) -> enabled_clause m cl -> valid_clause m cl). +Proof. now setoid_rewrite is_model_split. Qed. + (* Lemma consistent_dec m cl : clause_levels cl ⊂_lset levels m -> @@ -2987,29 +2886,43 @@ Proof. move=> //. Qed. +Print valid_clause. Definition valid_clause_Z cls cl := forall v : Level.t -> Z, positive_valuation v -> clauses_sem v cls -> clause_sem v cl. +Lemma valid_clause_Z_weaken cls cls' cl : + Clauses.Subset cls' cls -> valid_clause_Z cls' cl -> valid_clause_Z cls cl. +Proof. + intros hsub vc v pos csem. apply vc; tea. eapply clauses_sem_subset; tea. +Qed. + +Definition nvalid_clause_Z cls cl := + exists v : Level.t -> Z, positive_valuation v /\ clauses_sem v cls /\ ~ clause_sem v cl. + +Lemma valid_clause_Z_invalid cls cl : nvalid_clause_Z cls cl -> ~ valid_clause_Z cls cl. +Proof. + unfold valid_clause_Z, nvalid_clause_Z; firstorder. +Qed. -Lemma check_clause_invalid_valid_Z m cl : +(*Lemma check_clause_invalid_valid_Z m mcheck cl : clause_levels cl ⊂_lset (levels m) -> - check_gen (clauses m) cl = Invalid -> ~ valid_clause_Z (clauses m) cl. + check_gen (clauses m) cl = Invalid mcheck -> ~ valid_clause_Z (clauses m) cl. Proof. move=> hwf. unfold check_clause. move/check_invalid_allm => /(_ (model m) (model_ok (model_valid m))). - set (minit := check_init_model _ _). move=> /fwd. - { have minimal := model_minimal m. - red. red in minimal. - move=> m' initle ism. eapply minimal. - admit. exact ism. } + { (* This means the conclusion's level in the inital model to check should + be set at least as high as in the current clauses. This should follow + from minimality. *) + red. + todo "level of conclusion". } move=> /fwd. - { move=> k hin. have he := model_levels m k. admit. } + { red. todo "scope, easy". } move=> /fwd. - { admit. } + { todo "check_init_model <= model m, to investigate". } move=> invalidc vc. apply invalidc. red in vc. move: (vc (Z_valuation_of_model m)) => /fwd. eapply valuation_of_model_pos. @@ -3017,22 +2930,50 @@ Proof. rewrite def_clause_sem_valid //. { eapply defined_model_of_subset; tea. eapply defined_model. } -Qed. +Qed.*) +Search entails. +(* +Lemma check_clause_invalid_valid_Z m cl mcheck : + clause_levels cl ⊂_lset (levels m) -> + check_gen (clauses m) cl = Invalid mcheck -> ~ valid_clause_Z (clauses m) cl. +Proof. + move=> hwf. + unfold check_clause. + move/check_invalid_allm => /(_ (model m) (model_ok (model_valid m))). + move=> /fwd. + { (* This means the conclusion's level in the inital model to check should + be set at least as high as in the current clauses. This should follow + from minimality. *) + todo "level of conclusion". } + move=> /fwd. + { red. todo "scope, easy". } + move=> /fwd. + { todo "check_init_model <= model m, to investigate". } + move=> invalidc vc. apply invalidc. + red in vc. move: (vc (Z_valuation_of_model m)) => /fwd. + eapply valuation_of_model_pos. + move/(_ (model_valuation m)). + rewrite def_clause_sem_valid //. + { eapply defined_model_of_subset; tea. + eapply defined_model. } +Qed.*) Lemma check_clause_valid_Z m cl : - check_clause m cl <-> valid_clause_Z (clauses m) cl. + check_clause m cl -> valid_clause_Z (clauses m) cl. Proof. unfold check_clause. - split. - - rewrite checkb_entails. - move=> ent v posv csem. - apply entails_completeness in ent. - red in ent. - move: {ent}(ent Z _ v csem). - destruct cl as [prems [concl k]]. - rewrite //= !interp_nes_union interp_nes_singleton //= /interp_expr //=. - lia. + rewrite checkb_entails. + move=> ent v posv csem. + apply entails_completeness in ent. + red in ent. + move: {ent}(ent Z _ v csem). + destruct cl as [prems [concl k]]. + rewrite //= !interp_nes_union interp_nes_singleton //= /interp_expr //=. + lia. +Qed. + +(* - intros vc. destruct (check_genb) eqn:ec => //. apply (ssrbool.introT (@negPf _)) in ec. @@ -3091,64 +3032,61 @@ Search (_ = false). destruct (eq) intros S. Qed. +*) +Definition check_clauses (cls : Clauses.t) (cls' : Clauses.t) : bool := + Clauses.for_all (check_genb cls) cls'. -Lemma check_entails m cl : - check (clauses m) cl <-> entails (clauses m) cl. -Proof. - unfold check. - destruct (check_clause) eqn:ec. - - now move/check_clause_looping: ec. - - split => //. unfold check_clause in ec. - move/check_invalid_entails: ec. - intros ne ent. - exfalso; apply ne. - destruct cl as [prems [concl k]]; cbn. - now eapply entails_weak_union. - - unfold check_clause in ec. - move/check_gen_entails: ec. - intros ent; split => // _. - destruct cl as [prems [concl k]]; cbn in *. - Search entails. - now eapply entails_weak_union. - +Definition consistent_clauses_model cls := + exists m, Model.enabled_clauses m cls /\ is_model cls m. +Lemma consistent_model m : consistent_clauses_model (clauses m). +Proof. + exists (model m). split. + eapply model_enabled. + apply model_ok. Qed. -Definition check_clauses (cls : Clauses.t) (cls' : Clauses.t) : bool := - Clauses.for_all (check cls) cls'. - -Lemma check_clauses_spec cls cls' : +Lemma check_clauses_gen_spec cls cls' : + consistent_clauses_model cls -> check_clauses cls cls' <-> entails_clauses cls cls'. Proof. - split. - - rewrite /check_clauses /Deciders.check_clauses. - move/Clauses.for_all_spec => ha cl /ha. unfold checkb. - destruct check_clause eqn:ch => // _. - eapply check_gen_entails in ch. now apply ch. - - intros hv. - rewrite /check_clauses /Deciders.check_clauses. - eapply Clauses.for_all_spec; tc => cl hin. - unfold checkb; destruct check eqn:hc => //. - * exfalso; eapply check_entails_looping in hc; tea. - now apply model_entails_succ in hc. - * move/check_invalid_entails: hc => he. - exfalso. elim he. now apply hv. - Qed. + intros hcon. + split. + - rewrite /check_clauses. + move/Clauses.for_all_spec => ha cl /ha. + unfold check_genb; destruct check_gen eqn:hc => //. + now move/check_gen_entails: hc. + - intros hv. + rewrite /check_clauses /check_genb. + eapply Clauses.for_all_spec; tc => cl hin. + destruct check_gen eqn:hc => //. + * exfalso. destruct hcon as [m [en ism]]. + eapply check_gen_entails_looping in hc; tea. + eapply model_entails_succ in hc; tea. + * move/check_invalid_entails: hc => he. + exfalso. elim he. now apply hv. +Qed. + +Definition check_model_clauses m cls := + check_clauses (clauses m) cls. + +Lemma check_model_clauses_entails m cls : + check_model_clauses m cls <-> entails_clauses (clauses m) cls. +Proof. + rewrite check_clauses_gen_spec //. + apply consistent_model. +Qed. Theorem check_spec m cl : clause_levels cl ⊂_lset levels m -> - check (clauses m) cl <-> valid_clause_Z (clauses m) cl. + check_clause m cl -> valid_clause_Z (clauses m) cl. Proof. - unfold check. - destruct check_clause eqn:he; split => //. - - now move/check_clause_looping: he. - - now move/check_clause_invalid_valid_Z: he => /(_ H). - - now move/check_clause_valid_Z: he. + move=> hwf; apply check_clause_valid_Z. Qed. -Lemma check_neg_spec m cl : +(* Lemma check_neg_spec m cl : clause_levels cl ⊂_lset levels m -> check (clauses m) cl = false <-> ~ valid_clause_Z (clauses m) cl. Proof. @@ -3157,22 +3095,17 @@ Proof. - now move/check_clause_looping: he. - now move/check_clause_invalid_valid_Z: he => /(_ H). - now move/check_clause_valid_Z: he. -Qed. +Qed. *) Definition valid_clauses cls cls' := forall v : Level.t -> option Z, positive_opt_valuation v -> clauses_sem v cls -> clauses_sem v cls'. - - Definition check_clauses m cls := - check_clauses (clauses m) cls. - - Lemma check_clauses_complete m cls : - check_clauses m cls <-> valid_entailments (clauses m) cls. + check_model_clauses m cls <-> valid_entailments (clauses m) cls. Proof. - rewrite check_clauses_spec. + rewrite check_model_clauses_entails. rewrite -entails_L_entails_ℋ_equiv. rewrite -entails_L_rels_entails_L_clauses. rewrite -completeness_all. @@ -3186,10 +3119,10 @@ Qed. Qed. Lemma check_clauses_Z_positive_complete m cls : - check_clauses m cls <-> valid_clauses (clauses m) cls. + check_model_clauses m cls <-> valid_clauses (clauses m) cls. Proof. split. - - rewrite check_clauses_spec. + - rewrite check_model_clauses_entails. rewrite -entails_L_entails_ℋ_equiv. rewrite -entails_L_rels_entails_L_clauses. rewrite -completeness_all. @@ -3197,31 +3130,32 @@ Qed. red in vr. move: (vr (option Z) Zopt_semi v). rewrite !interp_rels_clauses_sem //. - - intros sem. unfold check_clauses, Deciders.check_clauses. + - intros sem. unfold check_model_clauses. eapply Clauses.for_all_spec. tc. move=> cl /sem => semcl. - unfold checkb; destruct check eqn:hc => //. - * move/check_entails_looping : hc. + unfold check_genb. + destruct check_gen eqn:hc => //. + * move/check_gen_entails_looping : hc. rewrite -to_entails_all. rewrite -entails_L_entails_ℋ_equiv. rewrite -entails_L_rels_entails_L_clauses. rewrite -ISL.completeness_all. - move/(_ Z _ (valuation_of_model m)). + move/(_ Z _ (Z_valuation_of_model m)). rewrite -interp_rels_clauses_sem. move/(_ (model_valuation m)). rewrite -interp_rels_clauses_sem. rewrite clauses_sem_leq. cbn. rewrite interp_add_prems //=. lia. * move/check_invalid_valuation: hc. - move=> [v [hpos semcls def ncl]]. specialize (semcl v hpos semcls). + move=> [hpos semcls def ncl]. specialize (semcl _ hpos semcls). now elim ncl. Qed. Lemma check_clauses_Z_complete m cls : - check_clauses m cls <-> valid_semilattice_entailments Zopt_semi (clauses m) cls. + check_model_clauses m cls <-> valid_semilattice_entailments Zopt_semi (clauses m) cls. Proof. split. - - rewrite check_clauses_spec. + - rewrite check_model_clauses_entails. rewrite -entails_L_entails_ℋ_equiv. rewrite -entails_L_rels_entails_L_clauses. rewrite -completeness_all. @@ -3229,23 +3163,23 @@ Qed. red in vr. move: (vr (option Z) Zopt_semi v). rewrite !interp_rels_clauses_sem //. - - intros sem. unfold check_clauses, Deciders.check_clauses. + - intros sem. unfold check_model_clauses, check_clauses. eapply Clauses.for_all_spec. tc. move=> cl /sem => semcl. - unfold checkb; destruct check eqn:hc => //. - * move/check_entails_looping : hc. + unfold check_genb; destruct check_gen eqn:hc => //. + * move/check_gen_entails_looping : hc. rewrite -to_entails_all. rewrite -entails_L_entails_ℋ_equiv. rewrite -entails_L_rels_entails_L_clauses. rewrite -ISL.completeness_all. - move/(_ Z _ (valuation_of_model m)). + move/(_ Z _ (Z_valuation_of_model m)). rewrite -interp_rels_clauses_sem. move/(_ (model_valuation m)). rewrite -interp_rels_clauses_sem. rewrite clauses_sem_leq. cbn. rewrite interp_add_prems //=. lia. * move/check_invalid_valuation: hc. - move=> [v [_ semcls def ncl]]. specialize (semcl v). elim ncl; now apply semcl. + move=> [_ semcls def ncl]. specialize (semcl (opt_valuation_of_model m0)). elim ncl; now apply semcl. Qed. Definition pred (le : LevelExpr.t) := (le.1, le.2 - 1). @@ -3353,11 +3287,11 @@ Module LoopChecking (LS : LevelSets). Lemma enforce_inconsistent {m cls u} : enforce m cls = Some (inr u) -> - inconsistent_ext m (to_clauses cls). + inconsistent_ext_Z m (to_clauses cls). Proof. move/enforce_clauses_inconsistent. intros incon v vpos clssem csem. - apply incon. exists v. split => //. + apply incon. red. exists v. split => //. apply clauses_sem_union. split => //. Qed. @@ -3387,12 +3321,12 @@ Module LoopChecking (LS : LevelSets). Returns false if the constraint results in an inconsistent set of constraints or it simply is not valid. *) Definition check m c := - Impl.check_clauses m.(Impl.Abstract.clauses) (to_clauses c). + check_model_clauses m (to_clauses c). (* Checking corresponds to entailment in the free semilattice *) Lemma check_spec {m c} : check m c <-> entails_clauses (clauses m) (to_clauses c). - Proof. apply check_clauses_spec. Qed. + Proof. apply check_model_clauses_entails. Qed. (* Checking corresponds to validity in *all* semilattices, including degenerate ones. *) Lemma check_complete m c : @@ -3408,10 +3342,10 @@ Module LoopChecking (LS : LevelSets). check m c <-> valid_clauses (clauses m) (to_clauses c). Proof. apply check_clauses_Z_positive_complete. Qed. - Lemma zero_declared m : Impl.CorrectModel.zero_declared (model m). + Lemma zero_declared m : Impl.zero_declared (model m). Proof. eapply zero_declared. Qed. - Lemma above_zero_declared m : Impl.CorrectModel.above_zero_declared (levels m) (clauses m). + Lemma above_zero_declared m : Impl.above_zero_declared (levels m) (clauses m). Proof. eapply above_zero_declared. Qed. Definition model_valuation m : clauses_sem (to_Z_val (valuation m)) (clauses m). diff --git a/common/theories/LoopChecking/HornSemilatticeEquiv.v b/common/theories/LoopChecking/HornSemilatticeEquiv.v index 4b46f027d..635d75958 100644 --- a/common/theories/LoopChecking/HornSemilatticeEquiv.v +++ b/common/theories/LoopChecking/HornSemilatticeEquiv.v @@ -867,17 +867,35 @@ End ClausesSemantics. Import Semilattice. Lemma entails_L_completeness {p l r} : - (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v p -> interp_nes v l ≡ interp_nes v r)%sl -> + (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_rels v p -> interp_nes v l ≡ interp_nes v r)%sl <-> p ⊢ℒ l ≡ r. Proof. - intros hv. - specialize (hv _ (init_model p) (ids p)). - forward hv. - { apply interp_rels_init. } + apply (@completeness p (l, r)). + Qed. + + Lemma entails_L_completeness_syn {p l r} : + let SL := init_model p in + (forall (v : Level.t -> NES.t), interp_nes v l ≡ interp_nes v r)%sl -> + p ⊢ℒ l ≡ r. + Proof. + intros SL hv. + specialize (hv (ids p)). rewrite !interp_triv in hv. exact hv. Qed. + (* Lemma entails_L_completeness_syn_Z {p l r} : + let SL := init_model p in + (forall (v : Level.t -> Z), interp_rels v p -> interp_nes v l ≡ interp_nes v r)%sl -> + p ⊢ℒ l ≡ r. + Proof. + intros SL hv. cbn in hv. + unfold interp_rels in hv. unfold interp_nes in hv. cbn in hv. + specialize (hv (ids p)). + rewrite !interp_triv in hv. + exact hv. + Qed. *) + Lemma entails_completeness {cls cl} : entails cls cl <-> valid_semilattice_entailment cls cl. Proof. diff --git a/template-rocq/theories/Junk.v b/template-rocq/theories/Junk.v index 28d69512e..90c103b83 100644 --- a/template-rocq/theories/Junk.v +++ b/template-rocq/theories/Junk.v @@ -1,3 +1,431 @@ +Definition has_lt V m m' := + (exists l k k', LevelSet.In l V /\ LevelMap.MapsTo l k m /\ LevelMap.MapsTo l k' m' /\ lt_value k k'). + +Lemma nlt_spec V m m' : ~ has_lt V m m' <-> forall l k k', LevelSet.In l V -> LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m' -> lt_value k k' -> False. +Proof. + split. + - intros nlt l k k' inv hm hm' lt. + apply nlt. red. exists l, k, k'; split => //. + - intros hl [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]. + apply (hl l0 k0 k0') => //. +Qed. + +(* Lemma nsmaller m m' : ~ is_smaller_model m m' <-> + exists l k k', LevelMap.MapsTo l k m /\ LevelMap.MapsTo l k' m' /\ lt_value k' k. +Proof. + split. + - intros hnsm. unfold is_smaller_model in hnsm. + eapply Decidable.not_and in hnsm. destruct hnsm. *) + + +Definition le_values V m m' := + forall l, LevelSet.In l V -> (level_value m l ≤ level_value m' l)%opt. + +Infix "≦[ V ]" := (le_values V) (at level 70, format "x ≦[ V ] y"). + +Lemma dec_le_values V m m' : Decidable.decidable (m ≦[V] m'). +Proof. +Admitted. + + +Lemma is_ext_le_value V m m' : + (m ⩽ m') -> le_values V m m'. +Proof. + move=> hext l. + destruct (@level_valueP m l). eapply hext in H as [k' [hm' le]]. + now rewrite (level_value_MapsTo hm'). + constructor. +Qed. + +Lemma le_opt_lt x y z : (lt_value x y)%opt -> (y ≤ z)%opt -> lt_value x z. +Proof. + destruct x, y, z; cbn; intros hle hle'; depelim hle'; lia. +Qed. + +Lemma nlt_opt_le x y : ~ (x ≤ y)%opt -> lt_value y x. +Proof. + destruct (check_atom_value x y) eqn:ca. + - move/check_atom_value_spec: ca. contradiction. + - destruct x, y; cbn in * => //. + intros hne. red in hne. cbn in hne. lia. +Qed. + +Definition lt_value (x y : option Z) := + match x, y with + | Some x, Some y => x < y + | None, Some _ => True + | Some _, None => False + | None, None => False + end. + +Definition is_ext m m' : bool := + LevelMapFact.for_all (fun l k => + match LevelMap.find l m' with + | None => false + | Some k' => check_atom_value k k' + end) m. + +(* Definition extends m m' := + (forall l k, LevelMap.MapsTo l k m -> exists k', LevelMap.MapsTo l k' m' /\ (k ≤ k')%opt). *) + +Lemma is_ext_spec m m' : is_ext m m' <-> m ⩽ m'. +Proof. + split. + - rewrite /is_ext. + rewrite [is_true _]LevelMapFact.for_all_iff => hf l k /hf. + case: (find_spec l m') => //. + move=> k0 hm /check_atom_value_spec hle. exists k0. split => //. + - intros ext. rewrite /is_ext. + rewrite [is_true _]LevelMapFact.for_all_iff => l e /ext. + intros [k' [hm hle]]. + rewrite (LevelMap.find_1 hm). + now apply/check_atom_value_spec. +Qed. + +Lemma dec_ext m m' : Decidable.decidable (m ⩽ m'). +Proof. + red. rewrite -is_ext_spec. now destruct is_ext. +Qed. + + + +Instance lt_irrefl : Irreflexive lt_value. +Proof. + intros []; cbn. red. unfold lt_value. unfold lt; cbn. lia. + now hnf. +Qed. + +Instance le_inter_refl : Reflexive le_inter. +Proof. + intros x l k k' m m'. eapply LevelMapFact.F.MapsTo_fun in m; tea. subst. reflexivity. +Qed. + +Instance le_values_refl V : Reflexive (le_values V). +Proof. + intros x l; reflexivity. +Qed. + +Instance le_inter_trans V : Transitive (le_values V). +Proof. + intros x y z h0 h1 l hin. transitivity (level_value y l). apply h0 => //. apply h1 => //. +Qed. + +Instance le_values_preorder V : PreOrder (le_values V). +Proof. + split; tc. +Qed. + +Definition eq_level_values V m m' := + forall l, LevelSet.In l V -> level_value m l = level_value m' l. + +Instance eq_level_values_equiv V : Equivalence (eq_level_values V). +Proof. + split. + - intros x l. reflexivity. + - move=> x y h l. now symmetry. + - move=> x y z h h' l. now transitivity (level_value y l). +Qed. + +Instance le_values_partial_order V : PartialOrder (eq_level_values V) (le_values V). +Proof. + intros m m'. + split. + - intros hm. cbn. split. intros l hin. now rewrite hm. + red. intros l hin; now rewrite hm. + - cbn; unfold flip => -[] le le'. + red. intros l hin. move: (le l hin) (le' l hin). + apply antisymmetry. +Qed. + +Definition is_smaller_model V (m m' : model) := + m ≦[V] m' /\ has_lt V m m'. + +(* Lemma le_values_inter V m m' : le_values V m m' -> le_inter m m'. +Proof. + intros hle l k k' hm hm'. + move: (hle l). + rewrite (level_value_MapsTo hm). + now rewrite (level_value_MapsTo hm'). +Qed. *) + +(* Instance model_rel_strictorder V : StrictOrder (is_smaller_model V). +Proof. + split. + - intros x. red. + unfold is_smaller_model. + move=> [eq hlt]. destruct hlt as [l [k [k' [hin [hm [hm' hlt]]]]]]. + eapply LevelMapFact.F.MapsTo_fun in hm; tea. subst. destruct k; cbn in hlt => //. lia. + - intros x y z [le [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]] [le' _]. + split. + * now transitivity y. + * red. exists l0, k0. apply le_values_inter in le. + specialize (le _ _ _ hin hm0 hm0'). + specialize (le' l0). + rewrite (level_value_MapsTo hm0') in le'. + move: le'. + case: (@level_valueP z l0). + intros k hm le'. exists k. split => //. split => //. split => //. eapply le_opt_lt; tea. + now eapply le'. + intros hnin lenon. specialize (lenon hin). + depelim lenon => //. auto. + now destruct k0 ; cbn in hlt'. +Qed. *) +(* +Definition is_smaller_model_dec V m m' : Decidable.decidable (is_smaller_model V m m'). +Proof. Admitted. + +Lemma eq_values_equal V m m' : LevelMap.Equal m m' -> eq_level_values V m m'. +Proof. + move=> eqv l; move: (eqv l). + rewrite /level_value. do 2 destruct LevelMap.find => //; congruence. +Qed. + +Lemma eq_level_values_inter {V m m'} : eq_level_values V m m' -> + forall l k k', LevelSet.In l V -> LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m' -> (k = k')%opt. +Proof. + intros eq l k k' hin hm hm'. + specialize (eq l). move: eq. + rewrite (level_value_MapsTo hm) (level_value_MapsTo hm'). intros ->. reflexivity. auto. +Qed. +Print is_smaller_model. +Lemma nis_smaller_spec V m m' : ~ (is_smaller_model V m m') <-> ~ (m ≦[V] m') \/ ~ has_lt V m m'. +Proof. + rewrite /is_smaller_model. + split. + - move/Decidable.not_and => /fwd. apply dec_le_values. auto. + - intros [] []. now apply H. now apply H. +Qed. + +Lemma le_lt_model V m m' : m ≦[V] m' -> ~ (is_smaller_model V m' m). +Proof. + intros le [lt li]. + eapply antisymmetry in le; tea. + move: li. change (~ has_lt V m' m). rewrite nlt_spec. + intros. + eapply eq_level_values_inter in le; tea. subst k'. + now eapply irreflexivity in H2. +Qed. + +Lemma le_inter_has_lt V m m' : le_inter m m' <-> ~ has_lt V m' m. +Proof. + split. + - intros hinter [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]. + specialize (hinter _ _ _ hm0' hm0). + eapply le_opt_lt in hlt'; tea. + now eapply irreflexivity in hlt'. + - move/nlt_spec => hlt l k k' hm hm'. + destruct (check_atom_value_spec k k') => //. exfalso. + apply (hlt l k' k hin) => //. + now apply nlt_opt_le in H. +Qed. + +Lemma nle_inter_has_lt V m m' : ~ le_inter V m m' <-> has_lt V m' m. +Proof. + split. + - intros nle. rewrite le_inter_has_lt in nle. todo "decidability". + - rewrite le_inter_has_lt. auto. +Qed. + +Lemma le_values_has_lt V m m' : le_values V m m' -> ~ has_lt V m' m. +Proof. + intros hinter [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]. + eapply le_values_inter in hinter. + specialize (hinter _ _ _ hin hm0' hm0). + eapply le_opt_lt in hlt'; tea. + now eapply irreflexivity in hlt'. +Qed. *) + +(* Lemma le_values_inter_inv V m m' : model_of V m -> le_inter V m m' -> m ≦[V] m'. +Proof. + intros mof hle l hin. + specialize (mof l hin). + specialize (hle l hin). + move: hle. + destruct (@level_valueP m l) => //. + intros hle. intros h h'. eapply LevelMapFact.F.MapsTo_fun in H; tea. subst k. + depelim hle. + eapply level_value_MapsTo' in H0. + eapply LevelMapFact.F.MapsTo_fun in H0; tea. subst k'. + now constructor. + constructor. +Qed. *) + +(* +- move/nlt_spec => hlt l. k k' hm hm'. + destruct (check_atom_value_spec k k') => //. exfalso. + apply (hlt l k' k). split => //. split => //. + now apply nlt_opt_le in H. +Qed. *) +(* +Lemma contra A B : Decidable.decidable B -> (A -> ~ B) -> (~ A -> B). +Proof. + intros dec f na. + destruct dec. exact H. *) + +Lemma nle_values_has_lt V m m' : + ~ LevelSet.Empty V -> + model_of V m -> ~ le_values V m m' -> has_lt V m' m. +Proof. + intros hne le. +Admitted. + +(* +Lemma nle_ m m' : ~ m ⩽ m' <-> (LevelMap.Empty m' /\ ~ LevelMap.Empty m) \/ + has_lt m m'. +Proof. + move: m'. apply: LevelMapFact.map_induction. + - intros m' he. split. + intros hne. left; split => //. intros he'. apply hne. + have eq : m =m m'. + { rewrite LevelMapFact.F.Equal_mapsto_iff. firstorder. } + rewrite eq. reflexivity. + intros [[hem hem']|lt]. + * intros le. now apply hem' => l k /le -[k' []] /hem. + * intros hle. destruct lt as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. + now eapply he in hm0'. + - move=> m0 m1 nle l k nin hadd. split. + * intros nle'. right. red. + specialize (hle _ _ hm0) as [k' [hin']]. + eapply LevelMapFact.F.MapsTo_fun in hm0'; tea. subst k0'. *) + +Instance le_values_proper V : Proper (LevelMap.Equal ==> LevelMap.Equal ==> iff) (le_values V). +Proof. + intros ?? h ?? h'; rewrite /le_values //=. + now setoid_rewrite h; setoid_rewrite h'. +Qed. +(* +Lemma nle_lt_model m m' : m ≦ m' <-> ~ has_lt m' m. +Proof. + split. + - intros hm' hlt. + destruct hlt as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. + eapply le_values_inter in hm'. + specialize (hm' l0 _ _ hm0' hm0). + have h := le_opt_lt _ _ _ hlt' hm'. now apply irreflexivity in h. + - intros nlt l. rewrite -le_inter_has_lt in nlt. + red in nlt. + + Search has_lt. +*) +(* + move: m m'. apply: LevelMapFact.map_induction. + - intros m he m'. split. + intros hne. elim hne. intros l. + destruct (@level_valueP m l). now eapply he in H. constructor. + unfold has_lt. intros [l [k [k' [hm [hm' _]]]]]. + now eapply he in hm'. + - intros m m0 h x k hnin hadd m'. + apply levelmap_add_spec in hadd. + rewrite /has_lt. + split. + intros hle. setoid_rewrite hadd in hle. + destruct () + + + left; split => //. intros he'. apply hne. + have eq : m =m m'. + { rewrite LevelMapFact.F.Equal_mapsto_iff. firstorder. } + rewrite eq. reflexivity. + intros [[hem hem']|lt]. + * intros le. now apply hem' => l k /le -[k' []] /hem. + * intros hle. destruct lt as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. + now eapply he in hm0'. + - move=> m0 m1 nle l k nin hadd. split. + * intros nle'. right. red. + specialize (hle _ _ hm0) as [k' [hin']]. + + + intros nle. + destruct (dec_le_values m' m). split => //. + eapply nle_values_has_lt. in H. + apply nle_inter_has_lt. + intros lei. apply nle. + red in H, lei. intros l. specialize (H l). + destruct (@level_valueP m l). + destruct (@level_valueP m' l). + specialize (lei _ _ _ H0 H1). auto. + + Search le_inter. + eapply is_ext_le_inter in H. + eapply antisymmetry in H;. + + + destruct (is_smaller_model_dec m' m) => //. + [lt li]. + have eq : m =m m'. + now apply antisymmetry. + setoid_rewrite eq in li. + destruct li as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. + eapply LevelMapFact.F.MapsTo_fun in hm0; tea. subst. + now apply irreflexivity in hlt'. +Qed. *) + + +(* +Lemma minimal_unique cls m m' : + minimal cls m -> is_model cls m -> minimal cls m' -> is_model cls m' -> (normalize_model m) ⩽ (normalize_model m'). +Proof. + intros min ism. + rewrite minimal_forall in min. + intros min' ism'. + rewrite minimal_forall in min'. + specialize (min _ ism'). + specialize (min' _ ism). + destruct (is_smaller_model_dec (normalize_model m) (normalize_model m')). apply H. + assert (sirr := irreflexivity (R := is_smaller_model) (normalize_model m)). + + destruct (dec_ext (normalize_model m) (normalize_model m')) => //. +Qed. *) +Print has_lt. +Lemma nle_values V m m' : + ~ LevelSet.Empty V -> + model_of V m -> + ~ (le_values V m m') -> + exists l, LevelSet.In l V /\ lt_value (level_value m' l) (level_value m l). +Proof. + intros hne mof leq. + have := (nle_values_has_lt V m m' hne mof leq). + intros [l [k [k' []]]]. destruct H0 as [? []]. + exists l; split => //. + now rewrite (level_value_MapsTo H0) (level_value_MapsTo H1). +Qed. + +(* Lemma minimal_le cls m m' : + minimal cls m -> is_model cls m' -> model_of (clauses_levels cls) m' -> + model_of (clauses_levels cls) m -> + is_smaller_model (clauses_levels cls) (normalize_model m) (normalize_model m'). +Proof. + intros nex ism mof mof'. + rewrite minimal_forall in nex. + specialize (nex _ ism). + destruct (is_smaller_model_dec (clauses_levels cls) (normalize_model m) (normalize_model m')) => //. +Abort. *) + + + +(* Lemma minimal_forall cls cls' m : minimal cls cls' m <-> + forall m', is_model cls m' -> is_smaller_model (clauses_levels cls) (normalize_model m') (normalize_model m) -> False. +Proof. + split. + - intros hmin m' ism issm. apply hmin. exists m'. split => //. + - intros hm' [m' [issm ism]]. apply (hm' m' ism issm). +Qed. *) + +(* Lemma minimal_mapsto cls m m' : + minimal cls cls' m -> is_model cls m' -> is_smaller_model (clauses_levels cls) (normalize_model m') (normalize_model m) -> False. +Proof. + intros nex ism. + rewrite minimal_forall in nex. + now specialize (nex _ ism). +Qed. *) + +(* Lemma minimal_model_unique cls minit m m' : + minimal_above minit cls m -> minimal_above minit cls m' -> is_model cls m -> is_model cls m' -> + normalize_model m =m normalize_model m'. +Abort. *) + + + #[program] Definition of_level_map_n (m : LevelMap.t nat) V n (hne : ~ LevelMap.Empty m) : nonEmptyLevelExprSet := {| t_set := LevelMap.fold (fun l k acc => From 12d7ace1c4bfc1aef541d3e2b5dc1f4dccc10e17 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 9 Oct 2025 13:33:35 +0200 Subject: [PATCH 098/164] Add zero in semilattice def --- common/theories/LoopChecking/Deciders.v | 24 ++++++++- common/theories/LoopChecking/HornClauses.v | 3 +- .../LoopChecking/HornSemilatticeEquiv.v | 54 ++++++++++++------- .../LoopChecking/InitialSemilattice.v | 2 + utils/theories/MRInstances.v | 6 ++- utils/theories/SemiLattice.v | 2 + 6 files changed, 68 insertions(+), 23 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 56a4e8cfb..ee288423d 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -2906,7 +2906,29 @@ Proof. unfold valid_clause_Z, nvalid_clause_Z; firstorder. Qed. -(*Lemma check_clause_invalid_valid_Z m mcheck cl : +Lemma check_clause_invalid_valid_Z m mcheck cl : + clause_levels cl ⊂_lset (levels m) -> + check_gen (clauses m) cl = Invalid mcheck -> ~ valid_clause_Z (clauses m) cl. +Proof. + intros wf. + move/check_invalid_entails. + rewrite entails_completeness_syn. + intros nvsl nz. + apply nvsl. + intros v cs. + set (sl := init_model (relations_of_clauses (clauses m))). + have he : clause_sem v cl \/ ~ clause_sem v cl. admit. + destruct he => //. red in nz. + destruct cl as [prems concl]. + specialize (nv (Z_valuation_of_model m)). forward nv. admit. + specialize (nv (model_valuation m)). cbn. + cbn in nv. + red in nv. + set (v' : premises -> Z := fun u => + specialize (nv (fun l => interp_nes v' (v l))). + + +Lemma check_clause_invalid_valid_Z m mcheck cl : clause_levels cl ⊂_lset (levels m) -> check_gen (clauses m) cl = Invalid mcheck -> ~ valid_clause_Z (clauses m) cl. Proof. diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index fdc826839..f5deb560c 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -2026,12 +2026,13 @@ Module Clauses (LS : LevelSets). Section prems_semi. Obligation Tactic := idtac. - Import Semilattice (Semilattice, eq, add, join). + Import Semilattice (Semilattice, eq, zero, add, join). Context (cls : Clauses.t). Equations? horn_semi : Semilattice NES.t Z := horn_semi := {| eq x y := cls ⊢ℋ x ≡ y; + zero := NES.singleton (Level.zero, 0); add := add_prems; join := union |}. Proof. diff --git a/common/theories/LoopChecking/HornSemilatticeEquiv.v b/common/theories/LoopChecking/HornSemilatticeEquiv.v index 635d75958..152f7b6b4 100644 --- a/common/theories/LoopChecking/HornSemilatticeEquiv.v +++ b/common/theories/LoopChecking/HornSemilatticeEquiv.v @@ -873,47 +873,63 @@ End ClausesSemantics. apply (@completeness p (l, r)). Qed. + Lemma entails_completeness {cls cl} : + entails cls cl <-> valid_semilattice_entailment cls cl. + Proof. + split; revgoals. + - intros hv. + eapply entails_L_entails_ℋ_equiv. + 2:{ now eapply Clauses.singleton_spec. } + intros c. rewrite Clauses.singleton_spec => ->. + red. eapply entails_L_completeness. + intros S SL v. specialize (hv S SL v). + rewrite -interp_rels_clauses_sem. move/hv. + destruct cl; cbn => //. + rewrite interp_nes_union interp_nes_singleton //. + - move/entails_entails_L. + move/entails_L_clause_clauses. + move/entails_L_rels_entails_L_clauses. + move/completeness_all. + unfold valid_relations, valid_semilattice_entailment. + setoid_rewrite interp_rels_clauses_sem. + setoid_rewrite interp_rel_clause_sem. + rewrite relations_of_clauses_singleton. + now setoid_rewrite interp_rels_tip. + Qed. + Lemma entails_L_completeness_syn {p l r} : let SL := init_model p in - (forall (v : Level.t -> NES.t), interp_nes v l ≡ interp_nes v r)%sl -> + (forall (v : Level.t -> NES.t), interp_rels v p -> interp_nes v l ≡ interp_nes v r)%sl -> p ⊢ℒ l ≡ r. Proof. intros SL hv. - specialize (hv (ids p)). + specialize (hv (ids p) (interp_rels_init p)). rewrite !interp_triv in hv. exact hv. Qed. - (* Lemma entails_L_completeness_syn_Z {p l r} : - let SL := init_model p in - (forall (v : Level.t -> Z), interp_rels v p -> interp_nes v l ≡ interp_nes v r)%sl -> - p ⊢ℒ l ≡ r. - Proof. - intros SL hv. cbn in hv. - unfold interp_rels in hv. unfold interp_nes in hv. cbn in hv. - specialize (hv (ids p)). - rewrite !interp_triv in hv. - exact hv. - Qed. *) + Definition valid_semilattice_entailment_syn cls cl := + let SL := init_model (relations_of_clauses cls) in + (forall (v : Level.t -> NES.t), clauses_sem v cls -> clause_sem v cl). - Lemma entails_completeness {cls cl} : - entails cls cl <-> valid_semilattice_entailment cls cl. + Lemma entails_completeness_syn {cls cl} : + entails cls cl <-> valid_semilattice_entailment_syn cls cl. Proof. split; revgoals. - intros hv. eapply entails_L_entails_ℋ_equiv. 2:{ now eapply Clauses.singleton_spec. } intros c. rewrite Clauses.singleton_spec => ->. - red. eapply entails_L_completeness. - intros S SL v. specialize (hv S SL v). + red. eapply entails_L_completeness_syn. + intros v. red in hv. specialize (hv v). rewrite -interp_rels_clauses_sem. move/hv. - destruct cl; cbn => //. + destruct cl => //. rewrite interp_nes_union interp_nes_singleton //. - move/entails_entails_L. move/entails_L_clause_clauses. move/entails_L_rels_entails_L_clauses. move/completeness_all. - unfold valid_relations, valid_semilattice_entailment. + unfold valid_relations, valid_semilattice_entailment_syn. setoid_rewrite interp_rels_clauses_sem. setoid_rewrite interp_rel_clause_sem. rewrite relations_of_clauses_singleton. diff --git a/common/theories/LoopChecking/InitialSemilattice.v b/common/theories/LoopChecking/InitialSemilattice.v index 212d9ff95..1726dfd2d 100644 --- a/common/theories/LoopChecking/InitialSemilattice.v +++ b/common/theories/LoopChecking/InitialSemilattice.v @@ -156,6 +156,7 @@ Module InitialSemilattice (LS : LevelSets). Equations? pres_semilattice : Semilattice NES.t Q.t := pres_semilattice := {| eq x y := relations p.(C) -> univ_eq x y; + zero := NES.singleton (Level.zero, 0%Z); add := add_prems; join x y := x ∪ y |}. Proof. @@ -454,6 +455,7 @@ Module InitialSemilattice (LS : LevelSets). Equations? init_model (rs : rels) : Semilattice t Q.t := init_model rs := {| eq x y := rs ⊢ℒ x ≡ y; + zero := NES.singleton (Level.zero, 0%Z); add := add_prems; join := union |}. Proof. diff --git a/utils/theories/MRInstances.v b/utils/theories/MRInstances.v index 734045b51..ac0ceb6b8 100644 --- a/utils/theories/MRInstances.v +++ b/utils/theories/MRInstances.v @@ -46,7 +46,8 @@ Section ZSemiLattice. Import Semilattice. Program Definition Zsemilattice : Semilattice Z Z := - {| add := Z.add; + {| zero := 0%Z; + add := Z.add; join := Z.max; |}. Solve Obligations with program_simpl; try lia. @@ -70,7 +71,8 @@ Section NatSemiLattice. Import Semilattice. Program Definition Natsemilattice : Semilattice nat nat := - {| add := Nat.add; + {| zero := 0; + add := Nat.add; join := Nat.max; |}. Solve Obligations with program_simpl; try lia. diff --git a/utils/theories/SemiLattice.v b/utils/theories/SemiLattice.v index 4a685c9e2..29d19609c 100644 --- a/utils/theories/SemiLattice.v +++ b/utils/theories/SemiLattice.v @@ -20,6 +20,7 @@ Module Semilattice. Class Semilattice (carrier : Type) (incr : Type) `{CM : IsCommMonoid incr} := { eq : carrier -> carrier -> Prop where "x ≡ y" := (eq x y) : sl_scope; eq_equiv :: Equivalence eq; + zero : carrier; add : incr -> carrier -> carrier; join : carrier -> carrier -> carrier; add_distr n m x : add n (add m x) ≡ add (CommutativeMonoid.add n m) x; @@ -298,6 +299,7 @@ Section OptSemilattice. opt_semi := {| eq x y := R_opt (@eq _ _ CM SL) x y; eq_equiv := _; + zero := Some zero; add n x := option_map (add n) x; join := option_map2 join |}. Proof. From 7f286ee4d4f9852d9629103c180357ce51c4a448 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 10 Oct 2025 06:54:54 +0200 Subject: [PATCH 099/164] Minor changes --- common/theories/LoopChecking/Deciders.v | 163 ++++++++++++++---------- utils/theories/SemiLattice.v | 4 +- 2 files changed, 99 insertions(+), 68 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index ee288423d..dafcc795f 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -889,16 +889,45 @@ Hint Rewrite clause_levels_spec levels_spec : set_specs'. Lemma nge_lt x y : (~ x <= y) -> y < x. Proof. intros n. unfold lt; cbn. lia. Qed. +Definition pred_expr (le : LevelExpr.t) := + (le.1, le.2 - 1). + +Definition checking_clause (cl : clause) := + let (prems, concl) := cl in + (singleton (pred_expr concl) ∪ prems, concl). + + Definition clause_premises_levels cl := NES.levels (premise cl). + + Lemma checking_clause_premise_levels cl : + clause_premises_levels (checking_clause cl) =_lset + clause_levels (checking_clause cl). + Proof. + destruct cl as [prems [concl k]]; rewrite /clause_premises_levels /checking_clause //=. + rewrite /clause_levels. cbn. unfold pred_expr; cbn. + intros l; firstorder. lsets. rsets. + rewrite NES.levels_spec. exists (k - 1). lsets. + Qed. + + Lemma checking_clause_levels cl : + clause_levels (checking_clause cl) =_lset clause_levels cl. + Proof. + destruct cl as [prems [concl k]]; rewrite /clause_premises_levels /checking_clause //=. + rewrite /clause_levels. cbn. unfold pred_expr; cbn. + intros l. rewrite LevelSet.union_spec NES.levels_spec. + setoid_rewrite LevelExprSet.union_spec; rewrite LevelSet.union_spec. + setoid_rewrite NES.levels_spec. firstorder rsets. noconf H. + now right. + Qed. Theorem check_invalid_allm {cls cl mcheck} : - check_gen cls cl = Invalid mcheck -> - let minit := check_init_model cls cl in + check_gen cls (checking_clause cl) = Invalid mcheck -> + let minit := check_init_model cls (checking_clause cl) in forall m, is_model cls m -> - minimal_above cls mcheck m -> + mcheck ⩽ m -> (* (level_value m (concl cl).1 ≤ level_value mcheck (concl cl).1)%opt -> *) model_of (clauses_levels cls ∪ clause_levels cl) m -> minit ⩽ m -> - valid_clause m cl -> False. + valid_clause m (checking_clause cl) -> False. Proof. move/check_invalid => [ism mofm minm encl invcl]. intros minit m' ism' minm' mof. @@ -915,7 +944,8 @@ Proof. have [minmf [[minpl minpk] [hin heq]]] := min_premise_spec_aux _ _ _ eqminp. cbn in heq. destruct (level_value mcheck minpl) as [minpmv|] => //. noconf heq. destruct concl as [concl k]. - have hpres : (min_premise mcheck prems ≤ min_premise m' prems)%opt. + set (prems' := (singleton (pred_expr (concl, k)) ∨ prems)%nes) in *. + have hpres : (min_premise mcheck prems' ≤ min_premise m' prems')%opt. { now eapply min_premise_pres. } rewrite eqminp in hpres. depelim hpres. rename y into minpm'. rename H into minpm'minpm. @@ -930,8 +960,7 @@ Proof. { repeat (autorewrite with set_specs set_specs'; cbn). now right. } eapply level_value_MapsTo' in conclm'. rewrite hl in nsat. - move:(minm' mcheck) => /fwd. reflexivity. - move/(_ ism). move/is_ext_le_inter/(_ concl _ _ conclm' hm) => /check_atom_value_spec //=. + move:minm'; move/is_ext_le_inter/(_ concl _ _ conclm' hm) => /check_atom_value_spec //=. move/negP: nsat. destruct conclv as [conclv|]. case: Z.leb_spec => //= hlt _ /Z.leb_le. lia. @@ -2338,8 +2367,6 @@ Lemma opt_valuation_of_model_equiv m l : apply clauses_sem_valid. Qed. - Definition clause_premises_levels cl := NES.levels (premise cl). - Theorem check_invalid_valuation {cls cl m} : check_gen cls cl = Invalid m -> let v := opt_valuation_of_model m in @@ -2596,33 +2623,7 @@ Lemma opt_valuation_of_model_equiv m l : Qed. -Definition pred_expr (le : LevelExpr.t) := - (le.1, le.2 - 1). -Definition checking_clause (cl : clause) := - let (prems, concl) := cl in - (singleton (pred_expr concl) ∪ prems, concl). - - Lemma checking_clause_premise_levels cl : - clause_premises_levels (checking_clause cl) =_lset - clause_levels (checking_clause cl). - Proof. - destruct cl as [prems [concl k]]; rewrite /clause_premises_levels /checking_clause //=. - rewrite /clause_levels. cbn. unfold pred_expr; cbn. - intros l; firstorder. lsets. rsets. - rewrite NES.levels_spec. exists (k - 1). lsets. - Qed. - - Lemma checking_clause_levels cl : - clause_levels (checking_clause cl) =_lset clause_levels cl. - Proof. - destruct cl as [prems [concl k]]; rewrite /clause_premises_levels /checking_clause //=. - rewrite /clause_levels. cbn. unfold pred_expr; cbn. - intros l. rewrite LevelSet.union_spec NES.levels_spec. - setoid_rewrite LevelExprSet.union_spec; rewrite LevelSet.union_spec. - setoid_rewrite NES.levels_spec. firstorder rsets. noconf H. - now right. - Qed. Definition check_genb cls cl := match check_gen cls cl with @@ -2886,60 +2887,90 @@ Proof. move=> //. Qed. -Print valid_clause. +Definition finite_premise (v : Level.t -> option Z) cl := + exists k, interp_nes v (premise cl) = Some k. + +Definition finite_clause (v : Level.t -> option Z) cl := + finite_premise v cl /\ isSome (v (concl cl).1). + +(* The valution here is in 𝐙 + ∞: + - clauses max (∞, ...) >= x are trivially valid. + - clauses max ... >= ∞ are invalid. + *) +Definition valid_clause_Zinf cls cl := + forall v : Level.t -> option Z, + positive_opt_valuation v -> + clauses_sem v cls -> + (* finite_clause v cl -> *) + clause_sem v cl. + Definition valid_clause_Z cls cl := forall v : Level.t -> Z, positive_valuation v -> - clauses_sem v cls -> clause_sem v cl. + clauses_sem v cls -> + clause_sem v cl. -Lemma valid_clause_Z_weaken cls cls' cl : - Clauses.Subset cls' cls -> valid_clause_Z cls' cl -> valid_clause_Z cls cl. +Lemma valid_clause_Z_Zinf cls cl : valid_clause_Zinf cls cl -> valid_clause_Z cls cl. Proof. - intros hsub vc v pos csem. apply vc; tea. eapply clauses_sem_subset; tea. + move=> vzinf v pos csem. + move: (vzinf (opt_val_of_Z_val v)) => /fwd. + { rewrite /opt_val_of_Z_val => l k hopt. noconf hopt. + apply pos. } + rewrite clauses_sem_opt clause_sem_opt; apply => //. Qed. -Definition nvalid_clause_Z cls cl := - exists v : Level.t -> Z, positive_valuation v /\ clauses_sem v cls /\ ~ clause_sem v cl. +Lemma contra A B : (B -> A) -> (~ A -> ~ B). +Proof. intros f na b. exact (na (f b)). Qed. + -Lemma valid_clause_Z_invalid cls cl : nvalid_clause_Z cls cl -> ~ valid_clause_Z cls cl. + +Definition valid_clause_Z_mon cls cls' cl : + Clauses.Subset cls cls' -> valid_clause_Zinf cls cl -> valid_clause_Zinf cls' cl. Proof. - unfold valid_clause_Z, nvalid_clause_Z; firstorder. + intros hsub vz v vpos clsem. + eapply vz => //. eapply clauses_sem_subset; tea. Qed. -Lemma check_clause_invalid_valid_Z m mcheck cl : - clause_levels cl ⊂_lset (levels m) -> - check_gen (clauses m) cl = Invalid mcheck -> ~ valid_clause_Z (clauses m) cl. +Definition valid_clause_Z_mon_neg cls cls' cl : + Clauses.Subset cls cls' -> ~ valid_clause_Zinf cls' cl -> ~ valid_clause_Zinf cls cl. Proof. - intros wf. - move/check_invalid_entails. - rewrite entails_completeness_syn. - intros nvsl nz. - apply nvsl. - intros v cs. - set (sl := init_model (relations_of_clauses (clauses m))). - have he : clause_sem v cl \/ ~ clause_sem v cl. admit. - destruct he => //. red in nz. - destruct cl as [prems concl]. - specialize (nv (Z_valuation_of_model m)). forward nv. admit. - specialize (nv (model_valuation m)). cbn. - cbn in nv. - red in nv. - set (v' : premises -> Z := fun u => - specialize (nv (fun l => interp_nes v' (v l))). + intros hsub vz vz'. eapply valid_clause_Z_mon in vz'; tea. contradiction. +Qed. +Section Zinf_semi. + Definition inf_model := LevelMap.t (option (option Z)). + + Definition le (x y : option Z) := + match x, y with + | None, None => true + | None, Some _ => false + | Some _, None => true + | Some x, Some y => x <=? y + end. -Lemma check_clause_invalid_valid_Z m mcheck cl : +End Zinf_semi. + + +Lemma check_clause_invalid_Zinf m mcheck cl : + check_gen (clauses m) cl = Invalid mcheck -> ~ valid_clause_Zinf (clauses m) cl. +Proof. + unfold check_clause. + move/check_invalid_valuation => [vpos csem hdef clsem]. + now move=> /(_ (opt_valuation_of_model mcheck) vpos csem). +Qed. + +Lemma check_clause_invalid_Z m mcheck cl : clause_levels cl ⊂_lset (levels m) -> check_gen (clauses m) cl = Invalid mcheck -> ~ valid_clause_Z (clauses m) cl. Proof. move=> hwf. - unfold check_clause. move/check_invalid_allm => /(_ (model m) (model_ok (model_valid m))). move=> /fwd. { (* This means the conclusion's level in the inital model to check should be set at least as high as in the current clauses. This should follow from minimality. *) red. + red. unfold model_rel. todo "level of conclusion". } move=> /fwd. { red. todo "scope, easy". } @@ -2952,7 +2983,7 @@ Proof. rewrite def_clause_sem_valid //. { eapply defined_model_of_subset; tea. eapply defined_model. } -Qed.*) +Qed. Search entails. (* diff --git a/utils/theories/SemiLattice.v b/utils/theories/SemiLattice.v index 29d19609c..8325bfe11 100644 --- a/utils/theories/SemiLattice.v +++ b/utils/theories/SemiLattice.v @@ -317,8 +317,8 @@ Section OptSemilattice. Defined. Existing Instance opt_semi. - (* None is greater than any element in this semilattice. - This models implications *) + (* None is greater than any element in this semilattice, i.e. + it models +∞. *) Lemma le_spec {x y : option S} : x ≤ y <-> (y = None) \/ (exists x' y', x = Some x' /\ y = Some y' /\ le x' y'). Proof. From 2d616e47978fbac430d5e497472d69b797bb47db Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 10 Oct 2025 07:28:27 +0200 Subject: [PATCH 100/164] Generalize zero_model definition --- common/theories/LoopChecking/Deciders.v | 19 ++++----- common/theories/LoopChecking/Models.v | 52 ++++++++++++++++--------- 2 files changed, 44 insertions(+), 27 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index dafcc795f..f648c4ce8 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -289,14 +289,14 @@ Proof. now apply enabled_clauses_le. Qed. -Program Definition loop_check cls (cl : clause) : result (premises_model (clauses_levels cls) cl).1 LevelSet.empty cls (premises_model (clauses_levels cls) cl).2 := +Program Definition loop_check cls (cl : clause) : result (premises_model (clauses_levels cls) None cl).1 LevelSet.empty cls (premises_model (clauses_levels cls) None cl).2 := let V := clauses_levels cls in - loop (premises_model V cl).1 LevelSet.empty cls (premises_model V cl).2 (premises_model V cl).2 _. + loop (premises_model V None cl).1 LevelSet.empty cls (premises_model V None cl).2 (premises_model V None cl).2 _. Next Obligation. split => //. - lsets. - intros l. rewrite LevelSet.union_spec. - rewrite -/(LevelMap.In l (premises_model (clauses_levels cls) cl).2). + rewrite -/(LevelMap.In l (premises_model (clauses_levels cls) None cl).2). rewrite in_premises_model. intuition auto. - apply is_update_of_empty. Qed. @@ -308,7 +308,7 @@ Variant check_result {cls} := Arguments check_result : clear implicits. Lemma valid_model_find {V W cl cls} : - forall v : valid_model (clause_levels cl ∪ V) W (premises_model_map (zero_model (clause_levels cl ∪ V)) (Clauses.singleton cl)) cls, + forall v : valid_model (clause_levels cl ∪ V) W (premises_model_map (zero_model None (clause_levels cl ∪ V)) (Clauses.singleton cl)) cls, ~ LevelMap.find (concl cl).1 (model_model v) = None. Proof. intros v hfind. @@ -699,7 +699,7 @@ Proof. Definition check_init_model cls cl := - (premises_model (clauses_levels cls) cl).2. + (premises_model (clauses_levels cls) None cl).2. Lemma minimal_above_refl cls m : minimal_above cls m m. @@ -782,7 +782,7 @@ Proof. red; cbn. have hcl : Clauses.In cl (Clauses.singleton cl). { now eapply Clauses.singleton_spec. } - have hs:= @premises_model_map_min_premise_inv V _ _ hcl. firstorder. } + have hs:= @premises_model_map_min_premise_inv V _ None _ hcl. firstorder. } split => //. { have hv := model_of_V v. clear -hv. subst V. cbn. now rewrite LevelSetProp.union_sym. @@ -799,7 +799,7 @@ Proof. eapply is_update_of_ext in hsu. have hs := min_premise_pres prems hsu. rewrite minp in hs. - have hmin := @premises_model_map_min_premise_inv V (Clauses.singleton cl) cl. + have hmin := @premises_model_map_min_premise_inv V (Clauses.singleton cl) None cl. forward hmin. now apply Clauses.singleton_spec. destruct hmin as [minp' [hmineq hpos]]. rewrite hmineq in hs. depelim hs. lia. } @@ -923,7 +923,7 @@ Theorem check_invalid_allm {cls cl mcheck} : check_gen cls (checking_clause cl) = Invalid mcheck -> let minit := check_init_model cls (checking_clause cl) in forall m, is_model cls m -> - mcheck ⩽ m -> + minimal_above cls mcheck m -> (* (level_value m (concl cl).1 ≤ level_value mcheck (concl cl).1)%opt -> *) model_of (clauses_levels cls ∪ clause_levels cl) m -> minit ⩽ m -> @@ -960,7 +960,8 @@ Proof. { repeat (autorewrite with set_specs set_specs'; cbn). now right. } eapply level_value_MapsTo' in conclm'. rewrite hl in nsat. - move:minm'; move/is_ext_le_inter/(_ concl _ _ conclm' hm) => /check_atom_value_spec //=. + move:(minm' mcheck) => /fwd. reflexivity. + move/(_ ism). move/is_ext_le_inter/(_ concl _ _ conclm' hm) => /check_atom_value_spec //=. move/negP: nsat. destruct conclv as [conclv|]. case: Z.leb_spec => //= hlt _ /Z.leb_le. lia. diff --git a/common/theories/LoopChecking/Models.v b/common/theories/LoopChecking/Models.v index f6d4bd47e..97ce4ece4 100644 --- a/common/theories/LoopChecking/Models.v +++ b/common/theories/LoopChecking/Models.v @@ -69,12 +69,12 @@ Module Models (LS : LevelSets). LevelSet.fold (fun l acc => LevelMap.add l (max_clause_premise_of l cls) acc) levels m. - Definition zero_model levels : model := - LevelSet.fold (fun l acc => LevelMap.add l None acc) levels (LevelMap.empty _). + Definition zero_model n levels : model := + LevelSet.fold (fun l acc => LevelMap.add l n acc) levels (LevelMap.empty _). - Definition premises_model V cl : LevelSet.t * model := + Definition premises_model V n cl : LevelSet.t * model := let levels := LevelSet.union (clause_levels cl) V in - (levels, premises_model_map (zero_model levels) (Clauses.singleton cl)). + (levels, premises_model_map (zero_model n levels) (Clauses.singleton cl)). Lemma premises_model_map_spec m cls : forall l k, @@ -102,7 +102,7 @@ Module Models (LS : LevelSets). rewrite LevelMapFact.F.add_mapsto_iff. right; split => //. Qed. - Lemma zero_model_spec {l ls n} : LevelMap.MapsTo l n (zero_model ls) <-> LevelSet.In l ls /\ n = None. + Lemma zero_model_spec {l ls i n} : LevelMap.MapsTo l n (zero_model i ls) <-> LevelSet.In l ls /\ n = i. Proof. unfold zero_model. eapply LevelSetProp.fold_rec. @@ -115,21 +115,21 @@ Module Models (LS : LevelSets). Qed. - Lemma premises_model_map_min_premise {levels cls prems z} : - min_premise (premises_model_map (zero_model levels) cls) prems = Some z -> + Lemma premises_model_map_min_premise {levels i cls prems z} : + min_premise (premises_model_map (zero_model i levels) cls) prems = Some z -> (exists minp mink, LevelExprSet.In (minp, mink) prems /\ exists maxp, max_clause_premise_of minp cls = Some maxp /\ z = maxp - mink) \/ - (exists minp mink, LevelExprSet.In (minp, mink) prems /\ z + mink <= 0)%Z. + (exists minp mink idef, LevelExprSet.In (minp, mink) prems /\ i = Some idef /\ z = idef - mink)%Z. Proof. set (m := premises_model_map _ _). have [minple [[minp mink] [inminp mineq]]] := min_premise_spec m prems. rewrite mineq. rewrite /min_atom_value. destruct level_value eqn:hl => //. intros [= <-]. eapply level_value_MapsTo' in hl. - eapply premises_model_map_spec in hl as [[inpcls [hm _]]|[ninpcls h']]. left. - 2:{ apply zero_model_spec in h' as [h' [= ->]]. } - exists minp, mink. split => //. noconf hm. rewrite -hm. + eapply premises_model_map_spec in hl as [[inpcls [hm _]]|[ninpcls h']]. + 2:{ apply zero_model_spec in h' as [h' [= eq]]. right. do 3 eexists; split; tea. subst i. split; trea. } + left. exists minp, mink. split => //. noconf hm. rewrite -hm. eexists; split => //. Qed. @@ -144,9 +144,9 @@ Module Models (LS : LevelSets). firstorder. Qed. - Lemma premises_model_map_min_premise_inv {levels cls} : + Lemma premises_model_map_min_premise_inv {levels cls i} : forall cl, Clauses.In cl cls -> - exists z, min_premise (premises_model_map (zero_model levels) cls) (premise cl) = Some z /\ (0 <= z)%Z. + exists z, min_premise (premises_model_map (zero_model i levels) cls) (premise cl) = Some z /\ (0 <= z)%Z. Proof. set (m := premises_model_map _ _). move=> cl hin. @@ -176,9 +176,9 @@ Module Models (LS : LevelSets). eapply levels_spec. now exists mink. Qed. - Lemma in_premises_model V cl : + Lemma in_premises_model V i cl : forall l, - LevelMap.In l (premises_model V cl).2 <-> + LevelMap.In l (premises_model V i cl).2 <-> LevelSet.In l V \/ LevelSet.In l (clause_levels cl). Proof. intros l. rewrite premises_model_map_in. @@ -188,15 +188,15 @@ Module Models (LS : LevelSets). apply clause_levels_spec. left. now subst. - apply zero_model_spec in H as [hin ->]. apply LevelSet.union_spec in hin. firstorder. - - right. exists None. apply zero_model_spec. split => //; lsets. + - right. exists i. apply zero_model_spec. split => //; lsets. - eapply clause_levels_spec in H as [H|H]. * left. exists cl. split => //. now apply Clauses.singleton_spec. - * subst. right. exists None. apply zero_model_spec. split => //. + * subst. right. exists i. apply zero_model_spec. split => //. apply LevelSet.union_spec. left. apply clause_levels_spec. now right. Qed. Lemma of_level_map_premises_model_map cls cl V ne : - cls ⊢a premise cl → of_level_map (premises_model_map (zero_model V) (Clauses.singleton cl)) ne. + cls ⊢a premise cl → of_level_map (premises_model_map (zero_model None V) (Clauses.singleton cl)) ne. Proof. intros [l k]. rewrite of_level_map_spec. move/premises_model_map_spec; cbn. @@ -208,6 +208,22 @@ Module Models (LS : LevelSets). now constructor. Qed. + Lemma of_level_map_premises_model_map_some cls cl V i ne ne' : + cls ⊢a union (of_level_map (zero_model (Some i) V) ne') (premise cl) → + of_level_map (premises_model_map (zero_model (Some i) V) (Clauses.singleton cl)) ne. + Proof. + intros [l k]. + rewrite of_level_map_spec. move/premises_model_map_spec; cbn. + intros [[hin' [[= heq] _]]|[hnin hm]]. + 2:{ apply zero_model_spec in hm as []. noconf H0. + constructor. eapply LevelExprSet.union_spec; left. + eapply of_level_map_spec. now eapply zero_model_spec. } + move: hin'; cbn; rewrite LevelSet.union_spec. intros []; [|lsets]. + eapply max_premise_of_spec_in in H as [maxp' [eq hin']]. + rewrite eq in heq; noconf heq. + constructor. now eapply LevelExprSet.union_spec; right. + Qed. + Lemma entails_all_satisfies {cls prems m hne l k} : cls ⊢a prems → of_level_map m hne -> infers_atom m l k -> From b2731fc7173148f4671c68a8d2e748fdb87c10b4 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 13 Oct 2025 20:01:06 +0200 Subject: [PATCH 101/164] WIP in deciders --- common/theories/LoopChecking/Deciders.v | 1024 ++++++++++++++++++++--- 1 file changed, 896 insertions(+), 128 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index f648c4ce8..1542005ce 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -289,9 +289,16 @@ Proof. now apply enabled_clauses_le. Qed. +Definition min_clause_q cl := + Z.min (premise_min (premise cl)) (concl cl).2. + +(* For checking we start from an a prems -> concl we +*) + Program Definition loop_check cls (cl : clause) : result (premises_model (clauses_levels cls) None cl).1 LevelSet.empty cls (premises_model (clauses_levels cls) None cl).2 := let V := clauses_levels cls in - loop (premises_model V None cl).1 LevelSet.empty cls (premises_model V None cl).2 (premises_model V None cl).2 _. + let i := None in + loop (premises_model V i cl).1 LevelSet.empty cls (premises_model V i cl).2 (premises_model V i cl).2 _. Next Obligation. split => //. - lsets. @@ -919,7 +926,761 @@ Definition checking_clause (cl : clause) := now right. Qed. -Theorem check_invalid_allm {cls cl mcheck} : +Definition is_total_model m cls := + Model.enabled_clauses m cls /\ is_model cls m. + +Definition is_enabled_clause m cl := + isSome (min_premise m (premise cl)). + +Lemma reflect_enabled m cl : reflect (enabled_clause m cl) (is_enabled_clause m cl). +Proof. + rewrite /is_enabled_clause /enabled_clause. + destruct min_premise => //=. + constructor; now eexists. + constructor. intros [z eq] => //. +Qed. + +Definition split_clauses m cls := + Clauses.partition (is_enabled_clause m) cls. + +Definition enabled_clauses_of m cls := (split_clauses m cls).1. +Definition disabled_clauses_of m cls := (split_clauses m cls).2. + +Lemma split_clauses_spec_1 m cls : + cls =_clset Clauses.union (enabled_clauses_of m cls) (disabled_clauses_of m cls). +Proof. Admitted. + +Lemma enabled_clauses_spec m cl cls : Clauses.In cl (enabled_clauses_of m cls) <-> Clauses.In cl cls /\ enabled_clause m cl. +Admitted. + +Lemma disabled_clauses_spec m cl cls : Clauses.In cl (disabled_clauses_of m cls) <-> Clauses.In cl cls /\ ~ enabled_clause m cl. +Admitted. + +Lemma nenabled_clause m cl : ~ enabled_clause m cl <-> min_premise m (premise cl) = None. +Proof. + case: (reflect_enabled m cl) => //. + split => //. red in p. firstorder. congruence. + firstorder. cbn in H. destruct min_premise => //. + destruct (H _ eq_refl). +Qed. + +Lemma is_model_split m cls : + is_model cls m <-> (is_total_model m (enabled_clauses_of m cls)). +Proof. + split. + - move/Clauses.for_all_spec => ism. + split. + intros cl. now rewrite enabled_clauses_spec. tc. + apply Clauses.for_all_spec. tc. + move=> cl /enabled_clauses_spec => -[] /ism //. + - move=> -[]. intros en. red in en. red in en. + intros ism. rewrite (split_clauses_spec_1 m cls). + eapply is_model_union. auto. + eapply Clauses.for_all_spec. tc. + move=> [prems [concl k]] /disabled_clauses_spec -[] hin hen. + Search enabled_clause. + apply valid_clause_intro. + now move/nenabled_clause: hen => ->. +Qed. + +Definition extend_model (m m' : model) := + LevelMap.mapi (fun l k => + match LevelMap.find l m' with + | Some (Some k') => Some k' + | _ => k + end) m. +Print on_Some. + +Definition is_le_on_defined m m' := + forall l k, LevelMap.MapsTo l (Some k) m' -> + exists k', LevelMap.MapsTo l (Some k') m /\ k' <= k. + +Lemma extend_model_max m m' : + is_le_on_defined m m' -> + forall l k, LevelMap.MapsTo l (Some k) m' -> + LevelMap.MapsTo l (Some k) (extend_model m m'). +Proof. + move=> isle l k /[dup] hm /isle => -[k' [hm' hle]]. + rewrite /extend_model LevelMapFact.F.mapi_mapsto_iff. + { intros x y e -> => //. } + exists (Some k'). rewrite (LevelMap.find_1 hm). + split => //. +Qed. + +Lemma extend_model_spec m m' : + is_le_on_defined m m' -> + forall l k, LevelMap.MapsTo l k (extend_model m m') -> + on_Some (fun k' => LevelMap.MapsTo l (Some k') m') k \/ + (level_value m' l = None /\ LevelMap.MapsTo l k m). +Proof. + intros hle l k. + rewrite /extend_model. + rewrite LevelMapFact.F.mapi_mapsto_iff. + { now intros x y e ->. } + intros [a [eq hm]]. subst k. + destruct (find_spec l m'). + destruct k; cbn. now left. + rewrite (level_value_MapsTo H). now right. + right. rewrite /level_value. destruct LevelMap.find eqn:hfind => //. + eapply LevelMap.find_2 in hfind. elim H; now exists o. +Qed. + +(* prems = x + kx, y + ky + m'[x] = Some vx + m'[y] = None + + m[x] = Some vx' <= vx + m[y] = Some vy' + + In m: min_premise m prems = min (vx' - kx, vy' - ky) + In m', min= None + In ext: min_premises (ext m m') = min (vx - kx, vy' - ky) + + The minimal premise can hence grow by (vx - vx'). + + We would like min_premise (x + kx, y + ky) +*) + +Lemma min_premise_extend_model_min {m m' prems k} : + is_le_on_defined m m' -> + min_premise (extend_model m m') prems = Some k -> + (* min_premise m' prems = None -> *) + exists k', min_premise m prems = Some k' /\ k' <= k. +Proof. + move=> isdef. + move: prems k. + apply: elim. + - intros [minp minl] k; rewrite !min_premise_singleton. + rewrite /min_atom_value. + destruct level_value eqn:hext => //=. + eapply level_value_MapsTo' in hext. + eapply extend_model_spec in hext; tea. cbn in hext. + destruct hext. intros [= <-]. + have [k' [hm hleq]] := (isdef minp _ H). + rewrite (level_value_MapsTo hm) => //. + exists (k' - minl). split; trea. lia. + destruct H as [lm' hm']. + intros [= <-]. + rewrite (level_value_MapsTo hm'). + eexists; split; trea. + - intros [le lek] prems heq hnin. + rewrite !min_premise_add. + destruct (min_premise (extend_model _ _) _) eqn:minext. + 2:{ intros k. now move/min_opt_None_right. } + specialize (heq _ eq_refl). + intros k. + destruct min_atom_value eqn:hl => //. + move=> [=] hz; subst k. + unfold min_atom_value in hl. + move: hl; case: (@level_valueP _ le) => //. + intros [extv|] => // /extend_model_spec. + move/(_ isdef) => //. + intros []. + + intros [= <-]. cbn in H. + destruct heq as [k' [-> hle]]. + have [k'' [hm hleq]] := isdef le _ H. + rewrite (min_atom_value_mapsto hm). cbn. + eexists; split; trea. lia. + + intros [= <-]. + destruct H. + destruct heq as [k' [-> hle]]. + rewrite (min_atom_value_mapsto H0). cbn. + eexists; split; trea. lia. +Qed. + + +Lemma min_premise_extend_model_max {m m' prems k} : + is_le_on_defined m m' -> + min_premise (extend_model m m') prems = Some k -> + forall k', min_premise m' prems = Some k' -> k = k'. +Proof. + intros isdef hmin. + intros k' minp. + move: prems k k' hmin minp. + apply: elim. + - intros [l lk] k k'. + rewrite !min_premise_singleton /min_atom_value. + destruct level_value eqn:hl => //. + intros [= <-]. + eapply level_value_MapsTo' in hl. + eapply extend_model_spec in hl as [hl|[hl hm']] => //. + cbn in hl. rewrite (level_value_MapsTo hl). now intros [= <-]. + now rewrite hl. + - intros [l lk] prems ih hnin k k'. + rewrite !min_premise_add. + destruct (min_premise (extend_model _ _) _) eqn:minext => //=. + 2:{ now move/min_opt_None_left. } + destruct level_value eqn:hl => //. + intros [= <-]. + eapply level_value_MapsTo' in hl. + eapply extend_model_spec in hl as [hl|[hl hm']] => //. + cbn in hl. rewrite (level_value_MapsTo hl). + destruct (min_premise m' prems) eqn:eqmin => //. + intros [= <-]. + specialize (ih _ _ eq_refl eq_refl). subst z1. + reflexivity. + rewrite hl. now move/min_opt_None_right. +Qed. + +Lemma min_premise_extend_model_spec m m' prems k : + is_le_on_defined m m' -> + min_premise (extend_model m m') prems = Some k -> + (min_premise m' prems = None /\ + exists k', min_premise m prems = Some k' /\ k' <= k) \/ + (min_premise m' prems = Some k). +Proof. + intros isdef minpext. + have := min_premise_extend_model_min isdef minpext. + have := min_premise_extend_model_max isdef minpext. + destruct (min_premise m' prems). + move=> hmax hmin. right => //. specialize (hmax _ eq_refl). subst. + reflexivity. + left. split => //. +Qed. + +Lemma extended_model_le_init m m' : m ⩽ extend_model m m'. +Proof. Admitted. + +Lemma extended_model_le_final m m' : m' ⩽ extend_model m m'. +Proof. Admitted. + +Lemma level_value_ext_max {l} {m m' : model} {k} : + level_value m' l = Some k -> + level_value (extend_model m m') l = Some k. +Proof. Admitted. + +(** + Checking starting from a lowered model. + + cls = max(x, v) >= y, x, v, y >= 0. + + check (x -> y) = false + minit := x = 0, v = - 1, y = -1, 0 = -1 + final = x = 0, v = -1, y = -1, 0 = 0 + + Indeed ~ valid (x >= y). + + Now x >= v as well. + minit := x = 0, v = - 1, y = -1, 0 = -1 + final = x = 0, v = 0, y = 0, 0 = 0 + + of_level_map minit -> of_level_map final <-> + + max (x, v - 1, y - 1, Set - 1) >= (x, v, y, Set) + can one infer x >= y from this? + yes. + +*) + +Definition levels_of_model (m : model) := + LevelMap.fold (fun l _ acc => LevelSet.add l acc) m LevelSet.empty. + +Module check'. + +Definition premises_model m cl : LevelSet.t * model := + let levels := LevelSet.union (clause_levels cl) (levels_of_model m) in + (levels, premises_model_map m (Clauses.singleton (add_clause (model_max m + 1) cl))). + +Print premises_model. +Print min_atom_value. +Program Definition loop_check m cls (cl : clause) + (hcls : levels_of_model m =_lset clauses_levels cls) : + let minit := premises_model m cl in + result minit.1 LevelSet.empty cls minit.2 := + let V := clauses_levels cls in + let minit := premises_model m cl in + loop minit.1 LevelSet.empty cls minit.2 minit.2 _. +Next Obligation. + split => //. + - lsets. + - intros l. rewrite LevelSet.union_spec. + rewrite -/(LevelMap.In l (premises_model m cl).2). + todo "scope". + (* rewrite in_premises_model. intuition auto. *) + - apply is_update_of_empty. +Qed. + +(* +Lemma valid_model_find' {V W cl cls} : + forall v : valid_model (clause_levels cl ∪ V) W (premises_model' m) (Clauses.singleton cl)) cls, + ~ LevelMap.find (concl cl).1 (model_model v) = None. +Proof. + intros v hfind. + destruct cl as [prems [concl k]]; cbn in *. + have vmupd := model_of_V v. + set (pm := premises_model_map _ _) in *. + move/LevelMapFact.F.not_find_in_iff: hfind; apply. + apply vmupd. rewrite LevelSet.union_spec; left. + rewrite clause_levels_spec. now right. +Qed. *) + +Equations check_gen (m : model) cls (cl : clause) : check_result cls := +check_gen m cls cl with inspect (loop_check m cls cl (todo "pre")) := + { | exist (Loop v _ isl) he => IsLooping v _ isl + | exist (Model W v _) he with inspect (LevelMap.find (concl cl).1 v.(model_model)) := { + | exist (Some val) he' with check_atom_value (Some (1 + model_max m + (concl cl).2)) val := + { | true => Valid + | false => Invalid v.(model_model) } + | exist None he' := todo "nempty" + (* with valid_model_find v he' := {} *) + } + }. + +Lemma entails_prem {cls m prems concl k ne ne'} : + let SL := horn_semi cls in + let pm := + (premises_model_map m + (Clauses.singleton (add_clause (model_max m + 1) (prems, (concl, k))))) + in + of_level_map pm ne ≡ + add_prems (model_max m + 1) prems ∨ of_level_map m ne'. +Proof. cbn in ne. +Admitted. + +Lemma add_n_succ {cls} {n : nat} (x : premises) : + let SL := horn_semi cls in + (x ∨ add (- Z.of_nat n) x ≡ x)%sl. +Proof. + intros SL. + induction n. + - cbn. rewrite add_prems_0. apply (join_idem (Semilattice := SL)). + - rewrite Nat2Z.inj_succ. + have ha := add_prems_add_prems (-1) (-Z.of_nat n) x. + have eq : - Z.of_nat n = 1 + - Z.succ (Z.of_nat n). lia. + cbn in ha. + rewrite -{1}IHn. + rewrite join_assoc. + rewrite (join_comm (add _ x)). + rewrite eq. + rewrite -add_distr. + rewrite join_sub. + rewrite add_distr. + cbn. rewrite -eq. apply IHn. +Qed. + +Lemma succ_le_inj_neg {cls} (u v : premises) : + let SL := horn_semi cls in + @Consistent _ _ _ SL -> + @EqDec _ _ _ SL -> + succ v ≤ succ u ∨ v -> ~ succ u ≤ v. +Proof. + intros SL con eq. + intros le. red in le. + intros hs. red in hs. rewrite hs in le. + rewrite join_comm join_sub in le. + apply symmetry in le. now apply con in le. +Qed. + +Lemma succ_le_inj {cls} (u v : premises) : + let SL := horn_semi cls in + @Consistent _ _ _ SL -> + @Total _ _ _ SL -> + succ v ≤ succ u ∨ v -> succ v ≤ succ u. +Proof. + intros SL con eq. + intros le. red in le. + destruct (eq v u). + - now eapply (le_add (n:=1)) in H. + - red in H. + have hs : succ v ≤ v ∨ v. + { transitivity (succ u ∨ v) => //. + apply join_le_pres. exact H. reflexivity. } + rewrite join_idem in hs. + specialize (con v). + elim con. apply eq_antisym. + split. red. now rewrite join_sub. + exact hs. + Qed. + + +Lemma add_inj {cls} (u v : premises) : + let SL := horn_semi cls in + @Consistent _ _ _ SL -> + @Total _ _ _ SL -> + add_prems 1 u ∨ add_prems 1 v ≡ add_prems 1 u ∨ v -> + u ∨ v ≡ u. +Proof. + intros SL con eq. + rewrite eq_antisym. + intros []. apply eq_antisym. split. + rewrite join_comm. apply join_le_left_eq. split. 2:{ reflexivity. } + apply (le_add (n:=1)). clear H0. + change (succ v ≤ succ u). + apply join_le_left_eq in H as []. + now apply succ_le_inj in H0. + apply join_le_left. +Qed. + +Lemma inject cls u v : + let SL := horn_semi cls in + @Consistent _ _ _ SL -> + @Total _ _ _ SL -> + (cls ⊢a u ∨ (add (-1) v) → u ∨ v)%sl -> + cls ⊢a u → v. +Proof. + intros SL con tot clsu. + eapply entails_all_concl_union in clsu as [entu entv]. + eapply to_entails_all in entv. + eapply to_entails_all. + eapply Theory.le_spec in entv. + unfold Clauses.le in entv. + apply Theory.le_spec. unfold Clauses.le. + rewrite -union_assoc in entv. + rewrite (@union_comm v u) in entv. + rewrite union_assoc in entv. + have h := (@add_n_succ cls 1 v). cbn -[eq] in h. + change (u ∨ (v ∨ add_prems (-1) v) ≡ u ∨ add_prems (-1) v) in entv. + move: entv. unfold SL. + setoid_rewrite h. + intros entv. rewrite union_comm. + change (u ∨ v ≡ u). + apply (eq_antisym (SL := SL)). split. + eapply (add_congr 1) in entv. + rewrite !add_join in entv. + rewrite add_distr [add (1 + -1)%Q _]add_prems_0 in entv. + apply add_inj in entv. + change (u ∨ v ≤ u). now rewrite entv. + red. intros nu he. cbn in he. + specialize (con nu). contradiction. exact tot. + rewrite join_comm. apply join_le_right. +Qed. + +Lemma to_SL cls x y : + let SL := horn_semi cls in + cls ⊢ℋ x ⋞ y <-> x ≤ y. +Proof. + intros SL. + now cbn; rewrite Theory.le_spec /Clauses.le. +Qed. + +Lemma inject' cls u v w : + let SL := horn_semi cls in + @Consistent _ _ _ SL -> + @Total _ _ _ SL -> + (w ≤ (u ∨ add (-1) v)%nes) -> + forall atom, LevelExprSet.In atom w -> + add (-1) v ≤ (u ∨ add (-1) w)%nes -> + cls ⊢ u → atom. +Proof. + intros SL con tot huv atom hin natom. + assert (hi := inject cls u w con tot). + rewrite -to_entails_all in hi. + rewrite -entails_all_singleton. + forward hi. + { clear hi. + rewrite to_SL. + transitivity (u ∨ add (-1) v). + eapply (join_le_left_eq (SL:=SL)). + split. eapply join_le_left. exact huv. + eapply (join_le_left_eq (SL:=SL)). split. + apply (join_le_left (SL:=SL)). + apply natom. } + eapply entails_all_singleton. + now specialize (hi _ hin). +Qed. + +(* Lemma atoms_of_shift m n k : + atoms_of_model (shift_model (n + k)%Z m) = + add_prems n (atoms_of_model (shift_model k m)). +Proof. Admitted. *) + +Lemma of_level_map_ext cls {m m'} hne hne' : + m ⩽ m' -> + cls ⊢a of_level_map m' hne' → of_level_map m hne. +Proof. + intros ext [l k] ina. + eapply of_level_map_spec in ina. + eapply ext in ina as [k' [hm hin']]. + depelim hin'. + have [y' eq] : exists y' : nat, k + Z.of_nat y' = y. + { exists (Z.to_nat (y - k)). lia. } + eapply (entails_pred_closure_n (n := y')). + rewrite eq. + constructor. now eapply of_level_map_spec. +Qed. + +Definition all_equiv cls u u' := + cls ⊢a u → u' /\ cls ⊢a u' → u. + +Notation " cls ⊢a u =a u' " := (all_equiv cls u u'). + +Lemma all_equiv_clause {cls u u'} : + let SL := horn_semi cls in + cls ⊢a u =a u' <-> (u ≡ u')%sl. +Proof. + intros SL. + unfold all_equiv. + rewrite -!to_entails_all. + rewrite !to_SL. + rewrite eq_antisym. + split; intuition. +Qed. + +Definition lt_model V m m' := model_rel_partial Z.lt V m m'. + +Lemma entails_partial {cls W m m'} : + model_of W m -> + is_update_of cls W m m' -> + LevelSet.Empty W /\ m =m m' \/ lt_model W m m'. +Proof. + move=> mof. + move/is_update_of_case. + intros []. now left. + right. now eapply strictly_updates_model_lt. +Qed. + +Axiom of_restricted_level_map : forall (V : LevelSet.t) (m : model), premises. + +Lemma entails_of_level_map {cls W m hne m'} : + model_of W m -> + is_update_of cls W m m' -> + cls ⊢a of_level_map m hne =a of_level_map m hne ∨ + add_prems 1 (of_restricted_level_map W m). +Proof. Admitted. + +Lemma inject2 cls (u v w : premises) : + let SL := horn_semi cls in + @Consistent _ _ _ SL -> + @Total _ _ _ SL -> + (w ≤ u ∨ v)%sl -> + (v ≤ add (-1) w)%sl -> + (w ≤ u). +Proof. + intros SL con tot huv hvw. + assert (hi := inject cls u w con tot). + rewrite -to_SL to_entails_all. apply hi. + rewrite -to_entails_all to_SL. + (* eassert (ha := le_add (x:=v) (y:=w) (n := -1)). *) + (* apply ha in hvw. *) + (* rewrite add_distr add_neutral in hvw. *) + change (u ∨ w ≤ u ∨ (add (-1) w))%sl. + eapply join_le_left_eq. split. apply join_le_left. + transitivity (u ∨ v). exact huv. + eapply join_le_pres. reflexivity. exact hvw. +Qed. + +Lemma inject_max cls w (u v : premises) : + let SL := horn_semi cls in + @Consistent _ _ _ SL -> + @EqDec _ _ _ SL -> + (singleton w ≤ u ∨ v)%sl -> + premise_max v < w.2 -> + singleton w ≤ u. +Proof. + intros SL con eq hsing hlt. + destruct (eq u v). admit. + +Admitted. + +Lemma premise_max_of_level_map {m hdef} : premise_max (of_level_map m hdef) <= model_max m. +Proof. + have [hf [[maxpl maxpk] [hin eq]]] := premise_max_spec (of_level_map m hdef). + rewrite eq. + eapply of_level_map_spec in hin. + cbn in eq. cbn. + have hm := model_max_spec m _ _ hin. + now depelim hm. +Qed. + +(* If a clause checks, then it is entailed (and will be valid in any extension of the model) *) +Theorem check_gen_entails {m cls cl} : + (concl cl).2 >= 0 -> + check_gen m cls cl = Valid -> entails cls (add_clause (model_max m + 1) cl). +Proof. + destruct cl as [prems [concl k]]. + move=> kpos. cbn in kpos. + funelim (check_gen m cls _) => //. + { todo "empty". } + move=> _. + set (V := (clause_levels _ ∪ levels_of_model m)%levels) in *. + clear Heqcall H H0. cbn [concl fst snd] in *. + move/check_atom_value_spec: Heq; intros h; depelim h. rename H into hgt. + have vmupd := model_updates v. + have vmok := model_ok v. + set (pm := premises_model_map _ _) in *. + have nepm : defined_map pm. + { apply premises_model_map_defined. + set (cl := (prems, _)) in *. + move/(_ (add_clause (model_max m + 1) cl)). + rewrite Clauses.singleton_spec. congruence. } + have nev : defined_map (model_model v). + by apply (is_update_of_defined_map nepm vmupd). + have hleq := is_update_of_ext vmupd. + have vmupd' := vmupd. + move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. + have ent' := (of_level_map_ext cls nepm nev hleq). + have equiv : cls ⊢a (of_level_map (model_model v) nev) =a + (of_level_map pm nepm). + split => //. + set (cl := add_clause (model_max m + 1) (prems, (concl0, k))) in *. + have defm : defined_map m. admit. + assert (hl := entails_prem (ne' := defm) (cls := cls) (ne := nepm)). + apply all_equiv_clause in equiv. + eapply to_entails_all, to_SL in ent. + rewrite hl in ent. + enough (cls ⊢ add_prems (model_max m + 1) prems → (concl0, y)). + { have hi : exists y' : nat, model_max m + 1 + k + Z.of_nat y' = y. + assert (y >= 0). admit. + have mmax := model_max_spec2 m. + exists (Z.to_nat (y - (1 + model_max m + k))). lia. + destruct hi as [y' eq]. + eapply (entails_pred_closure_n (n := y')). + cbn. now rewrite eq. } + set (SL := horn_semi cls). + assert (hsp : singleton (concl0, y) ≤ of_level_map (model_model v) nev). + { apply to_SL, to_entails_all, entails_all_singleton. + constructor. rewrite of_level_map_spec. + now eapply LevelMap.find_2 in he'. } + move/is_update_of_case: vmupd'. + intros [[empW eqm]|su]. + { rewrite -eqm in he'. + have [k' eq] : exists k', model_max m + 1 + k' = y. + exists (y - (1 + model_max m)). lia. + subst y. + rewrite -entails_all_singleton. + eapply to_entails_all. + rewrite to_SL. + have k'pos : k' >= 0. lia. + rewrite equiv in hsp. + rewrite hl in hsp. + eapply inject_max in hsp. exact hsp. + admit. red. cbn. admit. cbn -[le]. + have hmp := @premise_max_of_level_map m defm. + cbn. lia. + Abort. +End check'. + + + +Lemma valid_enabled_inverse m cl : + enabled_clause m (checking_clause cl) -> + valid_clause m (checking_clause cl) = false -> + valid_clauses m (inverse_clauses (checking_clause cl)). +Proof. + destruct cl as [prems [concl kconcl]]. + intros en vcl cl hin. + unfold inverse_clauses in hin. + eapply clauses_of_le_spec in hin as [[l k] [hin heq]]. subst cl. + apply valid_clause_intro. + move=> z hmin. red in en. cbn in en. + destruct en as [z' hz]. + eapply min_premise_spec_aux in hz as [hf hex]. + rewrite min_premise_singleton in hmin. + rewrite /min_atom_value in hmin. + rewrite add_prems_union in hin. + rewrite add_prems_singleton in hin. + rewrite LevelExprSet.union_spec /singleton //= in hin. + destruct hin. rsets. noconf H. + rewrite /min_atom_value in hmin. + destruct (level_value m concl) eqn:hl => //. noconf hmin. constructor. lia. + rewrite map_levelexprset_spec in H. destruct H as [[l' k'] [hin heq]]. + noconf heq. + move: vcl. + unfold valid_clause. cbn. + destruct min_premise eqn:hmin'. + rewrite /level_value_above. rewrite /min_atom_value in hmin. + destruct level_value eqn:hl => //. noconf hmin. + move: hmin'. + rewrite union_comm NES.union_add_singleton min_premise_add. + rewrite /min_atom_value //= hl. + destruct (min_premise m prems) eqn:hmprems => //=. + intros [= <-]. + apply min_premise_spec_aux in hmprems as [hfp exp]. + specialize (hfp _ hin). rewrite /min_atom_value in hfp. + destruct (level_value m l) eqn:hl'. depelim hfp. + move/Z.leb_gt => h. constructor. lia. + depelim hfp. + move=> //. +Qed. + + +Theorem check_invalid_inverse {cls cl mcheck} : + check_gen cls (checking_clause cl) = Invalid mcheck -> + is_model (inverse_clauses (checking_clause cl)) mcheck. +Proof. + (* destruct cl as [prems [concl k]]. *) + move/check_invalid => [ism mofm minm encl invcl]. + move/negP/negPf: invcl. + rewrite /is_model => neg. apply Clauses.for_all_spec; tc. + now apply valid_enabled_inverse. +Qed. + + +(*Theorem check_invalid_allm {cls cl mcheck} : + check_gen cls (checking_clause cl) = Invalid mcheck -> + let minit := check_init_model cls (checking_clause cl) in + forall m, is_total_model m cls -> + exists m', model_of (clauses_levels cls ∪ clause_levels cl) m' /\ is_total_model m' cls /\ ~ valid_clause m' cl. +Proof. + move/check_invalid => [ism mofm minm encl invcl]. + intros minit m [entot mtot]. + + + + exists (extend_model m mcheck); split. + - todo "scope". + - have hledef : is_le_on_defined m mcheck. admit. + split. + split. todo "enabled". + apply Clauses.for_all_spec; tc. + move/Clauses.for_all_spec: ism. + move/Clauses.for_all_spec: mtot. + move=> ha ha' [prems [concl k]] /[dup]/ha /valid_clause_elim h /ha' /valid_clause_elim vmcheck. + apply valid_clause_intro => minpext minp. + eapply min_premise_extend_model_spec in minp as [[ninm' [minmp [inm leq]]]|inmcheck] => //. + * specialize (h _ inm). + move: (extended_model_le_init m mcheck) => /(_ concl). + move: (@level_valueP m concl) h; case => k0 hm hle. depelim hle. + move/(_ _ hm) => -[] k' [] hm' hle'. depelim hle'. + rewrite (level_value_MapsTo hm'). constructor. + (** The minimial premise in the extension might have been shifted + by a value in mcheck still. + + prems must be of the shape (x + k, y + k'...) where x is not defined in mcheck + but y is. + the minimal premise in the extension might become + [(ext m mcheck)[x] - k] = [m[x] -k] or [(ext m mcheck)[y] - k'] = [mcheck[y] - k']. + In the first case we don't move the premise, so we are fine. + In the second case we would need to argue that + mcheck[y] - k' <= min_premise m (x + k, y + k', ...) + + *) + have minpextd : minpext <= minmp + model_max mcheck. admit. + have minpextd' : y = y0 \/ y + model_max mcheck <= y0. admit. + destruct minpextd'. subst. 2:lia. + admit. + (* lia. depelim hm. *) + * specialize (vmcheck _ inmcheck). + move: (@level_valueP mcheck concl) vmcheck; case. + 2:{ intros hin hle; depelim hle. } + move=> k0 hm hle. depelim hle. + have hmext := extend_model_max m mcheck hledef _ _ hm. + rewrite (level_value_MapsTo hmext). constructor => //. + * destruct cl as [prems [concl k]]. + move/valid_clause_elim => hz. apply invcl. + apply valid_clause_intro. + intros z minp. + rewrite union_comm union_add_singleton in minp. + rewrite min_premise_add in minp. + destruct (min_premise mcheck prems) as [minmcheck|] eqn:minpchk; cbn in minp; + move => //. + destruct (level_value mcheck concl) as [vconclchk|] eqn:vconclmcheck; + cbn in minp => //. + 2:{ now apply min_opt_None_right in minp. } + noconf minp. + constructor. + destruct (min_premise (extend_model m mcheck) prems) eqn:minpext. + 2:{ todo "minnon". } + specialize (hz _ eq_refl). + have hi := @min_premise_extend_model_max m mcheck prems z hledef. + rewrite minpext in hi. specialize (hi eq_refl). + specialize (hi _ minpchk). subst z. + rewrite (level_value_ext_max vconclmcheck) in hz. + depelim hz. lia. +Qed. *) + + +(*Theorem check_invalid_allm {cls cl mcheck} : check_gen cls (checking_clause cl) = Invalid mcheck -> let minit := check_init_model cls (checking_clause cl) in forall m, is_model cls m -> @@ -966,7 +1727,7 @@ Proof. destruct conclv as [conclv|]. case: Z.leb_spec => //= hlt _ /Z.leb_le. lia. auto. -Qed. +Qed.*) (* @@ -2237,14 +2998,14 @@ Lemma opt_valuation_of_model_equiv m l : Lemma enforce_dec m cls : clauses_levels cls ⊂_lset levels m -> { consistent (Clauses.union (clauses m) cls) } + - { inconsistent (Clauses.union (clauses m) cls) }. + { inconsistent_opt_ext m cls }. Proof. intros hm. destruct (enforce_clauses m cls) eqn:ec. destruct s as [model|loop]. - left. move/enforce_clauses_clauses: ec. intros <-. apply clauses_consistent. - - right. now move/enforce_clauses_inconsistent: ec. + - right. now move/enforce_clauses_inconsistent_opt: ec. (* intros he v semcs semc. red in he. specialize (he ) apply he. red. exists v. split => //. @@ -2516,7 +3277,7 @@ Lemma opt_valuation_of_model_equiv m l : Import Semilattice. - Lemma clauses_sem_clauses_of_le (V : Level.t -> Z) l r : + Lemma clauses_sem_clauses_of_le {S} {SL : Semilattice S Q.t} (V : Level.t -> S) l r : clauses_sem V (clauses_of_le l r) -> (interp_nes V l ≤ interp_nes V r)%sl. Proof. @@ -2528,14 +3289,16 @@ Lemma opt_valuation_of_model_equiv m l : rewrite interp_nes_singleton. move: (he (r, le)) => /fwd. exists le. split => //. now apply LevelExprSet.singleton_spec. - cbn. lia. + now cbn. - intros le x ih hnin ih'. rewrite interp_nes_add. forward ih. intros x0 [x1 [hin ->]]. move: (ih' (r, x1)) => /fwd. exists x1. split => //. apply LevelExprSet.add_spec. now right. auto. move: (ih' (r, le)) => /fwd. exists le. split => //. apply LevelExprSet.add_spec. now left. - cbn. cbn in ih. lia. + cbn. cbn in ih. rewrite /Semilattice.le. + move: ih. rewrite /Semilattice.le. + now rewrite join_assoc; intros ->. Qed. Lemma clauses_sem_tot_inverse_false (v : Level.t -> Z) (cl : clause) : @@ -2764,66 +3527,9 @@ Definition check_clause m cl := Definition consistent_clauses cls := exists val : Level.t -> Z, positive_valuation val /\ clauses_sem val cls. -Definition is_enabled_clause m cl := - isSome (min_premise m (premise cl)). - -Lemma reflect_enabled m cl : reflect (enabled_clause m cl) (is_enabled_clause m cl). -Proof. - rewrite /is_enabled_clause /enabled_clause. - destruct min_premise => //=. - constructor; now eexists. - constructor. intros [z eq] => //. -Qed. - -Definition split_clauses m cls := - Clauses.partition (is_enabled_clause m) cls. - -Definition enabled_clauses m cls := (split_clauses m cls).1. -Definition disabled_clauses m cls := (split_clauses m cls).2. - -Lemma split_clauses_spec_1 m cls : - cls =_clset Clauses.union (enabled_clauses m cls) (disabled_clauses m cls). -Proof. Admitted. - -Lemma enabled_clauses_spec m cl cls : Clauses.In cl (enabled_clauses m cls) <-> Clauses.In cl cls /\ enabled_clause m cl. -Admitted. - -Lemma disabled_clauses_spec m cl cls : Clauses.In cl (disabled_clauses m cls) <-> Clauses.In cl cls /\ ~ enabled_clause m cl. -Admitted. - -Lemma nenabled_clause m cl : ~ enabled_clause m cl <-> min_premise m (premise cl) = None. -Proof. - case: (reflect_enabled m cl) => //. - split => //. red in p. firstorder. congruence. - firstorder. cbn in H. destruct min_premise => //. - destruct (H _ eq_refl). -Qed. - -Definition is_total_model m cls := - Model.enabled_clauses m cls /\ is_model cls m. - -Lemma is_model_split m cls : - is_model cls m <-> (is_total_model m (enabled_clauses m cls)). -Proof. - split. - - move/Clauses.for_all_spec => ism. - split. - intros cl. now rewrite enabled_clauses_spec. tc. - apply Clauses.for_all_spec. tc. - move=> cl /enabled_clauses_spec => -[] /ism //. - - move=> -[]. intros en. red in en. red in en. - intros ism. rewrite (split_clauses_spec_1 m cls). - eapply is_model_union. auto. - eapply Clauses.for_all_spec. tc. - move=> [prems [concl k]] /disabled_clauses_spec -[] hin hen. - Search enabled_clause. - apply valid_clause_intro. - now move/nenabled_clause: hen => ->. -Qed. - Lemma equiv_all_models cls cl : (forall m, is_model cls m -> enabled_clause m cl -> valid_clause m cl) <-> - (forall m, is_total_model m (enabled_clauses m cls) -> enabled_clause m cl -> valid_clause m cl). + (forall m, is_total_model m (enabled_clauses_of m cls) -> enabled_clause m cl -> valid_clause m cl). Proof. now setoid_rewrite is_model_split. Qed. (* @@ -2847,53 +3553,45 @@ Proof. (* Admitted. *) -Lemma valid_enabled_inverse m cl : - enabled_clause m (checking_clause cl) -> - valid_clause m (checking_clause cl) = false -> - valid_clauses m (inverse_clauses (checking_clause cl)). -Proof. - destruct cl as [prems [concl kconcl]]. - intros en vcl cl hin. - unfold inverse_clauses in hin. - eapply clauses_of_le_spec in hin as [[l k] [hin heq]]. subst cl. - apply valid_clause_intro. - move=> z hmin. red in en. cbn in en. - destruct en as [z' hz]. - eapply min_premise_spec_aux in hz as [hf hex]. - rewrite min_premise_singleton in hmin. - rewrite /min_atom_value in hmin. - rewrite add_prems_union in hin. - rewrite add_prems_singleton in hin. - rewrite LevelExprSet.union_spec /singleton //= in hin. - destruct hin. rsets. noconf H. - rewrite /min_atom_value in hmin. - destruct (level_value m concl) eqn:hl => //. noconf hmin. constructor. lia. - rewrite map_levelexprset_spec in H. destruct H as [[l' k'] [hin heq]]. - noconf heq. - move: vcl. - unfold valid_clause. cbn. - destruct min_premise eqn:hmin'. - rewrite /level_value_above. rewrite /min_atom_value in hmin. - destruct level_value eqn:hl => //. noconf hmin. - move: hmin'. - rewrite union_comm NES.union_add_singleton min_premise_add. - rewrite /min_atom_value //= hl. - destruct (min_premise m prems) eqn:hmprems => //=. - intros [= <-]. - apply min_premise_spec_aux in hmprems as [hfp exp]. - specialize (hfp _ hin). rewrite /min_atom_value in hfp. - destruct (level_value m l) eqn:hl'. depelim hfp. - move/Z.leb_gt => h. constructor. lia. - depelim hfp. - move=> //. -Qed. - Definition finite_premise (v : Level.t -> option Z) cl := exists k, interp_nes v (premise cl) = Some k. Definition finite_clause (v : Level.t -> option Z) cl := finite_premise v cl /\ isSome (v (concl cl).1). +(* cls = { x, y -> y + 1; x, z -> y + 2 } + + Goal x -> y + + y - 1 -> y - 1 + + x, y - 1 -> y - 1 + + x + 1, y -> y + + x, x + 1, y -> y + + x, x + 1, y -> y + 1 + + + + x + + max (x, y) >= y+1 <-> x >= y+1 \/ y >= y+1 <-> x >= y+1 -> x >= y + + + check (x -> y) + + cls |- x -> y + 2 <-> cls |- x + 1 , y -> y + 1 + + { x = 0, y = U } + + + check { x = 1, y = 0 } -> { x = 1, y = 1 } -> {x = 1, y = 2} + Then test 1 <= v[y]{ x = 1, y = 2} - 1 + +*) + (* The valution here is in 𝐙 + ∞: - clauses max (∞, ...) >= x are trivially valid. - clauses max ... >= ∞ are invalid. @@ -2905,6 +3603,13 @@ Definition valid_clause_Zinf cls cl := (* finite_clause v cl -> *) clause_sem v cl. +Definition valid_clauses_Zinf cls cls' := + forall v : Level.t -> option Z, + positive_opt_valuation v -> + clauses_sem v cls -> + (* finite_clause v cl -> *) + clauses_sem v cls'. + Definition valid_clause_Z cls cl := forall v : Level.t -> Z, positive_valuation v -> @@ -2959,32 +3664,95 @@ Proof. move/check_invalid_valuation => [vpos csem hdef clsem]. now move=> /(_ (opt_valuation_of_model mcheck) vpos csem). Qed. +(* +Lemma invalid_clause_Zinf_em m cl : + ~ enforce_clauses m cl -> ~ valid_clauses_Zinf (clauses m) (inverse_clauses cl) -> False. +Proof. + intros vc nc'. apply nc'. red. + intros. + have hc : clauses_sem v (inverse_clauses cl) \/ ~ clauses_sem v (inverse_clauses cl). + admit. + destruct hc => //. elim nc'. + intros v' H' H0'. *) + +Lemma incon_forall cls : ~ consistent cls -> (forall v : Level.t -> Z, positive_valuation v -> clauses_sem v cls -> False). +Proof. + intros incon v hpos csem. apply incon. exists v. split => //. +Qed. + +(* Lemma incon_opt_ext_forall m cls : inconsistent_opt_ext m cls -> (forall v : Level.t -> Z, positive_valuation v -> clauses_sem v clauses_sem v cls -> False). +Proof. + intros incon v hpos csem. + red in incon. Search entails_loop. red in incon. + destruct incon as [loop [incl ent]]. + eapply entails_L_entails_ℋ_equiv in ent. + eappply entails + apply incon. exists v. split => //. +Qed. *) + +Lemma entails_equiv {cls l r u} : Clauses.union cls (clauses_of_le l r) ⊢ r → u -> + cls ⊢ l ∨ r → u. +Proof. + Print entails. + Search entails. + intros h; depind h. + - constructor. rewrite union_spec. now right. + - +Admitted. + + +Lemma entails_thin m prems concl : + clauses m ⊢ succ prems → concl -> + clauses m ⊢ succ prems ∨ singleton concl → succ_expr concl -> + clauses m ⊢ prems → concl. +Proof. + intros enpremconcl ent. + set (SL := horn_semi (clauses m)). + rewrite -entails_all_singleton. + eapply (entails_all_shift 1). + eapply entails_all_trans; tea. + 2:{ rewrite add_prems_singleton. eapply entails_all_singleton. exact ent. } + eapply entails_all_concl_union. split. eapply entails_all_tauto. + now eapply entails_all_singleton. +Qed. Lemma check_clause_invalid_Z m mcheck cl : clause_levels cl ⊂_lset (levels m) -> - check_gen (clauses m) cl = Invalid mcheck -> ~ valid_clause_Z (clauses m) cl. + check_gen (clauses m) (checking_clause cl) = Invalid mcheck -> ~ valid_clause_Z (clauses m) (checking_clause cl). Proof. move=> hwf. - move/check_invalid_allm => /(_ (model m) (model_ok (model_valid m))). - move=> /fwd. - { (* This means the conclusion's level in the inital model to check should - be set at least as high as in the current clauses. This should follow - from minimality. *) - red. - red. unfold model_rel. - todo "level of conclusion". } - move=> /fwd. - { red. todo "scope, easy". } - move=> /fwd. - { todo "check_init_model <= model m, to investigate". } - move=> invalidc vc. apply invalidc. - red in vc. move: (vc (Z_valuation_of_model m)) => /fwd. - eapply valuation_of_model_pos. - move/(_ (model_valuation m)). - rewrite def_clause_sem_valid //. - { eapply defined_model_of_subset; tea. - eapply defined_model. } -Qed. + intros inval nv. + destruct (enforce_dec m (inverse_clauses (checking_clause cl))). admit. + - red in c. + destruct c as [val [hpos csems]]. + eapply clauses_sem_union in csems as []. + specialize (nv _ hpos H). + destruct cl as [prems [concl k]]. cbn in nv, H0. + eapply clauses_sem_clauses_of_le in H0. cbn in H0. + rewrite interp_add_prems interp_nes_singleton //= in H0. lia. + - have minv := check_invalid_inverse inval. + move/check_invalid: inval => [ism]. intros. + destruct i as [loop [incl ent]]. + eapply entails_L_entails_ℋ_equiv in ent. + eapply entails_L_rels_entails_L_clauses in ent. + eapply completeness_all in ent. + red in ent. + specialize (ent (option Z) _ (opt_valuation_of_model mcheck)). + rewrite -!interp_rels_clauses_sem in ent. + forward ent. + have ism' : is_model (Clauses.union (clauses m) (inverse_clauses (checking_clause cl))) mcheck. + { eapply is_model_union => //. } + now eapply valid_clauses_model_opt in ism'. + eapply clauses_sem_clauses_of_le in ent. + rewrite interp_add_prems in ent. red in ent. cbn in ent. + destruct (interp_nes _ loop) eqn:hloop. cbn in ent. lia. + admit. + + eapply is_model_valid in ism'. + Search is_model. + + eapply entails_L_completeness in ent. 2:{ } + Search entails. (* From 2c45a3dbe581a7ae0b515fe505be2256d6d0e1cc Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 13 Oct 2025 20:02:20 +0200 Subject: [PATCH 102/164] Minor fix --- common/theories/LoopChecking/Model.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index e6e6274c7..5fbab7cc9 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -3152,7 +3152,7 @@ Module Model (LS : LevelSets). elim H. now eexists. apply ih => //. Qed. - Lemma min_atom_value_mapsto {l k v m} : LevelMap.MapsTo l (Some v) m -> min_atom_value m (l,k) = Some (v - k). + Lemma min_atom_value_mapsto {l k v m} : LevelMap.MapsTo l v m -> min_atom_value m (l,k) = option_map (fun v => v - k) v. Proof. rewrite /min_atom_value //=. now move/level_value_MapsTo => ->. From fe682d68417a07d3d32598d8596033a0bb42bc6b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 13 Oct 2025 22:02:47 +0200 Subject: [PATCH 103/164] Pulled back loop to the initial model --- .../LoopChecking/PartialLoopChecking.v | 89 ++++++++++++++----- 1 file changed, 69 insertions(+), 20 deletions(-) diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index 45d29ac40..910c35a74 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -549,6 +549,28 @@ Proof. now rewrite eq. Qed. + +Instance incl_preorder : PartialOrder LevelSet.Equal LevelSet.Subset. +Proof. + red. intros x y. split. + - unfold relation_conjunction; cbn. intros ->. split; auto. reflexivity. + red. reflexivity. + - cbn; unfold flip. lsets. +Qed. + +Instance rew_sub : RewriteRelation LevelSet.Subset := {}. + + +Instance incl_cls_preorder : PartialOrder Clauses.Equal Clauses.Subset. +Proof. + red. intros x y. split. + - unfold relation_conjunction; cbn. intros ->. split; auto. reflexivity. + red. reflexivity. + - cbn; unfold flip. clsets. +Qed. + +Instance rew_cls_sub : RewriteRelation Clauses.Subset := {}. + Section InnerLoop. Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) @@ -703,6 +725,17 @@ Proof. - now move/strictly_updates_incl. Qed. +Lemma strictly_updates_update_of {cls W m m'} : + strictly_updates cls W m m' -> + is_update_of cls W m m'. +Proof. + intros su. + rewrite /is_update_of. + destruct LevelSet.is_empty eqn:he => //. + eapply LevelSet.is_empty_spec in he. + eapply strictly_updates_non_empty in su => //. +Qed. + Local Open Scope Z_scope. #[tactic="idtac"] @@ -719,10 +752,10 @@ Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (minit m : mod | Model Wc mwc _ (* We get a model for (cls ↓ W), we check if it extends to all clauses. By invariant |Wc| cannot be larger than |W|. *) - with inspect (check_model cls (Wc, mwc.(model_model))) := + with inspect (check_model cls (W, mwc.(model_model))) := { | exist None eqm' => Model (LevelSet.union W Wc) {| model_model := mwc.(model_model) |} _ | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { - | exist true _ := Loop (of_level_map m' (check_model_defined_map eqm)) _ _ + | exist true _ := Loop (of_level_map minit (check_model_defined_init_map prf eqm)) _ _ | exist false neq' with loop V (LevelSet.union W Wcls) cls minit mcls _ := { (* Here Wcls < V, we've found a model for all of the clauses with conclusion in W, which can now be fixed. We concentrate on the clauses whose @@ -765,47 +798,53 @@ Proof. - intros l; move/incl. apply clauses_levels_mon. apply clauses_with_concl_subset. - now intros ?; rewrite in_clauses_with_concl. - apply LevelSet.equal_spec in e. - set (ne := check_model_defined_map _). clearbody ne. + set (ne := check_model_defined_init_map _ _). clearbody ne. have hu := model_updates mwc. eapply check_model_is_update_of in eqm as [eqm incl]; tea. - have om : only_model_of V m'. - { rewrite union_idem in eqm. - have incl' := strictly_updates_incl eqm. - have hcl := clauses_conclusions_levels cls. - eapply strictly_updates_only_model_gen in eqm; tea. eapply only_model_of_eq; tea. intro; lsets. } eapply strictly_updates_is_update_of in eqm; tea. rewrite union_idem union_with_concl in eqm. eapply check_model_update_of in eqm' as [wmcls [upd eq]]. intros l. rewrite levels_spec => -[k hin]. eapply of_level_map_spec in hin. - specialize (om l) as [_ incl']. + specialize (mof l) as [_ incl']. forward incl'. now eexists. rewrite -e in incl'. eapply strictly_updates_incl in eqm. eapply is_update_of_incl in upd. apply cls_sub. move: incl'; rewrite eq LevelSet.union_spec => -[] incl'. apply eqm. lsets. now apply upd. - - set (ne := check_model_defined_map _). clearbody ne. + - set (ne := check_model_defined_init_map _ _). clearbody ne. + apply LevelSet.equal_spec in e. have hu := model_updates mwc. eapply check_model_is_update_of in eqm as [eqm incl]; tea. - have om : only_model_of V m'. + have inclW : W ⊂_lset V. { rewrite union_idem in eqm. have incl' := strictly_updates_incl eqm. - have hcl := clauses_conclusions_levels cls. - eapply strictly_updates_only_model_gen in eqm; tea. eapply only_model_of_eq; tea. intro; lsets. } + etransitivity; tea. etransitivity; tea. } eapply strictly_updates_is_update_of in eqm; tea. rewrite union_idem union_with_concl in eqm. - eapply check_model_is_update_of in eqm' as [eqm' incl']; tea. - rewrite ClausesProp.union_sym union_with_concl in eqm'. + (* have isupd' : is_update_of cls (W ∪ Wc) minit (model_model mwc). *) + have incl' := is_update_of_incl hu. + rewrite clauses_conclusions_clauses_with_concl in incl'. + have hwwc : W ∪ Wc =_lset W. + { intros l; lsets. } + rewrite hwwc in eqm. + eapply strictly_updates_update_of in eqm. + eapply check_model_is_update_of in eqm' as [eqm' incl2]; tea. + rewrite union_idem in eqm'. rewrite e in eqm'. eapply (strictly_updates_entails_on_V _ _ _ ne) in eqm'. red. eapply entails_all_clauses_subset; tea. - eapply clauses_with_concl_subset. apply LevelSet.equal_spec in e. rewrite e. exact om. + eapply clauses_with_concl_subset. exact mof. - eapply check_model_is_update_of in eqm as [eqm incl]; tea. have hu := model_updates mwc. + have incl' := is_update_of_incl hu. eapply strictly_updates_is_update_of in hu; tea. rewrite union_idem union_with_concl in hu. eapply check_model_update_of in eqm' as [wmcls [upd ->]]. eapply is_update_of_strictly_updates in hu. have tr := is_update_of_trans_eq hu upd. + rewrite clauses_conclusions_clauses_with_concl in incl'. + have hwwc : W ∪ Wc =_lset W. + { intros l. lsets. } split => //. apply tr. clsets. lsets. - right. eapply check_model_spec_V in eqm' as eqm''. 3:etransitivity; [apply clauses_conclusions_levels|exact clsV]. cbn in eqm''. @@ -814,13 +853,19 @@ Proof. eapply strictly_updates_is_update_of in eqm; tea. 2:apply mwc. eapply strictly_updates_model_of_gen in eqm; tea. 2:exact mof. eapply model_of_subset; tea. lsets. } - 2:{ eapply is_update_of_total_model. apply mwc. } + 2:{ apply mwc. } destruct eqm'' as [Hwc Hwcls H1 mext tot]. eapply check_model_is_update_of in eqm as [eqm incl]; tea. rewrite union_idem in eqm. have hu := model_updates mwc. - eapply check_model_is_update_of in eqm' as [eqm' incl']; tea. - rewrite ClausesProp.union_sym union_with_concl in eqm'. + have incl' := is_update_of_incl hu. + rewrite clauses_conclusions_clauses_with_concl in incl'. + have hwwc : W ∪ Wc =_lset W. + { intros l. lsets. } + eapply strictly_updates_is_update_of in hu; tea. + rewrite union_with_concl hwwc in hu. + eapply check_model_is_update_of in eqm' as [eqm' incl2]; tea. + 2:{ now eapply strictly_updates_update_of. } have WcW := model_incl mwc. have w_incl := strictly_updates_incl eqm. have wcls_incl := strictly_updates_incl eqm'. @@ -831,7 +876,11 @@ Proof. assert (~ LevelSet.In (level (concl cl)) W). { intros hin. rewrite in_clauses_with_concl in H. intuition auto. } exists (concl cl).1. split => //. } - rewrite -!diff_cardinal //. clear -w_incl clsV incl wcls_incl. have hincl := clauses_conclusions_levels cls. lsets. lsets. + rewrite -!diff_cardinal //. rewrite union_idem in wcls_incl. + clear -w_incl clsV incl wcls_incl. + have hincl := clauses_conclusions_levels cls. + { lsets. } + { lsets. } assert (Wcls ⊂_lset V). lsets. eapply strict_subset_cardinal. eapply (strict_subset_leq_right _ (LevelSet.diff V W)). 2:lsets. From f2ce72ba53048c7eccc06e1707db8858e4b8c3fc Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 13 Oct 2025 22:03:02 +0200 Subject: [PATCH 104/164] Utility lemma --- common/theories/LoopChecking/Model.v | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 5fbab7cc9..a28678b19 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -326,6 +326,15 @@ Module Model (LS : LevelSets). intros hin su; econstructor 2; trea. Qed. + Lemma trans_update_eq {cls m ls ls' m' ls'' m''} : + strictly_updates cls ls m m' -> + strictly_updates cls ls' m' m'' -> + ls'' =_lset (ls ∪ ls') -> + strictly_updates cls ls'' m m''. + Proof. + intros hin su; econstructor 2; trea. + Qed. + Lemma one_update {cls m cl m'} : Clauses.In cl cls -> strict_update m cl m' -> strictly_updates cls (LevelSet.singleton (clause_conclusion cl)) m m'. From 4bf8fabcae8c256fc84d552e1e17bb730c3f73d6 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 15 Oct 2025 10:49:07 +0200 Subject: [PATCH 105/164] Still looking... --- common/theories/LoopChecking/Deciders.v | 198 ++++++++++++++++++++++-- 1 file changed, 189 insertions(+), 9 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 1542005ce..67a3502b4 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -1804,7 +1804,6 @@ Proof. - eapply is_update_of_empty. Qed. - Equations? infer_extension {V W init cls} (m : valid_model V W init cls) (hincl : only_model_of V init) (hs : clauses_levels cls ⊂_lset V) @@ -3311,6 +3310,23 @@ Lemma opt_valuation_of_model_equiv m l : rewrite interp_add_prems interp_nes_singleton. cbn; lia. Qed. + Lemma neg_inverse_Z (v : Level.t -> Z) (cl : clause) : + ~ clause_sem v cl <-> clauses_sem v (inverse_clauses cl). + Proof. + destruct cl as [prems [concl k]]. + cbn [clause_sem]. rewrite clauses_sem_leq. + rewrite interp_add_prems interp_nes_singleton. cbn. + split; lia. + Qed. + + Lemma neg_inverse_Z_inv (v : Level.t -> Z) (cl : clause) : + clause_sem v cl <-> ~ clauses_sem v (inverse_clauses cl). + Proof. + destruct cl as [prems [concl k]]. + cbn [clause_sem]. rewrite clauses_sem_leq. + rewrite interp_add_prems interp_nes_singleton. cbn. + split; lia. + Qed. Lemma neg_inverse (v : Level.t -> option Z) (cl : clause) : defined_valuation_of (clause_levels cl) v -> @@ -3360,6 +3376,13 @@ Lemma opt_valuation_of_model_equiv m l : apply levels_spec; exists concl.2. destruct concl; cbn. now rsets. Qed. + Lemma clause_sem_Z_dec (v : Level.t -> Z) cl : + Decidable.decidable (clause_sem v cl). + Proof. + destruct cl; cbn. + red. lia. + Qed. + Lemma clause_sem_dec (v : Level.t -> option Z) cl : Decidable.decidable (clause_sem v cl). Proof. @@ -3716,13 +3739,116 @@ Proof. now eapply entails_all_singleton. Qed. +(* Definition is_finite cls u := forall cl, Clauses.In cl cls -> cls ⊢a premise cl → u. *) + +Lemma consistent_dec (m : t) cl : + { consistent (Clauses.union (clauses m) (Clauses.singleton cl)) } + + { ~ consistent (Clauses.union (clauses m) (Clauses.singleton cl)) }. +Proof. + destruct (enforce_dec m (Clauses.singleton cl)). todo "scope". + - now left. + - right. destruct i as [loop [incl ent]]. + intros [v [csem c]]. + eapply entails_L_entails_ℋ_equiv in ent. + eapply entails_L_rels_entails_L_clauses in ent. + eapply completeness_all in ent. + red in ent. + specialize (ent Z _ v). + rewrite -!interp_rels_clauses_sem in ent. + specialize (ent c). + eapply clauses_sem_clauses_of_le in ent. + rewrite interp_add_prems in ent. cbn in ent. lia. +Qed. + +Lemma curry {A B C : Prop} : (A /\ B -> C) <-> (A -> B -> C). +Proof. intuition. Qed. + +Lemma incon_con m cl : + ~ consistent (Clauses.union (clauses m) (Clauses.singleton cl)) -> + consistent (Clauses.union (clauses m) (inverse_clauses cl)). +Proof. + intros n. + have hf := incon_forall _ n. + setoid_rewrite clauses_sem_union in hf. + specialize (hf (Z_valuation_of_model m)). + forward hf. apply valuation_of_model_pos. + rewrite (@curry _ _ _) in hf. + forward hf. eapply model_valuation. + exists (Z_valuation_of_model m). split. + apply valuation_of_model_pos. + eapply clauses_sem_union. split. + apply model_valuation. + rewrite clauses_sem_singleton in hf. cbn in hf. + now eapply neg_inverse_Z in hf. +Qed. + +Lemma consistent_clause_dec (m : t) cl : + { consistent (Clauses.union (clauses m) (Clauses.singleton cl)) } + + { consistent (Clauses.union (clauses m) (inverse_clauses cl)) }. +Proof. + destruct (consistent_dec m cl). + - now left. + - right. now apply incon_con. +Qed. + +Instance proper_clauses_sem {S} {SL : Semilattice S Q.t} (v : Level.t -> S) : Proper (Clauses.Equal ==> iff) (clauses_sem v). +Proof. + intros cls cls' h. + rewrite /clauses_sem. now rewrite h. +Qed. + +Lemma consistent_clauses_dec (m : t) cls : + clauses_levels cls ⊂_lset levels m -> + { m' | clauses m' =_clset Clauses.union (clauses m) cls } + (* consistent *) + { ~ exists m', clauses m' =_clset (Clauses.union (clauses m) cls) }. + (* { exists cl, Clauses.In cl cls /\ consistent (Clauses.union (clauses m) (inverse_clauses cl)) }. *) +Proof. + intros hwf. + destruct (enforce_clauses m cls) eqn:hl. + destruct s as [m'|loop]. + - move/enforce_clauses_clauses: hl. + left; exists m'. rewrite hl. reflexivity. + - move/enforce_clauses_inconsistent: hl. + intros hincon. right. intros [m' hcls]. + elim hincon. red. exists (Z_valuation_of_model m'). split. + eapply valuation_of_model_pos. have hm := model_valuation m'. + now rewrite hcls in hm. + - now move/enforce_clauses_None: hl. +Qed. + +Lemma ncon_nconopt cls : ~ consistent cls -> ~ consistent_opt cls. +Proof. + intros ncon [v csem]. red in csem. + have hi := incon_forall _ ncon. + apply ncon. red. +Admitted. +Lemma consistent_clauses_dec' m cls : + clauses_levels cls ⊂_lset levels m -> + { consistent (Clauses.union (clauses m) cls) } + + { ~ consistent (Clauses.union (clauses m) cls) }. +Proof. + intros hwf; destruct (consistent_clauses_dec m cls hwf) as [[m' he]|he']. + - left. red. exists (Z_valuation_of_model m'). rewrite -he. split. + apply valuation_of_model_pos. apply model_valuation. + - right. intros [v csem]. +Admitted. + +Lemma strictly_updates_shift {cls V m m'} k : + strictly_updates cls V m m' -> + strictly_updates cls V (shift_model k m) (shift_model k m'). +Admitted. + + +(* Definition is_finite m hne cls u := cls ⊢a of_level_map m hne → u. *) + Lemma check_clause_invalid_Z m mcheck cl : clause_levels cl ⊂_lset (levels m) -> check_gen (clauses m) (checking_clause cl) = Invalid mcheck -> ~ valid_clause_Z (clauses m) (checking_clause cl). Proof. move=> hwf. intros inval nv. - destruct (enforce_dec m (inverse_clauses (checking_clause cl))). admit. + red in nv. + destruct (enforce_dec m (inverse_clauses (checking_clause cl))). todo "scope". - red in c. destruct c as [val [hpos csems]]. eapply clauses_sem_union in csems as []. @@ -3732,6 +3858,25 @@ Proof. rewrite interp_add_prems interp_nes_singleton //= in H0. lia. - have minv := check_invalid_inverse inval. move/check_invalid: inval => [ism]. intros. + setoid_rewrite neg_inverse_Z_inv in nv. + destruct (consistent_clauses_dec' m (inverse_clauses (checking_clause cl))). admit. + * destruct c as [v [vpos csems]]. + eapply clauses_sem_union in csems as []. now eapply nv. + * elim n. exists (opt_valuation_of_model mcheck). red. + eapply clauses_sem_union. split. now eapply valid_clauses_model_opt. now eapply valid_clauses_model_opt. +Qed. + + +Lemma check_clause_invalid_Z m mcheck cl : + clause_levels cl ⊂_lset (levels m) -> + check_gen (clauses m) (checking_clause cl) = Invalid mcheck -> ~ valid_clause_Z (clauses m) (checking_clause cl). +Proof. + move=> hwf. + intros inval nv. + red in nv. + destruct (enforce_dec m (inverse_clauses (checking_clause cl))). todo "scope". + - red in c. + destruct i as [loop [incl ent]]. eapply entails_L_entails_ℋ_equiv in ent. eapply entails_L_rels_entails_L_clauses in ent. @@ -3744,17 +3889,52 @@ Proof. { eapply is_model_union => //. } now eapply valid_clauses_model_opt in ism'. eapply clauses_sem_clauses_of_le in ent. - rewrite interp_add_prems in ent. red in ent. cbn in ent. - destruct (interp_nes _ loop) eqn:hloop. cbn in ent. lia. - admit. - eapply is_model_valid in ism'. - Search is_model. + have nem : defined_map (model m). admit. + have ent' : is_finite (model m) nem (Clauses.union (clauses m) (inverse_clauses (checking_clause cl))) loop. + red. admit. - eapply entails_L_completeness in ent. 2:{ } + red in ent'. + Print inverse_clauses. + have ent' : is_finite (Clauses.union (clauses m) (inverse_clauses (checking_clause cl))) loop. + red. + admit. -Search entails. + destruct cl as [prems [concl k]]. cbn in p1. + red in ent'. + specialize (ent' (singleton (concl, k), choose (succ prems))). + forward ent'. + { eapply Clauses.union_spec. right. + rewrite /inverse_clauses. cbn. + eapply clauses_of_le_spec. exists (choose (succ prems)). + split => //. rewrite add_prems_union. + eapply LevelExprSet.union_spec. right; apply choose_spec. } + eapply to_entails_all in ent'. + eapply entails_L_entails_ℋ_equiv in ent'. + eapply entails_L_rels_entails_L_clauses in ent'. + eapply completeness_all in ent'. + red in ent'. + specialize (ent' (option Z) _ (opt_valuation_of_model mcheck)). + rewrite -!interp_rels_clauses_sem in ent'. + forward ent'. + have ism' : is_model (Clauses.union (clauses m) (inverse_clauses (checking_clause (prems, (concl, k))))) mcheck. + { eapply is_model_union => //. } + now eapply valid_clauses_model_opt in ism'. + eapply clauses_sem_clauses_of_le in ent'. + rewrite interp_nes_singleton in ent'. + apply le_spec in ent'. + destruct ent'. + * move: p1 => [] z. + move/min_premise_pos_spec/(_ (pred_expr (concl, k))) => /fwd. + { cbn. eapply LevelExprSet.union_spec. left. lesets. } + cbn; move/Some_leq => -[y']; rewrite /levelexpr_value //= => -[] lmconcl _. + move: H; rewrite /interp_expr. Search opt_valuation_of_model. + eapply level_value_MapsTo' in lmconcl. + rewrite (mapsto_opt_valuation_of_model lmconcl) //=. + * destruct H as [x' [y'[eql [eqconcl _]]]]. + rewrite interp_add_prems !eql in ent. cbn in ent. lia. +Qed. (* Lemma check_clause_invalid_valid_Z m cl mcheck : clause_levels cl ⊂_lset (levels m) -> From e2529301a77410c1582b5dc78ea66bbe13726d9d Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 15 Oct 2025 23:28:10 +0200 Subject: [PATCH 106/164] Reorder arguments of is_model, backtrack on "more precis loops" --- common/theories/LoopChecking/Deciders.v | 168 ++++++++++-------- common/theories/LoopChecking/Model.v | 84 +++++---- .../LoopChecking/PartialLoopChecking.v | 114 +++++++++++- 3 files changed, 259 insertions(+), 107 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 67a3502b4..ee456c444 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -124,8 +124,7 @@ Proof. Qed. Definition correct_model (cls : clauses) (m : model) := - enabled_clauses m cls /\ is_model cls m. - + enabled_clauses m cls /\ is_model m cls. (* Entailment *) @@ -163,13 +162,13 @@ Qed. Definition infer_correctness cls := match infer_model cls with | inl m => correct_model cls m - | inr u => ~ exists m, defined_model_of (levels u) m /\ is_model cls m + | inr u => ~ exists m, defined_model_of (levels u) m /\ is_model m cls end. Definition valid_clauses m cls := Clauses.For_all (valid_clause m) cls. Infix "⊨" := valid_clauses (at level 90). -Lemma is_model_valid {cls m} : is_model cls m <-> m ⊨ cls. +Lemma is_model_valid {cls m} : is_model m cls <-> m ⊨ cls. Proof. rewrite /is_model. rewrite [is_true _]Clauses.for_all_spec. reflexivity. @@ -374,7 +373,7 @@ Qed. Lemma check_looping {cls cl v vcls isl} : check_gen cls cl = IsLooping v vcls isl -> - ~ (exists m, defined_model_of (levels v) m /\ is_model cls m). + ~ (exists m, defined_model_of (levels v) m /\ is_model m cls). Proof. move/check_gen_entails_looping. intros loop [m' [en clssem]]. @@ -386,7 +385,7 @@ Proof. Qed. Lemma check_valid_looping {cls cl m v vcls isl} : - is_model cls m -> + is_model m cls -> check_gen cls cl = IsLooping v vcls isl -> defined_model_of (levels v) m -> False. Proof. @@ -396,7 +395,7 @@ Proof. Qed. Lemma model_entails_succ cls m v : - is_model cls m -> + is_model m cls -> enabled_clauses m cls -> cls ⊢a v → succ v -> False. Proof. @@ -470,14 +469,9 @@ Qed. Definition minimal_above_updates cls minit m := forall m', updates cls minit m' -> - is_model cls m' -> + is_model m' cls -> updates cls m m'. -Lemma Some_leq x y : (Some x ≤ y)%opt -> exists y', y = Some y' /\ (x <= y')%Z. -Proof. - intros h; depelim h. now eexists. -Qed. - Lemma not_value_above m l k : ~~ level_value_above m l k <-> opt_le Z.lt (level_value m l) (Some k). Proof. split. @@ -659,7 +653,7 @@ Admitted. minimal_above_updates cls minit m -> updates cls minit m -> forall cl, valid_clause m cl -> - forall m', updates cls m m' -> is_model cls m' -> valid_clause m' cl. + forall m', updates cls m m' -> is_model m cls' -> valid_clause m' cl. Proof. intros hmin hupd [prems [concl k]]. move/valid_clause_elim => hz m' ext ism. @@ -680,12 +674,12 @@ Proof. Definition minimal_above cls minit m := - forall m', minit ⩽ m' -> is_model cls m' -> m ⩽ m'. + forall m', minit ⩽ m' -> is_model m' cls -> m ⩽ m'. (* Lemma minimal_above_valid cls minit m : minimal_above cls minit m -> - forall cl, valid_clause m cl -> forall m', minit ⩽ m' -> is_model cls m' -> + forall cl, valid_clause m cl -> forall m', minit ⩽ m' -> is_model m cls' -> minimal_above cls minit m' -> valid_clause m' cl. Proof. intros hmin [prems [concl k]]. @@ -760,7 +754,7 @@ Qed. Theorem check_invalid {cls cl m} : check_gen cls cl = Invalid m -> - [/\ is_model cls m, + [/\ is_model m cls, model_of (clauses_levels cls ∪ clause_levels cl) m, minimal_above cls (check_init_model cls cl) m, enabled_clause m cl & ~ valid_clause m cl]. @@ -927,7 +921,7 @@ Definition checking_clause (cl : clause) := Qed. Definition is_total_model m cls := - Model.enabled_clauses m cls /\ is_model cls m. + Model.enabled_clauses m cls /\ is_model m cls. Definition is_enabled_clause m cl := isSome (min_premise m (premise cl)). @@ -965,7 +959,7 @@ Proof. Qed. Lemma is_model_split m cls : - is_model cls m <-> (is_total_model m (enabled_clauses_of m cls)). + is_model m cls <-> (is_total_model m (enabled_clauses_of m cls)). Proof. split. - move/Clauses.for_all_spec => ism. @@ -1596,7 +1590,7 @@ Qed. Theorem check_invalid_inverse {cls cl mcheck} : check_gen cls (checking_clause cl) = Invalid mcheck -> - is_model (inverse_clauses (checking_clause cl)) mcheck. + is_model mcheck (inverse_clauses (checking_clause cl)). Proof. (* destruct cl as [prems [concl k]]. *) move/check_invalid => [ism mofm minm encl invcl]. @@ -1683,7 +1677,7 @@ Qed. *) (*Theorem check_invalid_allm {cls cl mcheck} : check_gen cls (checking_clause cl) = Invalid mcheck -> let minit := check_init_model cls (checking_clause cl) in - forall m, is_model cls m -> + forall m, is_model m cls -> minimal_above cls mcheck m -> (* (level_value m (concl cl).1 ≤ level_value mcheck (concl cl).1)%opt -> *) model_of (clauses_levels cls ∪ clause_levels cl) m -> @@ -1733,7 +1727,7 @@ Qed.*) (* Lemma check_invalid_allm_zero {cls cl} : check_gen cls cl = Invalid -> - forall m, is_model cls m -> + forall m, is_model m cls -> minimal_above cls (zero_model (clauses )) m -> model_of (clauses_levels cls ∪ clause_levels cl) m -> minit ⩽ m -> @@ -1804,18 +1798,40 @@ Proof. - eapply is_update_of_empty. Qed. +Lemma is_update_of_only_model_of {V cls W m m'} : + only_model_of V m -> + is_update_of cls W m m' -> + clauses_conclusions cls ⊂_lset V -> + only_model_of V m'. +Proof. + intros om. + move/is_update_of_case => -[]. + - move=> [] he heq. now rewrite -heq. + - move/[dup]/strictly_updates_only_model_gen. + move/(_ _ om) => om' /strictly_updates_incl incl incl'. + have he : (LevelSet.union V W) =_lset V. + { lsets. } + now rewrite he in om'. +Qed. + Equations? infer_extension {V W init cls} (m : valid_model V W init cls) (hincl : only_model_of V init) (hs : clauses_levels cls ⊂_lset V) - (cls' : clauses) : - result (LevelSet.union (clauses_levels cls') V) LevelSet.empty (Clauses.union cls cls') (min_model_map m.(model_model) cls') := - infer_extension m hincl hs cls' := - infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model_map m.(model_model) cls') cls cls' _. + (cls' : clauses) + (hs' : clauses_levels cls' ⊂_lset V) : + result V LevelSet.empty (Clauses.union cls cls') m.(model_model) := + infer_extension m hincl hs cls' hs' := + infer_model_extension V m.(model_model) cls cls' _. Proof. - repeat split. + split; [|split]. - lsets. - lsets. - - have ms := min_model_map_spec cls' (model_model m). + - eapply is_update_of_only_model_of. exact hincl. + eapply m. + now rewrite (clauses_conclusions_levels cls). +Qed. +(* + have ms := min_model_map_spec cls' (model_model m). set (map := min_model_map _ _) in *. destruct ms as [hm [hcls hext]]. rewrite LevelSet.union_spec => [] []. @@ -1837,7 +1853,7 @@ Proof. + right. intuition. * have [_ ho] := valid_model_only_model _ _ _ _ m hincl k. forward ho by now exists v. now right. -Qed. +Qed. *) Section InitModels. @@ -1914,7 +1930,7 @@ Module CorrectModel. Definition model_of {V cls} (x : t V cls) := x.(model_valid).(model_model). Coercion model_of : t >-> model. - Lemma is_model_of {V cls} (x : t V cls) : is_model cls (model_of x). + Lemma is_model_of {V cls} (x : t V cls) : is_model (model_of x) cls. Proof. apply x.(model_valid). Qed. Lemma model_minimal {V cls} (x : t V cls) : minimal_above cls (initial_model x) (model_of x). @@ -1951,6 +1967,28 @@ Module CorrectModel. *) + Lemma enabled_clauses_union {m cls cls'} : + enabled_clauses m cls -> + enabled_clauses m cls' -> + enabled_clauses m (Clauses.union cls cls'). + Proof. Admitted. + + Lemma declared_pos_enabled {m V cls} : + clauses_levels cls ⊂_lset V -> + declared_pos V m -> + enabled_clauses m cls. + Proof. + intros incl dp. + intros [prems [concl k]] hin; cbn. + red. cbn. + destruct min_premise eqn:hmin. now eexists. + have [le [hin' heq]] := proj1 (min_premise_None m prems) hmin. + move: (dp le.1) => /fwd. + apply incl. eapply clauses_levels_spec. eexists; split; tea. + rewrite clause_levels_spec. left. cbn. apply levels_spec. exists le.2; destruct le => //. + intros [k0 hm]. + eapply level_value_MapsTo in hm. congruence. + Qed. Equations? init_model : t (LevelSet.singleton Level.zero) Clauses.empty := init_model := {| @@ -1992,30 +2030,27 @@ Module CorrectModel. (hdecla : above_zero_declared V (Clauses.union cls cls')) (declp : declared_pos V init) : result V (Clauses.union cls cls') := - infer_extension_correct m enabled hincl hs cls' hs' hdeclz hdecla hdeclp with infer_extension m hincl hs cls' := + infer_extension_correct m enabled hincl hs cls' hs' hdeclz hdecla hdeclp with infer_extension m hincl hs cls' hs' := | Loop u vcls isl => inr {| loop_univ := u; loop_on_univ := isl |} | Model w m' _ => inl {| - initial_model := min_model_map m.(model_model) cls'; + initial_model := m.(model_model); only_model_of_V := _; model_updates := w; clauses_declared := _; model_valid := {| model_model := m'.(model_model) |} |}. Proof. - - have [_ [_ hm]] := min_model_map_spec cls' (model_model m). - have mupd := I.model_updates m. eapply is_update_of_ext in mupd. - assert (hr := transitivity mupd hm). + - have mupd := I.model_updates m. eapply is_update_of_ext in mupd. eapply zero_declared_ext; tea. - move=> l inv. - have [_ [_ hm]] := min_model_map_spec cls' (model_model m). have mupd := I.model_updates m. eapply is_update_of_ext in mupd. - assert (hr := transitivity mupd hm). eapply declared_pos_ext; tea. - - eapply min_model_map_enabled. - eapply enabled_clauses_ext. + - eapply enabled_clauses_ext. have mupd := I.model_updates m. eapply is_update_of_ext in mupd. exact mupd. - exact enabled. - - have := valid_model_only_model _ _ _ _ m hincl. - now apply only_model_of_min_model_map. + eapply enabled_clauses_union => //. + red in hdeclp. + red in hdecla. + eapply declared_pos_enabled; tea. + - exact: (valid_model_only_model _ _ _ _ m hincl). - intros x; rewrite clauses_levels_spec; rw Clauses.union_spec. intros [cl [[hin|hin] incl]]. apply hs. apply clauses_levels_spec. clear -hin incl; firstorder. apply hs'. apply clauses_levels_spec. clear -hin incl; firstorder. @@ -2085,22 +2120,6 @@ Module CorrectModel. - apply model_valid. Qed. - Lemma is_update_of_only_model_of {V cls W m m'} : - only_model_of V m -> - is_update_of cls W m m' -> - clauses_conclusions cls ⊂_lset V -> - only_model_of V m'. - Proof. - intros om. - move/is_update_of_case => -[]. - - move=> [] he heq. now rewrite -heq. - - move/[dup]/strictly_updates_only_model_gen. - move/(_ _ om) => om' /strictly_updates_incl incl incl'. - have he : (LevelSet.union V W) =_lset V. - { lsets. } - now rewrite he in om'. - Qed. - Lemma model_levels {V cls} (m : t V cls) : forall l, LevelSet.In l V <-> (exists k, LevelMap.MapsTo l (Some k) (model_valid m).(model_model)). Proof. @@ -2370,8 +2389,8 @@ Module Abstract. Lemma is_model_add clauses l k m : ~ LevelSet.In l (clauses_levels clauses) -> - is_model clauses m -> - is_model clauses (LevelMap.add l k m). + is_model m clauses -> + is_model (LevelMap.add l k m) clauses. Proof. move=> hnin ism. eapply Clauses.for_all_spec; tc => cl hin'. @@ -3103,7 +3122,7 @@ Lemma opt_valuation_of_model_equiv m l : Qed. Lemma clauses_sem_valid {model cls} : - clauses_sem (opt_valuation_of_model model) cls <-> is_model cls model. + clauses_sem (opt_valuation_of_model model) cls <-> is_model model cls. Proof. rewrite is_model_valid. split. intros clssem. red. move=> cl /clssem. apply clause_sem_valid. @@ -3122,7 +3141,7 @@ Lemma opt_valuation_of_model_equiv m l : Lemma def_clauses_sem_valid {model cls} : defined_model_of (clauses_levels cls) model -> - clauses_sem (Z_valuation_of_model model) cls <-> is_model cls model. + clauses_sem (Z_valuation_of_model model) cls <-> is_model model cls. Proof. intros def. rewrite clauses_sem_def_equiv //. apply clauses_sem_valid. @@ -3443,7 +3462,8 @@ Proof. Qed. Lemma check_gen_model m cl : - check_genb (clauses m) cl <-> (forall m', is_model (clauses m) m' -> enabled_clause m' cl -> valid_clause m' cl). + check_genb (clauses m) cl <-> + (forall m', is_model m' (clauses m) -> enabled_clause m' cl -> valid_clause m' cl). Proof. unfold check_genb. destruct (check_gen) eqn:ec. @@ -3459,7 +3479,7 @@ Proof. Qed. Definition valid_model_clause m cl := - (forall m', is_model (clauses m) m' -> enabled_clause m' cl -> valid_clause m' cl). + (forall m', is_model m' (clauses m) -> enabled_clause m' cl -> valid_clause m' cl). Lemma entails_models m cl : entails (clauses m) cl <-> valid_model_clause m cl. Proof. @@ -3467,10 +3487,10 @@ Proof. Qed. Definition valid_all_model_clauses m cls := - (forall m', is_model (clauses m) m' -> enabled_clauses m' cls -> valid_clauses m' cls). + (forall m', is_model m' (clauses m) -> enabled_clauses m' cls -> valid_clauses m' cls). Definition valid_model_clauses m cls := - (forall m', is_model (clauses m) m' -> + (forall m', is_model m' (clauses m) -> forall cl, Clauses.In cl cls -> enabled_clause m' cl -> valid_clause m' cl). Lemma entails_all_models m cls : clauses m ⊢ℋ cls -> valid_all_model_clauses m cls. @@ -3504,7 +3524,7 @@ Qed. Qed. *) Lemma check_gen_exists_model m cl : - check_genb (clauses m) cl -> exists m', [/\ is_model (clauses m) m', enabled_clause m' cl & valid_clause m' cl]. + check_genb (clauses m) cl -> exists m', [/\ is_model m' (clauses m), enabled_clause m' cl & valid_clause m' cl]. Proof. unfold check_genb. funelim (check_gen (clauses m) cl) => // _. @@ -3518,7 +3538,7 @@ Qed. Lemma check_gen_neg_exists_model m cl : check_genb (clauses m) cl = false <-> - exists m', [/\ is_model (clauses m) m', enabled_clause m' cl & ~ valid_clause m' cl]. + exists m', [/\ is_model m' (clauses m), enabled_clause m' cl & ~ valid_clause m' cl]. Proof. unfold check_genb. funelim (check_gen (clauses m) cl) => //. @@ -3537,7 +3557,7 @@ Proof. destruct b; intuition. Qed. Lemma nentails_model m cl : ~ entails (clauses m) cl <-> - exists m', [/\ is_model (clauses m) m', enabled_clause m' cl & ~ valid_clause m' cl]. + exists m', [/\ is_model m' (clauses m), enabled_clause m' cl & ~ valid_clause m' cl]. Proof. rewrite -checkb_entails. rewrite negb_iff /is_true negb_true_iff. @@ -3551,7 +3571,7 @@ Definition consistent_clauses cls := exists val : Level.t -> Z, positive_valuation val /\ clauses_sem val cls. Lemma equiv_all_models cls cl : - (forall m, is_model cls m -> enabled_clause m cl -> valid_clause m cl) <-> + (forall m, is_model m cls -> enabled_clause m cl -> valid_clause m cl) <-> (forall m, is_total_model m (enabled_clauses_of m cls) -> enabled_clause m cl -> valid_clause m cl). Proof. now setoid_rewrite is_model_split. Qed. @@ -3859,10 +3879,14 @@ Proof. - have minv := check_invalid_inverse inval. move/check_invalid: inval => [ism]. intros. setoid_rewrite neg_inverse_Z_inv in nv. + hnf in i. + destruct i as [loop [hincl hloop]]. + red in p0. unfold not in nv. + destruct (consistent_clauses_dec' m (inverse_clauses (checking_clause cl))). admit. * destruct c as [v [vpos csems]]. eapply clauses_sem_union in csems as []. now eapply nv. - * elim n. exists (opt_valuation_of_model mcheck). red. + * elim n. exists (Z_valuation_of_model mcheck). red. eapply clauses_sem_union. split. now eapply valid_clauses_model_opt. now eapply valid_clauses_model_opt. Qed. @@ -4040,7 +4064,7 @@ Definition check_clauses (cls : Clauses.t) (cls' : Clauses.t) : bool := Clauses.for_all (check_genb cls) cls'. Definition consistent_clauses_model cls := - exists m, Model.enabled_clauses m cls /\ is_model cls m. + exists m, Model.enabled_clauses m cls /\ is_model m cls. Lemma consistent_model m : consistent_clauses_model (clauses m). Proof. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index a28678b19..6a348828c 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -1,7 +1,7 @@ (* Distributed under the terms of the MIT license. *) (* This module defines the notion of model as a partial function from levels to Z. - [is_model cls m] states that all clauses [cls] are valid in [m]. + [is_model m cls] states that all clauses [cls] are valid in [m]. An atom [l + k] is satisfied in a model [m] when the value of [l] in [m] is defined to [v : Z] and [k ≤ v]. If the value is undefined the atom does not hold. @@ -27,7 +27,7 @@ We also show the relation of a model to entailment: - If an entailment [cls ⊢ prems → concl] holds then any valid model [m] of the clauses [cls] - satisfies [prems → concl], i.e [ is_model cls m -> valid_clause m (prems, concl) ]. + satisfies [prems → concl], i.e [ is_model m cls -> valid_clause m (prems, concl) ]. - Conversely, if we have a sequence of strict updates from model [m] to model [m'] under clauses [cls] then we have an entailment: [ cls ⊢ of_model_map m → of_level_map m' ], where [of_level_map] turns assignments [m -> Some v] to atoms [m + v] and [m -> None] are discarded. @@ -192,7 +192,7 @@ Module Model (LS : LevelSets). level_value_above m l (k + k0) end. - Definition is_model (cls : clauses) (m : model) : bool := + Definition is_model (m : model) (cls : clauses) : bool := Clauses.for_all (valid_clause m) cls. Inductive update_result := @@ -436,9 +436,9 @@ Module Model (LS : LevelSets). red; intros. now transitivity y. Qed. - #[export] Instance is_model_proper : Proper (Clauses.Equal ==> eq ==> eq) is_model. + #[export] Instance is_model_proper : Proper (eq ==> Clauses.Equal ==> eq) is_model. Proof. - intros cl cl' eqcl x y ->. unfold is_model. now rewrite eqcl. + intros x y -> cl cl' eqcl. unfold is_model. now rewrite eqcl. Qed. #[export] Instance update_model_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> LevelMap.Equal) update_model. @@ -551,7 +551,7 @@ Module Model (LS : LevelSets). Lemma check_model_aux_spec {cls w m w' m'} : check_model_aux cls (w, m) = (w', m') -> - (w = w' -> m = m' /\ is_model cls m) /\ + (w = w' -> m = m' /\ is_model m cls) /\ (w <> w' -> exists pref, w' = pref ++ w /\ strictly_updates cls (LevelSetProp.of_list pref) m m'). Proof. rewrite /check_model_aux /is_model. @@ -680,7 +680,7 @@ Module Model (LS : LevelSets). rewrite /valid_clause. rewrite him //=. Qed. - Lemma strictly_updates_invalid cls w m m' : strictly_updates cls w m m' -> ~~ is_model cls m. + Lemma strictly_updates_invalid cls w m m' : strictly_updates cls w m m' -> ~~ is_model m cls. Proof. induction 1. - eapply strict_update_invalid in H1. @@ -692,7 +692,7 @@ Module Model (LS : LevelSets). Qed. Lemma check_model_None {cls acc} : - check_model cls acc = None <-> is_model cls acc.2. + check_model cls acc = None <-> is_model acc.2 cls. Proof. unfold check_model. destruct check_model_aux eqn:cm. @@ -973,7 +973,7 @@ Module Model (LS : LevelSets). Qed. Lemma is_model_union {cls cls' m} : - is_model cls m -> is_model cls' m -> is_model (Clauses.union cls cls') m. + is_model m cls -> is_model m cls' -> is_model m (Clauses.union cls cls'). Proof. rewrite /is_model. rewrite /is_true -!ClausesFact.for_all_iff. now move=> ism ism' x /Clauses.union_spec []. @@ -1580,7 +1580,7 @@ Module Model (LS : LevelSets). Qed. Lemma check_model_is_model {W cls m} : - check_model cls (W, m) = None <-> is_model cls m. + check_model cls (W, m) = None <-> is_model m cls. Proof. now rewrite check_model_None. Qed. @@ -1588,7 +1588,7 @@ Module Model (LS : LevelSets). Lemma check_model_update {W cls m wm'} : model_of (clauses_conclusions cls) m -> model_of W m -> - check_model cls (W, m) = Some wm' -> ~~ is_model cls m /\ m ⩽ wm'.2. + check_model cls (W, m) = Some wm' -> ~~ is_model m cls /\ m ⩽ wm'.2. Proof. intros mof tot. destruct wm'. @@ -2109,16 +2109,42 @@ Module Model (LS : LevelSets). intros x [k l']. apply cl'. exists k. now right. Qed. + Lemma restrict_model_ext {W m}: restrict_model W m ⩽ m. + Proof. + move=> l k /restrict_model_spec => -[hm _]. + exists k; split => //. reflexivity. + Qed. + + Lemma min_premise_some_preserved {m m'} {prems : premises} {k} : + (forall x k, LevelSet.In x (levels prems) -> level_value m x = Some k -> level_value m' x = Some k) -> + min_premise m prems = Some k -> + min_premise m' prems = Some k. + Proof. + intros hcl. + move: prems k hcl; apply: NES.elim. + - intros [l lk] k ih. + rewrite !min_premise_singleton. + rewrite /min_atom_value. destruct level_value eqn:hl => //. + eapply ih in hl. rewrite hl. auto. + rewrite levels_singleton. cbn. lsets. + - intros [l lk] x ih hnin k' hle. + rewrite !min_premise_add. + unfold min_atom_value. + destruct (level_value m l) eqn:hl => //=. + eapply hle in hl. rewrite hl. destruct (min_premise) eqn:hmin => //=. + move: (ih z0) => /fwd. + { intros x0 k hin. eapply hle. rewrite levels_add. rsets. now right. } + move/(_ (eq_refl)) ->. congruence. + rewrite levels_add. rsets; now left. + destruct min_premise => //. + Qed. + Lemma min_premise_restrict m W (prems : premises) v : - (forall l k, LevelExprSet.In (l, k) prems -> LevelSet.In l W) -> min_premise (restrict_model W m) prems = Some v -> min_premise m prems = Some v. Proof. - intros hin. - rewrite (@min_premise_preserved _ m) //. - move=> x. rewrite levels_spec => [] [k] /hin inW. - apply levelmap_level_value_eq => k'. - rewrite restrict_model_spec. firstorder. + apply min_premise_some_preserved. + now move=> x k hin /level_value_MapsTo' /restrict_model_spec -[] /level_value_MapsTo. Qed. Lemma model_of_model_update W m m' : @@ -2210,8 +2236,6 @@ Module Model (LS : LevelSets). rewrite hm in hmin, above. exists v. split => //. eapply min_premise_restrict with W => //. - { intros l k' hp. move/in_restrict_clauses: incl => [] //= _ hsub _. apply hsub. - rewrite levels_spec. now exists k'. } move: above. rewrite /level_value_above /level_value. elim: find_spec => //. @@ -2374,8 +2398,8 @@ Module Model (LS : LevelSets). Lemma is_model_update W m m' cls : model_of W m -> only_model_of W m' -> - is_model (cls ⇂ W) m' -> - is_model (cls ⇂ W) (model_update m m'). + is_model m' (cls ⇂ W) -> + is_model (model_update m m') (cls ⇂ W). Proof. intros mW om. rewrite /is_model. @@ -2449,14 +2473,14 @@ Module Model (LS : LevelSets). eapply model_of_subset. exact mof. tea. Qed. - Lemma is_modelP m cls : reflect (Clauses.For_all (valid_clause m) cls) (is_model cls m). + Lemma is_modelP m cls : reflect (Clauses.For_all (valid_clause m) cls) (is_model m cls). Proof. case E: is_model; constructor. - now move: E; rewrite /is_model -ClausesFact.for_all_iff. - intros hf. apply ClausesFact.for_all_iff in hf; tc. unfold is_model in E; congruence. Qed. - Lemma is_model_invalid_clause cl cls m : is_model cls m -> ~~ valid_clause m cl -> ~ Clauses.In cl cls. + Lemma is_model_invalid_clause cl cls m : is_model m cls -> ~~ valid_clause m cl -> ~ Clauses.In cl cls. Proof. move/is_modelP => ism /negP valid hin. now specialize (ism _ hin). @@ -2591,7 +2615,7 @@ Module Model (LS : LevelSets). Qed. Lemma strictly_updates_valid_model {W W' m m' cls} : - is_model (cls ↓ W) m -> + is_model m (cls ↓ W) -> strictly_updates cls W' m m' -> exists l, LevelSet.In l W' /\ ~ LevelSet.In l W. Proof. @@ -3065,7 +3089,7 @@ Module Model (LS : LevelSets). Qed. Lemma entails_model_valid cls cl : entails cls cl -> - forall m, is_model cls m -> valid_clause m cl. + forall m, is_model m cls -> valid_clause m cl. Proof. induction 1. - intros m ism. @@ -3199,7 +3223,7 @@ Module Model (LS : LevelSets). depelim fs; depelim fs'. lia. Qed. - Lemma model_intersection {m m' cls} : is_model cls m -> is_model cls m' -> is_model cls (model_inter m m'). + Lemma model_intersection {m m' cls} : is_model m cls -> is_model m' cls -> is_model (model_inter m m') cls. Proof. move/is_modelP => m0 /is_modelP m1. apply/is_modelP => cl hin. @@ -3304,8 +3328,8 @@ Module Model (LS : LevelSets). Qed. Lemma shift_model_invariant {n m cls} : - is_model cls m <-> - is_model cls (shift_model n m). + is_model m cls <-> + is_model (shift_model n m) cls. Proof. rewrite /is_model. rewrite ![is_true _]Clauses.for_all_spec. @@ -3451,7 +3475,7 @@ Module Model (LS : LevelSets). Qed. Lemma valid_clauses_model_opt model cls : - is_model cls model -> + is_model model cls -> clauses_sem (opt_valuation_of_model model) cls. Proof. move=> ism cl hin. @@ -3504,7 +3528,7 @@ Module Model (LS : LevelSets). Lemma valid_clauses_model model cls : enabled_clauses model cls -> - is_model cls model -> + is_model model cls -> clauses_sem (Z_valuation_of_model model) cls. Proof. move=> en ism cl hin. diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index 910c35a74..b5bf01143 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -170,7 +170,7 @@ Record valid_model_def (V W : LevelSet.t) (m : model) (cls : clauses) := model_of_V :> model_of V model_model; model_updates : is_update_of cls W m model_model; model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; - model_ok :> is_model cls model_model; + model_ok :> is_model model_model cls; }. Arguments model_model {V W m cls}. Arguments model_of_V {V W m cls}. @@ -196,6 +196,14 @@ Proof. now move => sub h l /h. Qed. +Definition invalid_clauses m cls := Clauses.For_all (fun cl => valid_clause m cl = false) cls. + +Record LoopClauses {cls loop_cls m loop} := mkLoopClauses + { loop_cls_incl : loop_cls ⊂_clset cls; + loop_nmodel : ~ exists cl, Clauses.In cl loop_cls /\ valid_clause m cl; + incl_loop : levels loop ⊂_lset clauses_levels loop_cls }. +Arguments LoopClauses : clear implicits. + Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := | Loop (v : premises) (hincl : LevelSet.Subset (levels v) (clauses_levels cls)) (islooping : loop_on_univ cls v) | Model (w : LevelSet.t) (m : valid_model V w m cls) (prf : U ⊂_lset w). @@ -402,7 +410,7 @@ Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := Lemma measure_model W cls m : defined_model_of W m -> let clsdiff := cls_diff cls W in - measure W cls m = 0%nat -> is_model clsdiff m. + measure W cls m = 0%nat -> is_model m clsdiff. Proof using. intros dnf clsdiff hm. apply Clauses.for_all_spec. tc. @@ -571,6 +579,94 @@ Qed. Instance rew_cls_sub : RewriteRelation Clauses.Subset := {}. +Lemma is_modelP {m cls} : is_model m cls <-> Clauses.For_all (valid_clause m) cls. +Proof. + rewrite /is_model. + now rewrite [is_true _]Clauses.for_all_spec. +Qed. + +Lemma Some_leq x y : (Some x ≤ y)%opt -> exists y', y = Some y' /\ (x <= y')%Z. +Proof. + intros h; depelim h. now eexists. +Qed. + +Lemma is_model_subset {m cls cls'} : cls ⊂_clset cls' -> is_model m cls' -> is_model m cls. +Proof. + move=> incl /is_modelP cl; now apply/is_modelP=> cl' /incl /cl. +Qed. + +Lemma is_model_restrict {cls W m} : is_model m cls -> is_model (restrict_model W m) (cls ↓ W). +Proof. + move/is_modelP => ha. apply is_modelP => cl. + move/in_clauses_with_concl => -[] conclW /ha. + destruct cl as [prems [concl k]]. + move/valid_clause_elim => hz. apply valid_clause_intro => z hmin. + move/min_premise_restrict: hmin => /hz. + intros hs. cbn in conclW. + move: (@level_valueP m concl) hs; case. 2:{ intros hnin hleq; depelim hleq. } + move=> k' hm /Some_leq => -[vconcl [heq hle]]. subst k'. + have [_] := restrict_model_spec W m concl (Some vconcl) => /fwd. + split => //. + move/level_value_MapsTo => ->. now constructor. +Qed. + +Lemma restrict_with_concl_subset {cls W} : cls ⇂ W ⊂_clset (cls ↓ W). +Proof. + move=> cl /in_restrict_clauses => -[conclW premsW hin]. + rewrite in_clauses_with_concl. split => //. +Qed. + +Lemma is_model_restrict_only_w {cls W m} : is_model m cls -> is_model (restrict_model W m) (cls ⇂ W). +Proof. + move/(is_model_restrict (W:=W)). + intros he. + eapply is_model_subset; tea. + apply restrict_with_concl_subset. +Qed. + +(* Lemma not_model_valid {m cls cl} : ~~ is_model m cls -> valid_clause m cl -> Clauses.In cl cls *) +Lemma invalid_clauses_restrict {cls cls' W m} : cls ⊂_clset (cls' ⇂ W) -> + invalid_clauses (restrict_model W m) cls -> + invalid_clauses m cls. +Proof. + move=> hincl ha cl /[dup] hin /ha. + destruct cl as [prems [concl k]]. + rewrite /valid_clause. cbn. + destruct min_premise eqn:hmin => //. + move/min_premise_restrict: hmin => ->. + +Admitted. + +Lemma is_model_restrict_valid_noop {cls cls' W m} : cls ⊂_clset (cls' ⇂ W) -> + forall cl, Clauses.In cl cls -> valid_clause m cl -> valid_clause (restrict_model W m) cl. +Proof. + move=> hincl cl hin. + destruct cl as [prems [concl k]]. + move/valid_clause_elim => hz. apply valid_clause_intro => z hmin. + move/min_premise_restrict: hmin => /hz. + intros hs. + move: (@level_valueP m concl) hs; case. 2:{ intros hnin hleq; depelim hleq. } + move=> k' hm /Some_leq => -[vconcl [heq hle]]. subst k'. + have [_] := restrict_model_spec W m concl (Some vconcl) => /fwd. + split => //. eapply hincl in hin. + move/in_restrict_clauses: hin => -[] //=. + move/level_value_MapsTo => ->. now constructor. +Qed. + +Lemma is_model_restrict_noop {cls cls' W m} : cls ⊂_clset (cls' ⇂ W) -> is_model m cls -> is_model (restrict_model W m) cls. +Proof. + move=> hincl. + move/is_modelP => ha. apply is_modelP => cl /[dup] hin /ha. + intros; now eapply is_model_restrict_valid_noop. +Qed. + +Lemma strictly_updates_not_model {cls W m m'} : strictly_updates cls W m m' -> ~ is_model m cls. +Proof. + intros su hn. + eapply strictly_updates_invalid in su => //. + move/negbTE: su. congruence. +Qed. + Section InnerLoop. Context (V : LevelSet.t) (U : LevelSet.t) (init_model : model) @@ -684,12 +780,12 @@ Section InnerLoop. eapply is_update_of_weaken. 2:apply updm. rewrite eqprem. apply restrict_clauses_subset. - rewrite check_model_is_model in eqm. have okm := (model_ok mr). - have okupdm : is_model premconclW (model_update m (model_model mr)). - { setoid_rewrite eqprem at 1. apply is_model_update. apply strictly_updates_model_of in upd; tea. + have okupdm : is_model (model_update m (model_model mr)) premconclW. + { setoid_rewrite eqprem at 2. apply is_model_update. apply strictly_updates_model_of in upd; tea. eapply valid_model_only_model. now eapply strictly_updates_restrict_only_model. now setoid_rewrite <- eqprem at 1. } have mu := is_model_union okupdm eqm. - rewrite {1}eqprem in mu. + rewrite {2}eqprem in mu. rewrite union_diff_eq in mu. rewrite union_restrict_with_concl in mu. now rewrite (clauses_conclusions_eq _ _ clsW). @@ -736,6 +832,14 @@ Proof. eapply strictly_updates_non_empty in su => //. Qed. +Lemma levels_of_level_map {m ne V}: + only_model_of V m -> + levels (of_level_map m ne) ⊂_lset V. +Proof. + move=> om l; rewrite levels_spec => -[k] /of_level_map_spec hin. apply om. + now eexists. +Qed. + Local Open Scope Z_scope. #[tactic="idtac"] From e19514f44b295d527ed3fb066875dedcf64922f8 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 16 Oct 2025 23:23:14 +0200 Subject: [PATCH 107/164] Cleanup Deciders --- common/theories/LoopChecking/Deciders.v | 1350 ++++---------------- common/theories/LoopChecking/HornClauses.v | 18 +- common/theories/LoopChecking/Interfaces.v | 6 + common/theories/LoopChecking/Model.v | 2 +- 4 files changed, 244 insertions(+), 1132 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index ee456c444..d806b7c05 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -394,20 +394,32 @@ Proof. exists m. split => //. Qed. +Definition consistent cls := + exists val : Level.t -> Z, positive_valuation val /\ clauses_sem val cls. + +Lemma consistent_no_loop cls v : + consistent cls -> + cls ⊢a v → succ v -> False. +Proof. + move=> [val [vpos vsem]]. + move/to_entails_all/entails_L_entails_ℋ_equiv. + move/entails_L_rels_entails_L_clauses/completeness_all. + move/(_ Z _ val). + rewrite -!interp_rels_clauses_sem => /fwd //. + move/clauses_sem_leq. + rewrite interp_add_prems. cbn. lia. +Qed. + Lemma model_entails_succ cls m v : is_model m cls -> enabled_clauses m cls -> cls ⊢a v → succ v -> False. Proof. move=> mok en. - move/to_entails_all/entails_L_entails_ℋ_equiv. - move/entails_L_rels_entails_L_clauses/completeness_all. - move/(_ Z _ (Z_valuation_of_model m)). - rewrite -!interp_rels_clauses_sem => /fwd. - cbn in *. + apply consistent_no_loop. + exists (Z_valuation_of_model m). + split. apply valuation_of_model_pos. eapply valid_clauses_model => //. - move/clauses_sem_leq. - rewrite interp_add_prems. cbn. lia. Qed. Instance Z_le_partialorder : PreOrder Z.le. @@ -934,302 +946,16 @@ Proof. constructor. intros [z eq] => //. Qed. -Definition split_clauses m cls := - Clauses.partition (is_enabled_clause m) cls. - -Definition enabled_clauses_of m cls := (split_clauses m cls).1. -Definition disabled_clauses_of m cls := (split_clauses m cls).2. - -Lemma split_clauses_spec_1 m cls : - cls =_clset Clauses.union (enabled_clauses_of m cls) (disabled_clauses_of m cls). -Proof. Admitted. - -Lemma enabled_clauses_spec m cl cls : Clauses.In cl (enabled_clauses_of m cls) <-> Clauses.In cl cls /\ enabled_clause m cl. -Admitted. - -Lemma disabled_clauses_spec m cl cls : Clauses.In cl (disabled_clauses_of m cls) <-> Clauses.In cl cls /\ ~ enabled_clause m cl. -Admitted. - -Lemma nenabled_clause m cl : ~ enabled_clause m cl <-> min_premise m (premise cl) = None. -Proof. - case: (reflect_enabled m cl) => //. - split => //. red in p. firstorder. congruence. - firstorder. cbn in H. destruct min_premise => //. - destruct (H _ eq_refl). -Qed. - -Lemma is_model_split m cls : - is_model m cls <-> (is_total_model m (enabled_clauses_of m cls)). -Proof. - split. - - move/Clauses.for_all_spec => ism. - split. - intros cl. now rewrite enabled_clauses_spec. tc. - apply Clauses.for_all_spec. tc. - move=> cl /enabled_clauses_spec => -[] /ism //. - - move=> -[]. intros en. red in en. red in en. - intros ism. rewrite (split_clauses_spec_1 m cls). - eapply is_model_union. auto. - eapply Clauses.for_all_spec. tc. - move=> [prems [concl k]] /disabled_clauses_spec -[] hin hen. - Search enabled_clause. - apply valid_clause_intro. - now move/nenabled_clause: hen => ->. -Qed. - -Definition extend_model (m m' : model) := - LevelMap.mapi (fun l k => - match LevelMap.find l m' with - | Some (Some k') => Some k' - | _ => k - end) m. -Print on_Some. - -Definition is_le_on_defined m m' := - forall l k, LevelMap.MapsTo l (Some k) m' -> - exists k', LevelMap.MapsTo l (Some k') m /\ k' <= k. - -Lemma extend_model_max m m' : - is_le_on_defined m m' -> - forall l k, LevelMap.MapsTo l (Some k) m' -> - LevelMap.MapsTo l (Some k) (extend_model m m'). -Proof. - move=> isle l k /[dup] hm /isle => -[k' [hm' hle]]. - rewrite /extend_model LevelMapFact.F.mapi_mapsto_iff. - { intros x y e -> => //. } - exists (Some k'). rewrite (LevelMap.find_1 hm). - split => //. -Qed. - -Lemma extend_model_spec m m' : - is_le_on_defined m m' -> - forall l k, LevelMap.MapsTo l k (extend_model m m') -> - on_Some (fun k' => LevelMap.MapsTo l (Some k') m') k \/ - (level_value m' l = None /\ LevelMap.MapsTo l k m). -Proof. - intros hle l k. - rewrite /extend_model. - rewrite LevelMapFact.F.mapi_mapsto_iff. - { now intros x y e ->. } - intros [a [eq hm]]. subst k. - destruct (find_spec l m'). - destruct k; cbn. now left. - rewrite (level_value_MapsTo H). now right. - right. rewrite /level_value. destruct LevelMap.find eqn:hfind => //. - eapply LevelMap.find_2 in hfind. elim H; now exists o. -Qed. - -(* prems = x + kx, y + ky - m'[x] = Some vx - m'[y] = None - - m[x] = Some vx' <= vx - m[y] = Some vy' - - In m: min_premise m prems = min (vx' - kx, vy' - ky) - In m', min= None - In ext: min_premises (ext m m') = min (vx - kx, vy' - ky) - - The minimal premise can hence grow by (vx - vx'). - - We would like min_premise (x + kx, y + ky) -*) - -Lemma min_premise_extend_model_min {m m' prems k} : - is_le_on_defined m m' -> - min_premise (extend_model m m') prems = Some k -> - (* min_premise m' prems = None -> *) - exists k', min_premise m prems = Some k' /\ k' <= k. -Proof. - move=> isdef. - move: prems k. - apply: elim. - - intros [minp minl] k; rewrite !min_premise_singleton. - rewrite /min_atom_value. - destruct level_value eqn:hext => //=. - eapply level_value_MapsTo' in hext. - eapply extend_model_spec in hext; tea. cbn in hext. - destruct hext. intros [= <-]. - have [k' [hm hleq]] := (isdef minp _ H). - rewrite (level_value_MapsTo hm) => //. - exists (k' - minl). split; trea. lia. - destruct H as [lm' hm']. - intros [= <-]. - rewrite (level_value_MapsTo hm'). - eexists; split; trea. - - intros [le lek] prems heq hnin. - rewrite !min_premise_add. - destruct (min_premise (extend_model _ _) _) eqn:minext. - 2:{ intros k. now move/min_opt_None_right. } - specialize (heq _ eq_refl). - intros k. - destruct min_atom_value eqn:hl => //. - move=> [=] hz; subst k. - unfold min_atom_value in hl. - move: hl; case: (@level_valueP _ le) => //. - intros [extv|] => // /extend_model_spec. - move/(_ isdef) => //. - intros []. - + intros [= <-]. cbn in H. - destruct heq as [k' [-> hle]]. - have [k'' [hm hleq]] := isdef le _ H. - rewrite (min_atom_value_mapsto hm). cbn. - eexists; split; trea. lia. - + intros [= <-]. - destruct H. - destruct heq as [k' [-> hle]]. - rewrite (min_atom_value_mapsto H0). cbn. - eexists; split; trea. lia. -Qed. - - -Lemma min_premise_extend_model_max {m m' prems k} : - is_le_on_defined m m' -> - min_premise (extend_model m m') prems = Some k -> - forall k', min_premise m' prems = Some k' -> k = k'. -Proof. - intros isdef hmin. - intros k' minp. - move: prems k k' hmin minp. - apply: elim. - - intros [l lk] k k'. - rewrite !min_premise_singleton /min_atom_value. - destruct level_value eqn:hl => //. - intros [= <-]. - eapply level_value_MapsTo' in hl. - eapply extend_model_spec in hl as [hl|[hl hm']] => //. - cbn in hl. rewrite (level_value_MapsTo hl). now intros [= <-]. - now rewrite hl. - - intros [l lk] prems ih hnin k k'. - rewrite !min_premise_add. - destruct (min_premise (extend_model _ _) _) eqn:minext => //=. - 2:{ now move/min_opt_None_left. } - destruct level_value eqn:hl => //. - intros [= <-]. - eapply level_value_MapsTo' in hl. - eapply extend_model_spec in hl as [hl|[hl hm']] => //. - cbn in hl. rewrite (level_value_MapsTo hl). - destruct (min_premise m' prems) eqn:eqmin => //. - intros [= <-]. - specialize (ih _ _ eq_refl eq_refl). subst z1. - reflexivity. - rewrite hl. now move/min_opt_None_right. -Qed. - -Lemma min_premise_extend_model_spec m m' prems k : - is_le_on_defined m m' -> - min_premise (extend_model m m') prems = Some k -> - (min_premise m' prems = None /\ - exists k', min_premise m prems = Some k' /\ k' <= k) \/ - (min_premise m' prems = Some k). -Proof. - intros isdef minpext. - have := min_premise_extend_model_min isdef minpext. - have := min_premise_extend_model_max isdef minpext. - destruct (min_premise m' prems). - move=> hmax hmin. right => //. specialize (hmax _ eq_refl). subst. - reflexivity. - left. split => //. -Qed. - -Lemma extended_model_le_init m m' : m ⩽ extend_model m m'. -Proof. Admitted. - -Lemma extended_model_le_final m m' : m' ⩽ extend_model m m'. -Proof. Admitted. - -Lemma level_value_ext_max {l} {m m' : model} {k} : - level_value m' l = Some k -> - level_value (extend_model m m') l = Some k. -Proof. Admitted. - -(** - Checking starting from a lowered model. - - cls = max(x, v) >= y, x, v, y >= 0. - - check (x -> y) = false - minit := x = 0, v = - 1, y = -1, 0 = -1 - final = x = 0, v = -1, y = -1, 0 = 0 - - Indeed ~ valid (x >= y). - - Now x >= v as well. - minit := x = 0, v = - 1, y = -1, 0 = -1 - final = x = 0, v = 0, y = 0, 0 = 0 - - of_level_map minit -> of_level_map final <-> - - max (x, v - 1, y - 1, Set - 1) >= (x, v, y, Set) - can one infer x >= y from this? - yes. - -*) - Definition levels_of_model (m : model) := LevelMap.fold (fun l _ acc => LevelSet.add l acc) m LevelSet.empty. -Module check'. - -Definition premises_model m cl : LevelSet.t * model := - let levels := LevelSet.union (clause_levels cl) (levels_of_model m) in - (levels, premises_model_map m (Clauses.singleton (add_clause (model_max m + 1) cl))). - -Print premises_model. -Print min_atom_value. -Program Definition loop_check m cls (cl : clause) - (hcls : levels_of_model m =_lset clauses_levels cls) : - let minit := premises_model m cl in - result minit.1 LevelSet.empty cls minit.2 := - let V := clauses_levels cls in - let minit := premises_model m cl in - loop minit.1 LevelSet.empty cls minit.2 minit.2 _. -Next Obligation. - split => //. - - lsets. - - intros l. rewrite LevelSet.union_spec. - rewrite -/(LevelMap.In l (premises_model m cl).2). - todo "scope". - (* rewrite in_premises_model. intuition auto. *) - - apply is_update_of_empty. -Qed. - -(* -Lemma valid_model_find' {V W cl cls} : - forall v : valid_model (clause_levels cl ∪ V) W (premises_model' m) (Clauses.singleton cl)) cls, - ~ LevelMap.find (concl cl).1 (model_model v) = None. -Proof. - intros v hfind. - destruct cl as [prems [concl k]]; cbn in *. - have vmupd := model_of_V v. - set (pm := premises_model_map _ _) in *. - move/LevelMapFact.F.not_find_in_iff: hfind; apply. - apply vmupd. rewrite LevelSet.union_spec; left. - rewrite clause_levels_spec. now right. -Qed. *) - -Equations check_gen (m : model) cls (cl : clause) : check_result cls := -check_gen m cls cl with inspect (loop_check m cls cl (todo "pre")) := - { | exist (Loop v _ isl) he => IsLooping v _ isl - | exist (Model W v _) he with inspect (LevelMap.find (concl cl).1 v.(model_model)) := { - | exist (Some val) he' with check_atom_value (Some (1 + model_max m + (concl cl).2)) val := - { | true => Valid - | false => Invalid v.(model_model) } - | exist None he' := todo "nempty" - (* with valid_model_find v he' := {} *) - } - }. - -Lemma entails_prem {cls m prems concl k ne ne'} : +Lemma to_SL cls x y : let SL := horn_semi cls in - let pm := - (premises_model_map m - (Clauses.singleton (add_clause (model_max m + 1) (prems, (concl, k))))) - in - of_level_map pm ne ≡ - add_prems (model_max m + 1) prems ∨ of_level_map m ne'. -Proof. cbn in ne. -Admitted. + cls ⊢ℋ x ⋞ y <-> x ≤ y. +Proof. + intros SL. + now cbn; rewrite Theory.le_spec /Clauses.le. +Qed. Lemma add_n_succ {cls} {n : nat} (x : premises) : let SL := horn_semi cls in @@ -1242,310 +968,11 @@ Proof. have ha := add_prems_add_prems (-1) (-Z.of_nat n) x. have eq : - Z.of_nat n = 1 + - Z.succ (Z.of_nat n). lia. cbn in ha. - rewrite -{1}IHn. - rewrite join_assoc. - rewrite (join_comm (add _ x)). - rewrite eq. - rewrite -add_distr. - rewrite join_sub. - rewrite add_distr. + rewrite -{1}IHn join_assoc (join_comm (add _ x)). + rewrite eq -add_distr join_sub add_distr. cbn. rewrite -eq. apply IHn. Qed. -Lemma succ_le_inj_neg {cls} (u v : premises) : - let SL := horn_semi cls in - @Consistent _ _ _ SL -> - @EqDec _ _ _ SL -> - succ v ≤ succ u ∨ v -> ~ succ u ≤ v. -Proof. - intros SL con eq. - intros le. red in le. - intros hs. red in hs. rewrite hs in le. - rewrite join_comm join_sub in le. - apply symmetry in le. now apply con in le. -Qed. - -Lemma succ_le_inj {cls} (u v : premises) : - let SL := horn_semi cls in - @Consistent _ _ _ SL -> - @Total _ _ _ SL -> - succ v ≤ succ u ∨ v -> succ v ≤ succ u. -Proof. - intros SL con eq. - intros le. red in le. - destruct (eq v u). - - now eapply (le_add (n:=1)) in H. - - red in H. - have hs : succ v ≤ v ∨ v. - { transitivity (succ u ∨ v) => //. - apply join_le_pres. exact H. reflexivity. } - rewrite join_idem in hs. - specialize (con v). - elim con. apply eq_antisym. - split. red. now rewrite join_sub. - exact hs. - Qed. - - -Lemma add_inj {cls} (u v : premises) : - let SL := horn_semi cls in - @Consistent _ _ _ SL -> - @Total _ _ _ SL -> - add_prems 1 u ∨ add_prems 1 v ≡ add_prems 1 u ∨ v -> - u ∨ v ≡ u. -Proof. - intros SL con eq. - rewrite eq_antisym. - intros []. apply eq_antisym. split. - rewrite join_comm. apply join_le_left_eq. split. 2:{ reflexivity. } - apply (le_add (n:=1)). clear H0. - change (succ v ≤ succ u). - apply join_le_left_eq in H as []. - now apply succ_le_inj in H0. - apply join_le_left. -Qed. - -Lemma inject cls u v : - let SL := horn_semi cls in - @Consistent _ _ _ SL -> - @Total _ _ _ SL -> - (cls ⊢a u ∨ (add (-1) v) → u ∨ v)%sl -> - cls ⊢a u → v. -Proof. - intros SL con tot clsu. - eapply entails_all_concl_union in clsu as [entu entv]. - eapply to_entails_all in entv. - eapply to_entails_all. - eapply Theory.le_spec in entv. - unfold Clauses.le in entv. - apply Theory.le_spec. unfold Clauses.le. - rewrite -union_assoc in entv. - rewrite (@union_comm v u) in entv. - rewrite union_assoc in entv. - have h := (@add_n_succ cls 1 v). cbn -[eq] in h. - change (u ∨ (v ∨ add_prems (-1) v) ≡ u ∨ add_prems (-1) v) in entv. - move: entv. unfold SL. - setoid_rewrite h. - intros entv. rewrite union_comm. - change (u ∨ v ≡ u). - apply (eq_antisym (SL := SL)). split. - eapply (add_congr 1) in entv. - rewrite !add_join in entv. - rewrite add_distr [add (1 + -1)%Q _]add_prems_0 in entv. - apply add_inj in entv. - change (u ∨ v ≤ u). now rewrite entv. - red. intros nu he. cbn in he. - specialize (con nu). contradiction. exact tot. - rewrite join_comm. apply join_le_right. -Qed. - -Lemma to_SL cls x y : - let SL := horn_semi cls in - cls ⊢ℋ x ⋞ y <-> x ≤ y. -Proof. - intros SL. - now cbn; rewrite Theory.le_spec /Clauses.le. -Qed. - -Lemma inject' cls u v w : - let SL := horn_semi cls in - @Consistent _ _ _ SL -> - @Total _ _ _ SL -> - (w ≤ (u ∨ add (-1) v)%nes) -> - forall atom, LevelExprSet.In atom w -> - add (-1) v ≤ (u ∨ add (-1) w)%nes -> - cls ⊢ u → atom. -Proof. - intros SL con tot huv atom hin natom. - assert (hi := inject cls u w con tot). - rewrite -to_entails_all in hi. - rewrite -entails_all_singleton. - forward hi. - { clear hi. - rewrite to_SL. - transitivity (u ∨ add (-1) v). - eapply (join_le_left_eq (SL:=SL)). - split. eapply join_le_left. exact huv. - eapply (join_le_left_eq (SL:=SL)). split. - apply (join_le_left (SL:=SL)). - apply natom. } - eapply entails_all_singleton. - now specialize (hi _ hin). -Qed. - -(* Lemma atoms_of_shift m n k : - atoms_of_model (shift_model (n + k)%Z m) = - add_prems n (atoms_of_model (shift_model k m)). -Proof. Admitted. *) - -Lemma of_level_map_ext cls {m m'} hne hne' : - m ⩽ m' -> - cls ⊢a of_level_map m' hne' → of_level_map m hne. -Proof. - intros ext [l k] ina. - eapply of_level_map_spec in ina. - eapply ext in ina as [k' [hm hin']]. - depelim hin'. - have [y' eq] : exists y' : nat, k + Z.of_nat y' = y. - { exists (Z.to_nat (y - k)). lia. } - eapply (entails_pred_closure_n (n := y')). - rewrite eq. - constructor. now eapply of_level_map_spec. -Qed. - -Definition all_equiv cls u u' := - cls ⊢a u → u' /\ cls ⊢a u' → u. - -Notation " cls ⊢a u =a u' " := (all_equiv cls u u'). - -Lemma all_equiv_clause {cls u u'} : - let SL := horn_semi cls in - cls ⊢a u =a u' <-> (u ≡ u')%sl. -Proof. - intros SL. - unfold all_equiv. - rewrite -!to_entails_all. - rewrite !to_SL. - rewrite eq_antisym. - split; intuition. -Qed. - -Definition lt_model V m m' := model_rel_partial Z.lt V m m'. - -Lemma entails_partial {cls W m m'} : - model_of W m -> - is_update_of cls W m m' -> - LevelSet.Empty W /\ m =m m' \/ lt_model W m m'. -Proof. - move=> mof. - move/is_update_of_case. - intros []. now left. - right. now eapply strictly_updates_model_lt. -Qed. - -Axiom of_restricted_level_map : forall (V : LevelSet.t) (m : model), premises. - -Lemma entails_of_level_map {cls W m hne m'} : - model_of W m -> - is_update_of cls W m m' -> - cls ⊢a of_level_map m hne =a of_level_map m hne ∨ - add_prems 1 (of_restricted_level_map W m). -Proof. Admitted. - -Lemma inject2 cls (u v w : premises) : - let SL := horn_semi cls in - @Consistent _ _ _ SL -> - @Total _ _ _ SL -> - (w ≤ u ∨ v)%sl -> - (v ≤ add (-1) w)%sl -> - (w ≤ u). -Proof. - intros SL con tot huv hvw. - assert (hi := inject cls u w con tot). - rewrite -to_SL to_entails_all. apply hi. - rewrite -to_entails_all to_SL. - (* eassert (ha := le_add (x:=v) (y:=w) (n := -1)). *) - (* apply ha in hvw. *) - (* rewrite add_distr add_neutral in hvw. *) - change (u ∨ w ≤ u ∨ (add (-1) w))%sl. - eapply join_le_left_eq. split. apply join_le_left. - transitivity (u ∨ v). exact huv. - eapply join_le_pres. reflexivity. exact hvw. -Qed. - -Lemma inject_max cls w (u v : premises) : - let SL := horn_semi cls in - @Consistent _ _ _ SL -> - @EqDec _ _ _ SL -> - (singleton w ≤ u ∨ v)%sl -> - premise_max v < w.2 -> - singleton w ≤ u. -Proof. - intros SL con eq hsing hlt. - destruct (eq u v). admit. - -Admitted. - -Lemma premise_max_of_level_map {m hdef} : premise_max (of_level_map m hdef) <= model_max m. -Proof. - have [hf [[maxpl maxpk] [hin eq]]] := premise_max_spec (of_level_map m hdef). - rewrite eq. - eapply of_level_map_spec in hin. - cbn in eq. cbn. - have hm := model_max_spec m _ _ hin. - now depelim hm. -Qed. - -(* If a clause checks, then it is entailed (and will be valid in any extension of the model) *) -Theorem check_gen_entails {m cls cl} : - (concl cl).2 >= 0 -> - check_gen m cls cl = Valid -> entails cls (add_clause (model_max m + 1) cl). -Proof. - destruct cl as [prems [concl k]]. - move=> kpos. cbn in kpos. - funelim (check_gen m cls _) => //. - { todo "empty". } - move=> _. - set (V := (clause_levels _ ∪ levels_of_model m)%levels) in *. - clear Heqcall H H0. cbn [concl fst snd] in *. - move/check_atom_value_spec: Heq; intros h; depelim h. rename H into hgt. - have vmupd := model_updates v. - have vmok := model_ok v. - set (pm := premises_model_map _ _) in *. - have nepm : defined_map pm. - { apply premises_model_map_defined. - set (cl := (prems, _)) in *. - move/(_ (add_clause (model_max m + 1) cl)). - rewrite Clauses.singleton_spec. congruence. } - have nev : defined_map (model_model v). - by apply (is_update_of_defined_map nepm vmupd). - have hleq := is_update_of_ext vmupd. - have vmupd' := vmupd. - move/(is_update_of_entails (hne := nepm) (hne' := nev)): vmupd => ent. - have ent' := (of_level_map_ext cls nepm nev hleq). - have equiv : cls ⊢a (of_level_map (model_model v) nev) =a - (of_level_map pm nepm). - split => //. - set (cl := add_clause (model_max m + 1) (prems, (concl0, k))) in *. - have defm : defined_map m. admit. - assert (hl := entails_prem (ne' := defm) (cls := cls) (ne := nepm)). - apply all_equiv_clause in equiv. - eapply to_entails_all, to_SL in ent. - rewrite hl in ent. - enough (cls ⊢ add_prems (model_max m + 1) prems → (concl0, y)). - { have hi : exists y' : nat, model_max m + 1 + k + Z.of_nat y' = y. - assert (y >= 0). admit. - have mmax := model_max_spec2 m. - exists (Z.to_nat (y - (1 + model_max m + k))). lia. - destruct hi as [y' eq]. - eapply (entails_pred_closure_n (n := y')). - cbn. now rewrite eq. } - set (SL := horn_semi cls). - assert (hsp : singleton (concl0, y) ≤ of_level_map (model_model v) nev). - { apply to_SL, to_entails_all, entails_all_singleton. - constructor. rewrite of_level_map_spec. - now eapply LevelMap.find_2 in he'. } - move/is_update_of_case: vmupd'. - intros [[empW eqm]|su]. - { rewrite -eqm in he'. - have [k' eq] : exists k', model_max m + 1 + k' = y. - exists (y - (1 + model_max m)). lia. - subst y. - rewrite -entails_all_singleton. - eapply to_entails_all. - rewrite to_SL. - have k'pos : k' >= 0. lia. - rewrite equiv in hsp. - rewrite hl in hsp. - eapply inject_max in hsp. exact hsp. - admit. red. cbn. admit. cbn -[le]. - have hmp := @premise_max_of_level_map m defm. - cbn. lia. - Abort. -End check'. - - - Lemma valid_enabled_inverse m cl : enabled_clause m (checking_clause cl) -> valid_clause m (checking_clause cl) = false -> @@ -1592,149 +1019,12 @@ Theorem check_invalid_inverse {cls cl mcheck} : check_gen cls (checking_clause cl) = Invalid mcheck -> is_model mcheck (inverse_clauses (checking_clause cl)). Proof. - (* destruct cl as [prems [concl k]]. *) move/check_invalid => [ism mofm minm encl invcl]. move/negP/negPf: invcl. rewrite /is_model => neg. apply Clauses.for_all_spec; tc. now apply valid_enabled_inverse. Qed. - -(*Theorem check_invalid_allm {cls cl mcheck} : - check_gen cls (checking_clause cl) = Invalid mcheck -> - let minit := check_init_model cls (checking_clause cl) in - forall m, is_total_model m cls -> - exists m', model_of (clauses_levels cls ∪ clause_levels cl) m' /\ is_total_model m' cls /\ ~ valid_clause m' cl. -Proof. - move/check_invalid => [ism mofm minm encl invcl]. - intros minit m [entot mtot]. - - - - exists (extend_model m mcheck); split. - - todo "scope". - - have hledef : is_le_on_defined m mcheck. admit. - split. - split. todo "enabled". - apply Clauses.for_all_spec; tc. - move/Clauses.for_all_spec: ism. - move/Clauses.for_all_spec: mtot. - move=> ha ha' [prems [concl k]] /[dup]/ha /valid_clause_elim h /ha' /valid_clause_elim vmcheck. - apply valid_clause_intro => minpext minp. - eapply min_premise_extend_model_spec in minp as [[ninm' [minmp [inm leq]]]|inmcheck] => //. - * specialize (h _ inm). - move: (extended_model_le_init m mcheck) => /(_ concl). - move: (@level_valueP m concl) h; case => k0 hm hle. depelim hle. - move/(_ _ hm) => -[] k' [] hm' hle'. depelim hle'. - rewrite (level_value_MapsTo hm'). constructor. - (** The minimial premise in the extension might have been shifted - by a value in mcheck still. - - prems must be of the shape (x + k, y + k'...) where x is not defined in mcheck - but y is. - the minimal premise in the extension might become - [(ext m mcheck)[x] - k] = [m[x] -k] or [(ext m mcheck)[y] - k'] = [mcheck[y] - k']. - In the first case we don't move the premise, so we are fine. - In the second case we would need to argue that - mcheck[y] - k' <= min_premise m (x + k, y + k', ...) - - *) - have minpextd : minpext <= minmp + model_max mcheck. admit. - have minpextd' : y = y0 \/ y + model_max mcheck <= y0. admit. - destruct minpextd'. subst. 2:lia. - admit. - (* lia. depelim hm. *) - * specialize (vmcheck _ inmcheck). - move: (@level_valueP mcheck concl) vmcheck; case. - 2:{ intros hin hle; depelim hle. } - move=> k0 hm hle. depelim hle. - have hmext := extend_model_max m mcheck hledef _ _ hm. - rewrite (level_value_MapsTo hmext). constructor => //. - * destruct cl as [prems [concl k]]. - move/valid_clause_elim => hz. apply invcl. - apply valid_clause_intro. - intros z minp. - rewrite union_comm union_add_singleton in minp. - rewrite min_premise_add in minp. - destruct (min_premise mcheck prems) as [minmcheck|] eqn:minpchk; cbn in minp; - move => //. - destruct (level_value mcheck concl) as [vconclchk|] eqn:vconclmcheck; - cbn in minp => //. - 2:{ now apply min_opt_None_right in minp. } - noconf minp. - constructor. - destruct (min_premise (extend_model m mcheck) prems) eqn:minpext. - 2:{ todo "minnon". } - specialize (hz _ eq_refl). - have hi := @min_premise_extend_model_max m mcheck prems z hledef. - rewrite minpext in hi. specialize (hi eq_refl). - specialize (hi _ minpchk). subst z. - rewrite (level_value_ext_max vconclmcheck) in hz. - depelim hz. lia. -Qed. *) - - -(*Theorem check_invalid_allm {cls cl mcheck} : - check_gen cls (checking_clause cl) = Invalid mcheck -> - let minit := check_init_model cls (checking_clause cl) in - forall m, is_model m cls -> - minimal_above cls mcheck m -> - (* (level_value m (concl cl).1 ≤ level_value mcheck (concl cl).1)%opt -> *) - model_of (clauses_levels cls ∪ clause_levels cl) m -> - minit ⩽ m -> - valid_clause m (checking_clause cl) -> False. -Proof. - move/check_invalid => [ism mofm minm encl invcl]. - intros minit m' ism' minm' mof. - have pmodelm : minit ⩽ mcheck. todo "ext inferred". - intros ext' vm'. - destruct cl as [prems concl]. - rewrite valid_clause_satisfies in invcl. red in encl. - destruct encl as [minp eqminp]. - rewrite eqminp in invcl. - have nsat : ~ satisfiable_atom mcheck (add_expr minp concl). - { intros s; elim invcl. - right. eexists; split; trea. } - clear invcl. cbn in eqminp. - have [minmf [[minpl minpk] [hin heq]]] := min_premise_spec_aux _ _ _ eqminp. - cbn in heq. destruct (level_value mcheck minpl) as [minpmv|] => //. noconf heq. - destruct concl as [concl k]. - set (prems' := (singleton (pred_expr (concl, k)) ∨ prems)%nes) in *. - have hpres : (min_premise mcheck prems' ≤ min_premise m' prems')%opt. - { now eapply min_premise_pres. } - rewrite eqminp in hpres. depelim hpres. - rename y into minpm'. rename H into minpm'minpm. - rename H0 into minpm'eq. - (* Clause is not vacuously true in m'. *) - move/valid_clause_elim: vm'. - move/(_ _ minpm'eq) => hle. - depelim hle. rename H into leminp'; rename H0 into conclm'. - rename y into m'conclv. - unfold satisfiable_atom in nsat. cbn in nsat. - destruct (model_of_level_value concl mofm) as [conclv [hm hl]]. - { repeat (autorewrite with set_specs set_specs'; cbn). now right. } - eapply level_value_MapsTo' in conclm'. - rewrite hl in nsat. - move:(minm' mcheck) => /fwd. reflexivity. - move/(_ ism). move/is_ext_le_inter/(_ concl _ _ conclm' hm) => /check_atom_value_spec //=. - move/negP: nsat. - destruct conclv as [conclv|]. - case: Z.leb_spec => //= hlt _ /Z.leb_le. lia. - auto. -Qed.*) - - -(* -Lemma check_invalid_allm_zero {cls cl} : - check_gen cls cl = Invalid -> - forall m, is_model m cls -> - minimal_above cls (zero_model (clauses )) m -> - model_of (clauses_levels cls ∪ clause_levels cl) m -> - minit ⩽ m -> - valid_clause m cl -> False. -Proof. *) - - Lemma check_invalid_entails {cls cl m} : check_gen cls cl = Invalid m -> ~ entails cls cl. Proof. @@ -1751,39 +1041,6 @@ Qed. Import Semilattice. Import ISL. -(* Lemma elim_pred {cls prems concl} : - entails cls (union prems (singleton (pred concl)), concl) -> - entails cls (prems, concl) \/ entails cls (singleton (pred concl), concl). -Proof. - Search entails. - set (SL := init_model (relations_of_clauses cls)). - rewrite -!entails_all_singleton. - rewrite -!to_entails_all. - rewrite -!entails_L_entails_ℋ_equiv. - rewrite -!entails_L_rels_entails_L_clauses. - rewrite !entails_L_relations_of_clauses_le. - rewrite !entails_L_all_tip. - change (le (singleton concl) (prems ∨ singleton (pred concl)) -> - (le (singleton concl) (prems) \/ - le (singleton concl) (singleton (pred concl)))). *) - -(* -Lemma check_complete {cls cl} : - checkb cls cl <-> valid_semilattice_entailment cls cl. -Proof. - unfold checkb. - destruct check eqn:ec. - - split => //. - intros vs. red in vs. - move/check_entails_looping: ec. - rewrite -to_entails_all. - move/entails_ℋ_entails_L. - move/entails_L_rels_entails_L_clauses. - rewrite -completeness_all. - intros vr. red in vr. - red in islooping. specialize (vr Z _ (valuation_of_model m)) *) - - Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) (prf : clauses_levels cls ⊂_lset V /\ clauses_levels cls' ⊂_lset V /\ only_model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := @@ -2649,6 +1906,56 @@ Module Abstract. Import I.Model.Model.Clauses.ISL. + + Lemma premises_loop cls cl {prems : premises} conclk : + premise cl ⊂_leset prems -> + Clauses.add cl cls ⊢ prems → conclk -> + exists n, cls ⊢ singleton (add_expr n (concl cl)) ∨ prems → conclk. + Proof. + intros hincl h. + depind h. + - exists 0. constructor. eapply LevelExprSet.union_spec. now right. + - forward IHh. intros l. move/hincl. now rewrite add_spec. + depelim H. + eapply Clauses.add_spec in H. destruct H. + * subst cl0. destruct cl; noconf H0. cbn in *. + destruct IHh as [n0 ent]. + exists (Z.max n0 n). + destruct (Z.max_spec n0 n) as [[hle heq]|[hlt heq]]. + { rewrite heq. + have he := @entails_add cls (NES.add (add_expr n p) prems) (add_expr n0 p) concl0. + forward he. + { destruct p as [concl k]. + eapply entails_lower. exists (n + k). split. + rewrite LevelExprSet.add_spec. now left. cbn. lia. } + rewrite union_comm union_add_singleton. apply he. + rewrite -union_add_singleton union_comm. exact ent. } + { rewrite heq. + have he := @entails_add cls (NES.add (add_expr n0 p) prems) (add_expr n p) concl0. + forward he. + { destruct p as [concl k]. + eapply entails_lower. exists (n0 + k). split. + rewrite LevelExprSet.add_spec. now left. cbn. lia. } + rewrite union_comm union_add_singleton. apply he. + move: ent. + now rewrite -!union_add_singleton -union_assoc (@union_comm _ prems). } + * destruct IHh. exists x. + destruct cl0 ; noconf H0. + eapply (clause_cut _ (add_prems n t0) (add_expr n p)). + apply (incls _ (t0, p)) => //. + move: H2. + now rewrite -!union_add_singleton union_assoc. + move=> le /H1 hin. apply LevelExprSet.union_spec. now right. + * destruct IHh as [n ent]. exists n. + eapply (clause_cut _ (singleton (x, k+1)) (x, k)). + constructor. + move: ent. now rewrite -!union_add_singleton union_assoc. + move=> le /H0 hin. apply LevelExprSet.union_spec. now right. + Qed. + + + + Definition entails_loop m cls := exists u : premises, NES.levels u ⊂_lset clauses_levels (Clauses.union (clauses m) cls) /\ @@ -2716,9 +2023,6 @@ Module Abstract. Definition consistent_opt cls := exists val : Level.t -> option Z, consistent_opt_val val cls. - Definition consistent cls := - exists val : Level.t -> Z, positive_valuation val /\ clauses_sem val cls. - (* Lemma opt_valuation_of_model_equiv m l : option_get 0%Z (opt_valuation_of_model m l) = valuation_of_model m l. @@ -3570,87 +2874,26 @@ Definition check_clause m cl := Definition consistent_clauses cls := exists val : Level.t -> Z, positive_valuation val /\ clauses_sem val cls. -Lemma equiv_all_models cls cl : - (forall m, is_model m cls -> enabled_clause m cl -> valid_clause m cl) <-> - (forall m, is_total_model m (enabled_clauses_of m cls) -> enabled_clause m cl -> valid_clause m cl). -Proof. now setoid_rewrite is_model_split. Qed. - -(* -Lemma consistent_dec m cl : - clause_levels cl ⊂_lset levels m -> - { consistent_clauses (Clauses.union (clauses m) (Clauses.singleton cl)) } + - { consistent_clauses (Clauses.union (clauses m) (inverse_clauses cl)) }. -Proof. - intros hcl. - destruct (enforce_dec m (Clauses.singleton cl)). - admit. - - now left. - - destruct (enforce_dec m (inverse_clauses cl)). - admit. - + now right. - + red in i, i0. - setoid_rewrite neg_inverse in i0. - specialize (i (valuation_of_model m) valuation_of_model_pos (model_valuation m)). - specialize (i0 (valuation_of_model m) valuation_of_model_pos (model_valuation m)). - elim i. now apply clauses_sem_singleton. *) -(* Admitted. *) - - -Definition finite_premise (v : Level.t -> option Z) cl := - exists k, interp_nes v (premise cl) = Some k. - -Definition finite_clause (v : Level.t -> option Z) cl := - finite_premise v cl /\ isSome (v (concl cl).1). - -(* cls = { x, y -> y + 1; x, z -> y + 2 } - - Goal x -> y - - y - 1 -> y - 1 - - x, y - 1 -> y - 1 - - x + 1, y -> y - - x, x + 1, y -> y - - x, x + 1, y -> y + 1 - - - - x - - max (x, y) >= y+1 <-> x >= y+1 \/ y >= y+1 <-> x >= y+1 -> x >= y - - - check (x -> y) - - cls |- x -> y + 2 <-> cls |- x + 1 , y -> y + 1 - - { x = 0, y = U } - - - check { x = 1, y = 0 } -> { x = 1, y = 1 } -> {x = 1, y = 2} - Then test 1 <= v[y]{ x = 1, y = 2} - 1 - -*) - (* The valution here is in 𝐙 + ∞: - clauses max (∞, ...) >= x are trivially valid. - clauses max ... >= ∞ are invalid. + + This corresponds to the fact that validity checking does compute + all the "downward" consequences of its premises (say [x, y]), + but will not consider unrelated max(v, x) expressions if [v] is + not entailed by [x] or [y]. + I.e. such expressions can live arbitrarily high. *) Definition valid_clause_Zinf cls cl := forall v : Level.t -> option Z, positive_opt_valuation v -> clauses_sem v cls -> - (* finite_clause v cl -> *) clause_sem v cl. Definition valid_clauses_Zinf cls cls' := forall v : Level.t -> option Z, positive_opt_valuation v -> clauses_sem v cls -> - (* finite_clause v cl -> *) clauses_sem v cls'. Definition valid_clause_Z cls cl := @@ -3668,11 +2911,6 @@ Proof. rewrite clauses_sem_opt clause_sem_opt; apply => //. Qed. -Lemma contra A B : (B -> A) -> (~ A -> ~ B). -Proof. intros f na b. exact (na (f b)). Qed. - - - Definition valid_clause_Z_mon cls cls' cl : Clauses.Subset cls cls' -> valid_clause_Zinf cls cl -> valid_clause_Zinf cls' cl. Proof. @@ -3686,20 +2924,6 @@ Proof. intros hsub vz vz'. eapply valid_clause_Z_mon in vz'; tea. contradiction. Qed. -Section Zinf_semi. - Definition inf_model := LevelMap.t (option (option Z)). - - Definition le (x y : option Z) := - match x, y with - | None, None => true - | None, Some _ => false - | Some _, None => true - | Some x, Some y => x <=? y - end. - -End Zinf_semi. - - Lemma check_clause_invalid_Zinf m mcheck cl : check_gen (clauses m) cl = Invalid mcheck -> ~ valid_clause_Zinf (clauses m) cl. Proof. @@ -3707,65 +2931,18 @@ Proof. move/check_invalid_valuation => [vpos csem hdef clsem]. now move=> /(_ (opt_valuation_of_model mcheck) vpos csem). Qed. -(* -Lemma invalid_clause_Zinf_em m cl : - ~ enforce_clauses m cl -> ~ valid_clauses_Zinf (clauses m) (inverse_clauses cl) -> False. -Proof. - intros vc nc'. apply nc'. red. - intros. - have hc : clauses_sem v (inverse_clauses cl) \/ ~ clauses_sem v (inverse_clauses cl). - admit. - destruct hc => //. elim nc'. - intros v' H' H0'. *) Lemma incon_forall cls : ~ consistent cls -> (forall v : Level.t -> Z, positive_valuation v -> clauses_sem v cls -> False). Proof. intros incon v hpos csem. apply incon. exists v. split => //. Qed. -(* Lemma incon_opt_ext_forall m cls : inconsistent_opt_ext m cls -> (forall v : Level.t -> Z, positive_valuation v -> clauses_sem v clauses_sem v cls -> False). -Proof. - intros incon v hpos csem. - red in incon. Search entails_loop. red in incon. - destruct incon as [loop [incl ent]]. - eapply entails_L_entails_ℋ_equiv in ent. - eappply entails - apply incon. exists v. split => //. -Qed. *) - -Lemma entails_equiv {cls l r u} : Clauses.union cls (clauses_of_le l r) ⊢ r → u -> - cls ⊢ l ∨ r → u. -Proof. - Print entails. - Search entails. - intros h; depind h. - - constructor. rewrite union_spec. now right. - - -Admitted. - - -Lemma entails_thin m prems concl : - clauses m ⊢ succ prems → concl -> - clauses m ⊢ succ prems ∨ singleton concl → succ_expr concl -> - clauses m ⊢ prems → concl. -Proof. - intros enpremconcl ent. - set (SL := horn_semi (clauses m)). - rewrite -entails_all_singleton. - eapply (entails_all_shift 1). - eapply entails_all_trans; tea. - 2:{ rewrite add_prems_singleton. eapply entails_all_singleton. exact ent. } - eapply entails_all_concl_union. split. eapply entails_all_tauto. - now eapply entails_all_singleton. -Qed. - -(* Definition is_finite cls u := forall cl, Clauses.In cl cls -> cls ⊢a premise cl → u. *) - Lemma consistent_dec (m : t) cl : + clauses_levels (Clauses.singleton cl) ⊂_lset levels m -> { consistent (Clauses.union (clauses m) (Clauses.singleton cl)) } + { ~ consistent (Clauses.union (clauses m) (Clauses.singleton cl)) }. Proof. - destruct (enforce_dec m (Clauses.singleton cl)). todo "scope". + intros hwf. destruct (enforce_dec m (Clauses.singleton cl)) => //. - now left. - right. destruct i as [loop [incl ent]]. intros [v [csem c]]. @@ -3803,10 +2980,11 @@ Proof. Qed. Lemma consistent_clause_dec (m : t) cl : + clauses_levels (Clauses.singleton cl) ⊂_lset levels m -> { consistent (Clauses.union (clauses m) (Clauses.singleton cl)) } + { consistent (Clauses.union (clauses m) (inverse_clauses cl)) }. Proof. - destruct (consistent_dec m cl). + intros hwf; destruct (consistent_dec m cl) => //. - now left. - right. now apply incon_con. Qed. @@ -3836,154 +3014,151 @@ Proof. - now move/enforce_clauses_None: hl. Qed. -Lemma ncon_nconopt cls : ~ consistent cls -> ~ consistent_opt cls. -Proof. - intros ncon [v csem]. red in csem. - have hi := incon_forall _ ncon. - apply ncon. red. -Admitted. -Lemma consistent_clauses_dec' m cls : - clauses_levels cls ⊂_lset levels m -> - { consistent (Clauses.union (clauses m) cls) } + - { ~ consistent (Clauses.union (clauses m) cls) }. -Proof. - intros hwf; destruct (consistent_clauses_dec m cls hwf) as [[m' he]|he']. - - left. red. exists (Z_valuation_of_model m'). rewrite -he. split. - apply valuation_of_model_pos. apply model_valuation. - - right. intros [v csem]. -Admitted. - -Lemma strictly_updates_shift {cls V m m'} k : - strictly_updates cls V m m' -> - strictly_updates cls V (shift_model k m) (shift_model k m'). -Admitted. - - -(* Definition is_finite m hne cls u := cls ⊢a of_level_map m hne → u. *) +Definition check_clauses (cls : Clauses.t) (cls' : Clauses.t) : bool := + Clauses.for_all (check_genb cls) cls'. -Lemma check_clause_invalid_Z m mcheck cl : - clause_levels cl ⊂_lset (levels m) -> - check_gen (clauses m) (checking_clause cl) = Invalid mcheck -> ~ valid_clause_Z (clauses m) (checking_clause cl). +Lemma check_clauses_spec m cls' : + check_clauses (clauses m) cls' <-> clauses m ⊢ℋ cls'. Proof. - move=> hwf. - intros inval nv. - red in nv. - destruct (enforce_dec m (inverse_clauses (checking_clause cl))). todo "scope". - - red in c. - destruct c as [val [hpos csems]]. - eapply clauses_sem_union in csems as []. - specialize (nv _ hpos H). - destruct cl as [prems [concl k]]. cbn in nv, H0. - eapply clauses_sem_clauses_of_le in H0. cbn in H0. - rewrite interp_add_prems interp_nes_singleton //= in H0. lia. - - have minv := check_invalid_inverse inval. - move/check_invalid: inval => [ism]. intros. - setoid_rewrite neg_inverse_Z_inv in nv. - hnf in i. - destruct i as [loop [hincl hloop]]. - red in p0. unfold not in nv. - - destruct (consistent_clauses_dec' m (inverse_clauses (checking_clause cl))). admit. - * destruct c as [v [vpos csems]]. - eapply clauses_sem_union in csems as []. now eapply nv. - * elim n. exists (Z_valuation_of_model mcheck). red. - eapply clauses_sem_union. split. now eapply valid_clauses_model_opt. now eapply valid_clauses_model_opt. + rewrite /check_clauses. + rewrite [is_true _]Clauses.for_all_spec. + split. + move=> ha cl /ha. + rewrite -/(is_true (check_genb (clauses m) cl)). + now rewrite checkb_entails. + move=> hent cl /hent. + now rewrite -checkb_entails. Qed. +Definition valid_total_models cls cl := + forall m : Model.model, is_total_model m cls -> defined_model_of (clause_levels cl) m -> valid_clause m cl. -Lemma check_clause_invalid_Z m mcheck cl : - clause_levels cl ⊂_lset (levels m) -> - check_gen (clauses m) (checking_clause cl) = Invalid mcheck -> ~ valid_clause_Z (clauses m) (checking_clause cl). -Proof. - move=> hwf. - intros inval nv. - red in nv. - destruct (enforce_dec m (inverse_clauses (checking_clause cl))). todo "scope". - - red in c. - - destruct i as [loop [incl ent]]. - eapply entails_L_entails_ℋ_equiv in ent. - eapply entails_L_rels_entails_L_clauses in ent. - eapply completeness_all in ent. - red in ent. - specialize (ent (option Z) _ (opt_valuation_of_model mcheck)). - rewrite -!interp_rels_clauses_sem in ent. - forward ent. - have ism' : is_model (Clauses.union (clauses m) (inverse_clauses (checking_clause cl))) mcheck. - { eapply is_model_union => //. } - now eapply valid_clauses_model_opt in ism'. - eapply clauses_sem_clauses_of_le in ent. - - have nem : defined_map (model m). admit. - have ent' : is_finite (model m) nem (Clauses.union (clauses m) (inverse_clauses (checking_clause cl))) loop. - red. admit. - - red in ent'. - - Print inverse_clauses. - have ent' : is_finite (Clauses.union (clauses m) (inverse_clauses (checking_clause cl))) loop. - red. - admit. - - destruct cl as [prems [concl k]]. cbn in p1. - red in ent'. - specialize (ent' (singleton (concl, k), choose (succ prems))). - forward ent'. - { eapply Clauses.union_spec. right. - rewrite /inverse_clauses. cbn. - eapply clauses_of_le_spec. exists (choose (succ prems)). - split => //. rewrite add_prems_union. - eapply LevelExprSet.union_spec. right; apply choose_spec. } - eapply to_entails_all in ent'. - eapply entails_L_entails_ℋ_equiv in ent'. - eapply entails_L_rels_entails_L_clauses in ent'. - eapply completeness_all in ent'. - red in ent'. - specialize (ent' (option Z) _ (opt_valuation_of_model mcheck)). - rewrite -!interp_rels_clauses_sem in ent'. - forward ent'. - have ism' : is_model (Clauses.union (clauses m) (inverse_clauses (checking_clause (prems, (concl, k))))) mcheck. - { eapply is_model_union => //. } - now eapply valid_clauses_model_opt in ism'. - eapply clauses_sem_clauses_of_le in ent'. - rewrite interp_nes_singleton in ent'. - apply le_spec in ent'. - destruct ent'. - * move: p1 => [] z. - move/min_premise_pos_spec/(_ (pred_expr (concl, k))) => /fwd. - { cbn. eapply LevelExprSet.union_spec. left. lesets. } - cbn; move/Some_leq => -[y']; rewrite /levelexpr_value //= => -[] lmconcl _. - move: H; rewrite /interp_expr. Search opt_valuation_of_model. - eapply level_value_MapsTo' in lmconcl. - rewrite (mapsto_opt_valuation_of_model lmconcl) //=. - * destruct H as [x' [y'[eql [eqconcl _]]]]. - rewrite interp_add_prems !eql in ent. cbn in ent. lia. -Qed. -(* -Lemma check_clause_invalid_valid_Z m cl mcheck : - clause_levels cl ⊂_lset (levels m) -> - check_gen (clauses m) cl = Invalid mcheck -> ~ valid_clause_Z (clauses m) cl. +Lemma valid_total_models_Z_models cls cl : valid_clause_Z cls cl -> valid_total_models cls cl. Proof. - move=> hwf. - unfold check_clause. - move/check_invalid_allm => /(_ (model m) (model_ok (model_valid m))). - move=> /fwd. - { (* This means the conclusion's level in the inital model to check should - be set at least as high as in the current clauses. This should follow - from minimality. *) - todo "level of conclusion". } - move=> /fwd. - { red. todo "scope, easy". } - move=> /fwd. - { todo "check_init_model <= model m, to investigate". } - move=> invalidc vc. apply invalidc. - red in vc. move: (vc (Z_valuation_of_model m)) => /fwd. + intros H m istot encl. + move: (H (Z_valuation_of_model m)) => /fwd. eapply valuation_of_model_pos. - move/(_ (model_valuation m)). - rewrite def_clause_sem_valid //. - { eapply defined_model_of_subset; tea. - eapply defined_model. } -Qed.*) + move=> /fwd. destruct istot. move/is_modelP: H1 => H1. + move=> cl' /[dup] /H0 en /H1. + now eapply valid_clause_model. + intros cs. + rewrite -def_clause_sem_valid //. +Qed. + + +Instance incl_leset_preorder : PartialOrder LevelExprSet.Equal LevelExprSet.Subset. +Proof. + red. intros x y. split. + - unfold relation_conjunction; cbn. intros ->. split; auto. reflexivity. + red. reflexivity. + - cbn; unfold flip. lesets. +Qed. + +Instance rew_lesub : RewriteRelation LevelExprSet.Subset := {}. + +Lemma subset_singleton (prems : premises) x : prems ⊂_leset singleton x -> prems = singleton x. +Proof. + move: prems; apply: elim. + - move=> le /(_ le) => /fwd. + now apply LevelExprSet.singleton_spec. + now rewrite LevelExprSet.singleton_spec => ->. + - intros le x' hincl hnin hadd. + destruct (Classes.eq_dec x le). + * subst. specialize (hadd (choose x')). + forward hadd. apply add_spec; right. apply choose_spec. + eapply singleton_spec in hadd. subst. + elim hnin. apply choose_spec. + * specialize (hadd le). forward hadd. + now apply add_spec. + apply LevelExprSet.singleton_spec in hadd. red in hadd. congruence. +Qed. + +(* x ∨ y -> y + 1 *) +Definition valid_Z_counterexample_cls (x y : Level.t) : clause := + ((singleton (x, 0) ∨ singleton (y, 0)), (y, 1))%nes. + +(* x -> y *) +Definition valid_Z_counterexample_cl (x y : Level.t) : clause := + (singleton (x, 0), (y, 0))%nes. + +Example check_clause_invalid_Z_counterexample (x y : Level.t) : + x <> y -> + let cls := Clauses.singleton (valid_Z_counterexample_cls x y) in + let cl := valid_Z_counterexample_cl x y in + exists mcheck, check_gen cls cl = Invalid mcheck /\ valid_clause_Z cls cl. +Proof. + move=> hdiff cls cl. + set (v := (fun l : Level.t => if eqb l x then 1 else 0)%Z). + have vx : v x = 1. now rewrite /v eqb_refl. + have vy : v y = 0. rewrite /v. case: eqb_spec => //. subst; congruence. + have hcls : clauses_sem v cls. + { eapply clauses_sem_singleton. cbn. + rewrite interp_nes_union !interp_nes_singleton //=. + rewrite vx vy. cbn. lia. } + have hcon : consistent cls. + { exists v. split => //. + intros l. unfold v. case: eqb_spec => //. } + destruct check_gen eqn:ec. + - move/check_gen_entails_looping: ec. + move/consistent_no_loop. contradiction. + - exists m. split => //. + intros v' vpos csem. + unfold cl; cbn. + rewrite interp_nes_singleton //=. + move: (csem (valid_Z_counterexample_cls x y)) => /fwd. now eapply Clauses.singleton_spec. + cbn. rewrite !interp_nes_union !interp_nes_singleton //=. lia. + - exfalso. move/check_gen_entails: ec. + rewrite entails_completeness. + intros ent. + set (vopt := (fun l : Level.t => if eqb l x then Some 0 else None)%Z). + have voptx : vopt x = Some 0. now rewrite /vopt eqb_refl. + have vopty : vopt y = None. rewrite /vopt. case: eqb_spec => //. subst; congruence. + specialize (ent (option Z) _ vopt). + have hcls' : clauses_sem vopt cls. + { eapply clauses_sem_singleton. cbn. + rewrite interp_nes_union !interp_nes_singleton //=. + rewrite voptx vopty. now cbn. } + move: (ent hcls'); cbn. + rewrite !interp_nes_singleton //=. + now rewrite voptx vopty; cbn. +Qed. + +Example check_clause_checking_invalid_Z_example (x y : Level.t) : + x <> y -> + let cls := Clauses.singleton (valid_Z_counterexample_cls x y) in + let cl := valid_Z_counterexample_cl x y in + check_gen cls (checking_clause cl) = Valid. +Proof. + move=> hdiff cls cl. + set (v := (fun l : Level.t => if eqb l x then 1 else 0)%Z). + have vx : v x = 1. now rewrite /v eqb_refl. + have vy : v y = 0. rewrite /v. case: eqb_spec => //. subst; congruence. + have hcls : clauses_sem v cls. + { eapply clauses_sem_singleton. cbn. + rewrite interp_nes_union !interp_nes_singleton //=. + rewrite vx vy. cbn. lia. } + have hcon : consistent cls. + { exists v. split => //. + intros l. unfold v. case: eqb_spec => //. } + destruct check_gen eqn:ec. + - move/check_gen_entails_looping: ec. + move/consistent_no_loop. contradiction. + - exfalso. move/check_invalid_entails: ec. + apply. apply entails_completeness. + red. intros. + move: (H (valid_Z_counterexample_cls x y)) => /fwd. + now apply Clauses.singleton_spec. + cbn. rewrite !interp_nes_union !interp_nes_singleton //=. + rewrite !add_neutral. intros hle. + apply (le_add (n:=1)). + etransitivity; tea. + rewrite !add_join !add_distr. + have -> : (1 + (0 - 1))%Q = 0 by cbn; lia. + rewrite add_neutral join_comm. + eapply join_le_pres. reflexivity. + red. now rewrite join_sub. + - reflexivity. +Qed. Lemma check_clause_valid_Z m cl : check_clause m cl -> valid_clause_Z (clauses m) cl. @@ -3999,70 +3174,6 @@ Proof. lia. Qed. -(* - - intros vc. - destruct (check_genb) eqn:ec => //. - apply (ssrbool.introT (@negPf _)) in ec. - move/negP: ec. rewrite checkb_entails => ent. - destruct (entails_dec_clauses m (inverse_clauses (checking_clause cl))). - * (* Contradiction: valid in Z but invalid in the Horn clauses *) - destruct cl as [prems concl]; cbn in *. - unfold inverse_clauses in e. - rewrite entails_ℋ_clauses_of_relations_equiv in e. - apply entails_L_entails_ℋ_equiv in e. - (* eapply entails_L_clauses_pres_le in e. *) - eapply entails_L_rels_entails_L_clauses in e. - Search relations_of_clauses. - eapply completeness_all in e. - red in e. specialize (e Z _ (Z_valuation_of_model m)). red in vc. cbn in vc. - admit. - (* eapply entails_L_completeness in e. *) - Search entails_L_clauses clauses_of_le. - * destruct a as [inval hvals]. - (* The new clause is independent from the old ones, - we can construct a complete model refuting it. - - *) - rewrite entails_models in ent. clear hvals. - rewrite -entails_all_models_inv in inval. - destruct (enforce_dec m (inverse_clauses (checking_clause cl))). - admit. - red in c. admit. - red in i. red in i. - exfalso. apply ent. red. - intros m' ism en. red in vc. - destruct (valid_clause m' (checking_clause cl)) eqn:he => //. - eapply valid_enabled_inverse in he. - unfold consistent in i. - (* exfalso; apply i. red. *) - exfalso. eapply inval. - red. - intros. - eapply entails_en - - - - rewrite to_entails_all in e. - eapply completeness_all in e. - red in e. - -Search (_ = false). - - destruct (checkb ) - - - intros m' ism en. - red in vc. - specialize (vc (Z_valuation_of_model m)). forward vc. apply valuation_of_model_pos. - specialize (vc (model_valuation m)). - destruct (eq) - intros S. -Qed. -*) - -Definition check_clauses (cls : Clauses.t) (cls' : Clauses.t) : bool := - Clauses.for_all (check_genb cls) cls'. - Definition consistent_clauses_model cls := exists m, Model.enabled_clauses m cls /\ is_model m cls. @@ -4112,17 +3223,6 @@ Proof. move=> hwf; apply check_clause_valid_Z. Qed. -(* Lemma check_neg_spec m cl : - clause_levels cl ⊂_lset levels m -> - check (clauses m) cl = false <-> ~ valid_clause_Z (clauses m) cl. -Proof. - unfold check. - destruct check_clause eqn:he; split => //. - - now move/check_clause_looping: he. - - now move/check_clause_invalid_valid_Z: he => /(_ H). - - now move/check_clause_valid_Z: he. -Qed. *) - Definition valid_clauses cls cls' := forall v : Level.t -> option Z, positive_opt_valuation v -> diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index f5deb560c..7b3d4d8a3 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -1511,17 +1511,23 @@ Module Clauses (LS : LevelSets). eapply entails_clauses_subset; tea. Qed. - Lemma entails_succ cls (u v : premises) : - (forall l k, LevelExprSet.In (l, k) v -> exists k', LevelExprSet.In (l, k') u /\ k <= k') -> - cls ⊢a u → v. + Lemma entails_lower cls (u : premises) l k : + (exists k', LevelExprSet.In (l, k') u /\ k <= k') -> + cls ⊢ u → (l, k). Proof. - intros hk [l k] hin. - specialize (hk _ _ hin) as [k' [hin' le]]. + intros [k' [hin' le']]. assert (exists n, k' = k + n) as [n ->] by (exists (k' - k); lia). eapply (entails_pred_closure_n (n := Z.to_nat n)). constructor. rewrite Z2Nat.id. lia. assumption. Qed. + Lemma entails_all_lower cls (u v : premises) : + (forall l k, LevelExprSet.In (l, k) v -> exists k', LevelExprSet.In (l, k') u /\ k <= k') -> + cls ⊢a u → v. + Proof. + intros hk [l k] hin. apply entails_lower. now apply hk. + Qed. + Lemma entails_all_tauto cls u : cls ⊢a u → u. Proof. intros x hin. now constructor. @@ -1640,7 +1646,7 @@ Module Clauses (LS : LevelSets). cls ⊢a succ_prems s → s. Proof. intros cl hin. - eapply Clauses.entails_succ; tea. + eapply Clauses.entails_all_lower; tea. intros l k hin'. exists (1 + k). split => //; try lia. eapply In_add_prems. exists (l, k); split => //. Qed. diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 3d47b9326..8b42f36da 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -318,8 +318,14 @@ Ltac lset := apply LevelSetProp.FM.mem_iff in H | [ H : LevelExprSet.In _ (LevelExprSet.singleton _) |- _ ] => apply LevelExprSet.singleton_spec in H; red in H; try subst + | [ H : LevelExprSet.In _ (singleton _) |- _ ] => + apply LevelExprSet.singleton_spec in H; red in H; try subst | [ H : LevelExprSet.In _ (LevelExprSet.add _ _) |- _ ] => apply LevelExprSet.add_spec in H as [] + | [ H : LevelExprSet.In _ (add _ _) |- _ ] => + apply LevelExprSet.add_spec in H as [] + | [ H : LevelExprSet.In _ (union _ _) |- _ ] => + apply LevelExprSet.union_spec in H as [] | [ H : LevelMap.MapsTo _ _ (LevelMap.add _ _ _) |- _ ] => rewrite LevelMapFact.F.add_mapsto_iff in H; unfold Level.eq in H | [ H : LevelMap.MapsTo _ _ (LevelMap.empty _) |- _ ] => diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 6a348828c..80ae137f4 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -2894,7 +2894,7 @@ Module Model (LS : LevelSets). have entails_prems : cls ⊢a hyps → premise_values prems m. by eapply model_hyps_entails with conclk; auto. eapply entails_all_trans; tea. - eapply entails_succ. + eapply entails_all_lower. intros l k. rewrite In_add_prems. intros [[prem premk] [inprem [= -> ->]]]. rw premise_values_spec. eexists. From dbf8574276a90337cb85b45e13e642ea35252b8d Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 28 Oct 2025 22:09:28 +0100 Subject: [PATCH 108/164] Developing theory of thinning clauses to avoid "latent" loops --- common/theories/LoopChecking/Deciders.v | 637 +++++++++++++++++- .../theories/LoopChecking/UnivLoopChecking.v | 29 +- common/theories/LoopChecking/ZModels.v | 315 +++++++++ common/theories/Universes.v | 29 +- common/theories/uGraph.v | 36 +- template-rocq/theories/Junk.v | 377 +++++++++++ 6 files changed, 1376 insertions(+), 47 deletions(-) create mode 100644 common/theories/LoopChecking/ZModels.v diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index d806b7c05..2cdd07926 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -1452,7 +1452,7 @@ Module CorrectModel. rewrite initm in hle. rewrite -/(model_of m) in ext hle. lia. Qed. - Lemma model_max {V cls} {m : t V cls}: forall l k, LevelMap.MapsTo l (Some k) (model_of m) -> + Lemma model_max_0 {V cls} {m : t V cls}: forall l k, LevelMap.MapsTo l (Some k) (model_of m) -> (Some k ≤ level_value (model_of m) (Level.zero))%opt. Proof. intros l k hm. @@ -1534,7 +1534,7 @@ Module CorrectModel. have zerom := model_max_spec m _ _ hzero. depelim zerom. destruct mmax'. rewrite H0 in H. cbn in *. lia. destruct H0 as [l' [k' [hm' eqmax]]]. - move/model_max: hm'. rewrite (level_value_MapsTo hzero) => hle; depelim hle. + move/model_max_0: hm'. rewrite (level_value_MapsTo hzero) => hle; depelim hle. have mr := valuation_range hzero. subst k'. have hs := valuation_of_model_spec (model_of m) _ _ hzero. cbn in hs. @@ -2354,6 +2354,23 @@ Lemma opt_valuation_of_model_equiv m l : exists z. split => //. Qed. + Lemma clause_sem_defined_premises_valid {model cl} : + defined_model_of (NES.levels (premise cl)) model -> + clause_sem (opt_valuation_of_model model) cl -> clause_sem (Z_valuation_of_model model) cl. + Proof. + intros def. + destruct cl as [prems [concl k]]. + rewrite /clause_sem. rewrite interp_nes_defined //. + unfold interp_expr. + destruct (opt_valuation_of_model model concl) eqn:hconcl. + * eapply opt_valuation_of_model_inv in hconcl as [k' [hm heq]]. subst z. + cbn. rewrite {3}/Z_valuation_of_model /to_Z_val /to_val. + have hv := valuation_of_value_pos hm. + apply valuation_of_model_spec in hm. + rewrite (LevelMap.find_1 hm). rewrite -/(valuation_of_value model k'). + lia. + * now cbn. + Qed. Lemma clause_sem_defined_valid_all {model cl} : defined_model_of (clause_levels cl) model -> @@ -3031,18 +3048,21 @@ Proof. Qed. Definition valid_total_models cls cl := - forall m : Model.model, is_total_model m cls -> defined_model_of (clause_levels cl) m -> valid_clause m cl. + forall m : Model.model, is_total_model m cls -> + defined_model_of (clause_levels cl) m -> valid_clause m cl. -Lemma valid_total_models_Z_models cls cl : valid_clause_Z cls cl -> valid_total_models cls cl. +Lemma valid_total_models_Z_models cls cl : valid_clause_Z cls cl <-> valid_total_models cls cl. Proof. - intros H m istot encl. - move: (H (Z_valuation_of_model m)) => /fwd. - eapply valuation_of_model_pos. - move=> /fwd. destruct istot. move/is_modelP: H1 => H1. - move=> cl' /[dup] /H0 en /H1. - now eapply valid_clause_model. - intros cs. - rewrite -def_clause_sem_valid //. + split. + - intros H m istot encl. + move: (H (Z_valuation_of_model m)) => /fwd. + eapply valuation_of_model_pos. + move=> /fwd. destruct istot. move/is_modelP: H1 => H1. + move=> cl' /[dup] /H0 en /H1. + now eapply valid_clause_model. + intros cs. + rewrite -def_clause_sem_valid //. + - intros vm v vpos csem. todo "admit". Qed. @@ -3073,10 +3093,96 @@ Proof. apply LevelExprSet.singleton_spec in hadd. red in hadd. congruence. Qed. + +Module CounterExample1. (* x ∨ y -> y + 1 *) Definition valid_Z_counterexample_cls (x y : Level.t) : clause := ((singleton (x, 0) ∨ singleton (y, 0)), (y, 1))%nes. +(* x -> y + 1 *) +Definition valid_Z_counterexample_cl (x y : Level.t) : clause := + (singleton (x, 0), (y, 1))%nes. + +Example check_clause_invalid_Z_counterexample (x y : Level.t) : + x <> y -> + let cls := Clauses.singleton (valid_Z_counterexample_cls x y) in + let cl := valid_Z_counterexample_cl x y in + exists mcheck, check_gen cls cl = Invalid mcheck /\ valid_clause_Z cls cl. +Proof. + move=> hdiff cls cl. + set (v := (fun l : Level.t => if eqb l x then 1 else 0)%Z). + have vx : v x = 1. now rewrite /v eqb_refl. + have vy : v y = 0. rewrite /v. case: eqb_spec => //. subst; congruence. + have hcls : clauses_sem v cls. + { eapply clauses_sem_singleton. cbn. + rewrite interp_nes_union !interp_nes_singleton //=. + rewrite vx vy. cbn. lia. } + have hcon : consistent cls. + { exists v. split => //. + intros l. unfold v. case: eqb_spec => //. } + destruct check_gen eqn:ec. + - move/check_gen_entails_looping: ec. + move/consistent_no_loop. contradiction. + - exists m. split => //. + intros v' vpos csem. + unfold cl; cbn. + rewrite interp_nes_singleton //=. + move: (csem (valid_Z_counterexample_cls x y)) => /fwd. now eapply Clauses.singleton_spec. + cbn. rewrite !interp_nes_union !interp_nes_singleton //=. lia. + - exfalso. move/check_gen_entails: ec. + rewrite entails_completeness. + intros ent. + set (vopt := (fun l : Level.t => if eqb l x then Some 0 else None)%Z). + have voptx : vopt x = Some 0. now rewrite /vopt eqb_refl. + have vopty : vopt y = None. rewrite /vopt. case: eqb_spec => //. subst; congruence. + specialize (ent (option Z) _ vopt). + have hcls' : clauses_sem vopt cls. + { eapply clauses_sem_singleton. cbn. + rewrite interp_nes_union !interp_nes_singleton //=. + rewrite voptx vopty. now cbn. } + move: (ent hcls'); cbn. + rewrite !interp_nes_singleton //=. + now rewrite voptx vopty; cbn. +Qed. + +Example check_clause_checking_invalid_Z_example (x y : Level.t) : + x <> y -> + let cls := Clauses.singleton (valid_Z_counterexample_cls x y) in + let cl := valid_Z_counterexample_cl x y in + check_gen cls (checking_clause cl) = Valid. +Proof. + move=> hdiff cls cl. + set (v := (fun l : Level.t => if eqb l x then 1 else 0)%Z). + have vx : v x = 1. now rewrite /v eqb_refl. + have vy : v y = 0. rewrite /v. case: eqb_spec => //. subst; congruence. + have hcls : clauses_sem v cls. + { eapply clauses_sem_singleton. cbn. + rewrite interp_nes_union !interp_nes_singleton //=. + rewrite vx vy. cbn. lia. } + have hcon : consistent cls. + { exists v. split => //. + intros l. unfold v. case: eqb_spec => //. } + destruct check_gen eqn:ec. + - move/check_gen_entails_looping: ec. + move/consistent_no_loop. contradiction. + - exfalso. move/check_invalid_entails: ec. + apply. apply entails_completeness. + red. intros. + move: (H (valid_Z_counterexample_cls x y)) => /fwd. + now apply Clauses.singleton_spec. + cbn. rewrite !interp_nes_union !interp_nes_singleton //=. + rewrite !add_neutral. intros hle. + now rewrite join_comm. + - reflexivity. +Qed. + +End CounterExample1. + +Module CounterExample2. +(* x + 1 ∨ y -> y + 1 *) +Definition valid_Z_counterexample_cls (x y : Level.t) : clause := + ((singleton (x, 1) ∨ singleton (y, 0)), (y, 1))%nes. + (* x -> y *) Definition valid_Z_counterexample_cl (x y : Level.t) : clause := (singleton (x, 0), (y, 0))%nes. @@ -3150,16 +3256,509 @@ Proof. now apply Clauses.singleton_spec. cbn. rewrite !interp_nes_union !interp_nes_singleton //=. rewrite !add_neutral. intros hle. - apply (le_add (n:=1)). - etransitivity; tea. - rewrite !add_join !add_distr. - have -> : (1 + (0 - 1))%Q = 0 by cbn; lia. - rewrite add_neutral join_comm. - eapply join_le_pres. reflexivity. - red. now rewrite join_sub. + eapply (le_add (n := 1)). + rewrite !add_join !add_distr add_neutral join_comm. + exact hle. - reflexivity. Qed. +End CounterExample2. + +(** To ensure validity in Z, one must remove "latent" loops from the clauses. + As we start validity checking from a set of satisfiable clauses, we know + that there exists an equivalent set of clauses (for Z valuations) with + no latent loop. + It is basically computed by the inference algorithm. + + E.g. if we encountered a clause l ∨ x + 1 -> l+1 during inference and found + a total model m of this clause, then necessarily the model also validates + x + 1 -> l + 1 as: + + min_premise m (l ∨ x + 1) = (min m[l] m[x]-1)+1 <= m[l] <-> m[x] <= m[l] + + So, instead of checking d + + +*) + +Class In T E := in_pred : E -> T -> Prop. +Instance Ines : In LevelExprSet.t LevelExpr.t := LevelExprSet.In. +Instance Inprems : In NES.t LevelExpr.t := fun x s => LevelExprSet.In x s. + +Notation " x ∈ S " := (in_pred x S) (at level 20). + +Equations remove_prem_opt (le : LevelExpr.t) (e : NES.t) : option NES.t := + remove_prem_opt le e with inspect (LevelExprSet.is_empty (LevelExprSet.remove le e)) := + | exist true _ => None + | exist false he => Some {| t_set := LevelExprSet.remove le e; t_ne := he |}. + +Lemma remove_prem_opt_Some le e e' le' : + remove_prem_opt le e = Some e' -> + LevelExprSet.In le' e' <-> + LevelExprSet.In le' e /\ le <> le'. +Proof. + funelim (remove_prem_opt le e) => //. + intros [= <-]; cbn. + rewrite LevelExprSet.remove_spec /LevelExprSet.E.eq. + intuition auto. +Qed. + +Lemma remove_prem_opt_Some_eq le e e' : + le ∈ e -> + remove_prem_opt le e = Some e' -> + e = union (singleton le) e' /\ ~ le ∈ e'. +Proof. + intros hin. + move/remove_prem_opt_Some => hl. + split. + - apply equal_exprsets => lk. + rewrite LevelExprSet.union_spec LevelExprSet.singleton_spec. + rewrite hl. + destruct (Classes.eq_dec lk le). + * subst. split => // _. now left. + * split => //. intros hin'. now right. + intros []. congruence. apply H. + - intros hin'. specialize (hl le). + apply hl in hin'. destruct hin'. congruence. +Qed. + +Lemma remove_prem_opt_None le e : + remove_prem_opt le e = None -> + LevelExprSet.In le e <-> e = singleton le. +Proof. + funelim (remove_prem_opt le e) => //. + intros _. clear H. move: e0. + rewrite LevelExprSet.is_empty_spec. + intros he. + split. intros. + - red in he. + apply equal_exprsets => l. + rewrite LevelExprSet.singleton_spec /LevelExprSet.E.eq. + split. intros hin. + setoid_rewrite LevelExprSet.remove_spec in he. + destruct (Classes.eq_dec l le0) => //. + elim (he l). split => //. + now intros ->. + - intros ->. now eapply LevelExprSet.singleton_spec. +Qed. + +Definition union_opt (e : NES.t) (e' : option NES.t) : NES.t := + match e' with + | Some e' => union e e' + | None => e + end. + +Lemma union_opt_union e e' e'' : union (union_opt e e') e'' = union e (union_opt e'' e'). +Proof. + destruct e'; cbn. + now rewrite union_assoc (@union_comm t0). + reflexivity. +Qed. + +Lemma union_remove le prems : + le ∈ prems -> + union_opt (singleton le) (remove_prem_opt le prems) = prems. +Proof. + intros hin. + destruct (remove_prem_opt le prems) eqn:hr. + - apply equal_exprsets => lk. + cbn. rsets; rewrite /LevelExprSet.E.eq. + eapply remove_prem_opt_Some in hr. erewrite hr. + firstorder auto. subst. apply hin. + destruct (Classes.eq_dec lk le). now left. + right. firstorder. + - apply remove_prem_opt_None in hr. + apply hr in hin. subst prems. now cbn. +Qed. + +Lemma entails_weak_union_opt cls prems prems' concl : + entails cls (prems, concl) -> + entails cls (union_opt prems prems', concl). +Proof. + destruct prems'; cbn => //. + now intros ent; rewrite union_comm; eapply entails_weak_union. +Qed. + +Inductive max_chain cls : Clause.t -> Prop := +| incl cl : entails cls cl -> max_chain cls cl +| chain {prems concl k k'} {prems' : NES.t} {concl'} : + max_chain cls (prems, (concl, k)) -> + max_chain cls (prems', concl') -> + (concl, k') ∈ prems' -> + max_chain cls (union_opt (add_prems (k' - k) prems) (remove_prem_opt (concl, k') prems'), concl'). + +Lemma max_chain_entails cls cl : + max_chain cls cl <-> entails cls cl. +Proof. + split. + + induction 1. + - exact H. + - eapply (entails_cumul_one (prems' := singleton (concl0, k'))); revgoals. + { rewrite union_opt_union union_remove //. now eapply entails_weak_union. } + eapply (entails_shift (k' - k)) in IHmax_chain1. + cbn in IHmax_chain1. + have heq: k' - k + k = k' by lia. + rewrite heq in IHmax_chain1. + eapply entails_all_singleton. + now eapply entails_weak_union_opt. + + intros ent; now apply incl. +Qed. + +Definition thin_clause m cl := + let prems := premise cl in + let filter '(l, k) := if entails_dec m (prems, (l, k + 1)) then false else true in + LevelExprSet.filter filter (premise cl). + +Lemma empty_filter f les : + LevelExprSet.is_empty (LevelExprSet.filter f les) -> + forall l, LevelExprSet.In l les -> f l = false. +Proof. + move/LevelExprSet.is_empty_spec. + have hs := LevelExprSet.partition_spec2 (f:=f) les. forward hs. tc. + have hs' := LevelExprSet.partition_spec1 (f:=f) les. forward hs'. tc. + rewrite -hs'. + intros he l. + specialize (hs' l). specialize (hs l). + destruct (f l) eqn:hl. + rewrite LevelExprSet.filter_spec in hs'. + specialize (he l). rewrite hs' in he. intros hin; elim he; split => //. + auto. +Qed. + +Lemma partition_in f les : + forall lk, LevelExprSet.In lk les <-> + LevelExprSet.In lk (LevelExprSet.partition f les).1 \/ + LevelExprSet.In lk (LevelExprSet.partition f les).2. +Proof. + intros lk. + rewrite LevelExprSet.partition_spec1 LevelExprSet.partition_spec2. + rewrite !LevelExprSet.filter_spec. + firstorder auto. + destruct (f lk); firstorder. +Qed. + +Lemma thin_clause_spec m cl : + let prems := thin_clause m cl in + if LevelExprSet.is_empty prems then + entails_all (clauses m) (premise cl) (succ (premise cl)) + else + exists premsnl premsl, + [/\ premise cl = (union_opt premsnl premsl)%nes, + prems = premsnl, + (forall l k, (l, k) ∈ premsnl -> ~ entails (clauses m) (premise cl, (l, k+1))) & + on_Some_or_None (fun premsl => entails_all (clauses m) (premise cl) (succ premsl)) premsl]. +Proof. + intros prems. + destruct (LevelExprSet.is_empty prems) eqn:ise. + - have ha : forall l k, LevelExprSet.In (l, k) (premise cl) -> entails (clauses m) (premise cl, (l, k + 1)). + intros l k hin. + eapply (empty_filter _ _ ise) in hin. + destruct entails_dec => //. + move=> -[] l k /In_add_prems -[[l' k']] [] hin ->. + eapply ha in hin. rewrite /succ_expr //=. now rewrite Z.add_comm. + - subst prems; unfold thin_clause in *. + set (fn := fun '(l, k) => _) in *. + set (fil := LevelExprSet.filter _ _) in *. + have hs := LevelExprSet.partition_spec2 (f:=fn) (premise cl). forward hs. tc. + have hs' := LevelExprSet.partition_spec1 (f:=fn) (premise cl). forward hs'. tc. + set (part := LevelExprSet.partition _ _) in *. + exists {| t_set := fil; t_ne := ise |}. + destruct (LevelExprSet.is_empty part.2) eqn:ise2. + * exists None. + cbn. split => //. + { apply equal_exprsets; cbn. + move=> lk. rewrite LevelExprSet.filter_spec. + intuition auto. + rewrite hs in ise2. + have he := empty_filter _ _ ise2. + specialize (he lk H). + destruct (fn lk) => //. } + { move=> l k /LevelExprSet.filter_spec -[] hin hf hent. + unfold fn in hf. destruct entails_dec => //. } + * exists (Some {| t_set := part.2; t_ne := ise2 |}). + cbn. split => //. + apply equal_exprsets => l. cbn. + rewrite LevelExprSet.union_spec. + rewrite -[fil]hs'. + now rewrite -partition_in. + { move=> l k /LevelExprSet.filter_spec -[] hin' hf hent. + unfold fn in hf. destruct entails_dec => //. } + { move=> l /In_add_prems -[[le' le'k]] []. + cbn. rewrite hs => /LevelExprSet.filter_spec [] hin heq. + intros ->. unfold fn in heq. destruct entails_dec => //. + cbn in heq. now rewrite Z.add_comm. } +Qed. + +Equations thin_clause_opt (m : t) (cl : clause) : option clause := + | m, cl with inspect (LevelExprSet.is_empty (thin_clause m cl)) := + | exist true _ => None + | exist false ne => Some ({| t_set := thin_clause m cl; t_ne := ne |}, concl cl). + + +Lemma thin_clause_opt_spec m cl : + match thin_clause_opt m cl with + | None => False + | Some cl' => + exists premsnl premsl, + [/\ premise cl = union_opt premsnl premsl, + cl' = (premsnl, concl cl), + (forall l k, (l, k) ∈ premsnl -> ~ entails (clauses m) (premise cl, (l, k+1))) & + on_Some_or_None (fun premsl => entails_all (clauses m) (premise cl) (succ premsl)) premsl] + end. +Proof. + funelim (thin_clause_opt m cl); clear H. + - assert (h := thin_clause_spec m cl). + cbn in h. + rewrite e in h. + now eapply model_entails_loop in h. + - assert (h := thin_clause_spec m cl). + cbn in h. + clear Heqcall. + rewrite ne in h. + destruct h as [premsnl [premsl []]]. + exists premsnl, premsl; split => //. + f_equal. apply equal_exprsets; cbn. now rewrite H0. +Qed. + +Lemma interp_nes_thin_clause (v : Level.t -> Z) {m cl ne} {premsnl : NES.t} : + thin_clause m cl = premsnl -> + interp_nes v ({| t_set := thin_clause m cl; t_ne := ne |}) = + interp_nes v premsnl. +Proof. + intros eq. + destruct premsnl. + destruct cl as [prems concl]; cbn in eq. + subst t_set0. f_equal. + apply equal_exprsets. cbn. reflexivity. +Qed. + +Lemma interp_nes_union_opt v e e' : + interp_nes v (union_opt e e') = + match e' with + | Some e' => Z.max (interp_nes v e) (interp_nes v e') + | None => interp_nes v e + end. +Proof. + destruct e' => //=. + now rewrite interp_nes_union; cbn. +Qed. + +Lemma thin_clause_opt_valid m cl : + match thin_clause_opt m cl with + | None => False + | Some cl' => valid_clause_Z (clauses m) cl <-> valid_clause_Z (clauses m) cl' + end. +Proof. + (* intros hent. *) + funelim (thin_clause_opt m cl). + - clear H Heqcall. + have hs := thin_clause_spec m cl. + cbn in hs. rewrite e in hs. + now eapply model_entails_loop in hs. + - clear H Heqcall. + have hs := thin_clause_spec m cl. + cbn in hs. rewrite ne in hs. + destruct cl as [prems [concl k]]. + rewrite /valid_clause_Z. cbn. + cbn in hs. destruct hs as [premsl [premsnl [heq heq' hent' hentl]]]. + split. + * move=> hv v vpos csem. + have hi := interp_nes_thin_clause v (ne := ne) heq'. + move: hv => /(_ v vpos csem). + rewrite hi. subst prems. + rewrite interp_nes_union_opt. + destruct premsnl => //. + destruct heq'. + move/to_entails_all: hentl. + move/entails_L_entails_ℋ_equiv/entails_L_rels_entails_L_clauses/completeness_all. + move/(_ Z _ v). + rewrite -interp_rels_clauses_sem. + move/(_ csem). + rewrite -interp_rels_clauses_sem. + move/clauses_sem_clauses_of_le. + rewrite interp_add_prems interp_nes_union. + cbn in hent' |- *. lia. + * move=> hv v vpos csem. + have hi := interp_nes_thin_clause v (ne := ne) heq'. + move: hv => /(_ v vpos csem). + rewrite hi. + subst prems. + rewrite interp_nes_union_opt. + destruct premsnl => //. + destruct heq'. + move/to_entails_all: hentl. + move/entails_L_entails_ℋ_equiv/entails_L_rels_entails_L_clauses/completeness_all. + move/(_ Z _ v). + rewrite -interp_rels_clauses_sem. + move/(_ csem). + rewrite -interp_rels_clauses_sem. + move/clauses_sem_clauses_of_le. + rewrite interp_add_prems interp_nes_union. + cbn in hent' |- *. lia. +Qed. + +(* +Lemma thin_clause_opt_entails m cl : + match thin_clause_opt m cl with + | None => False + | Some cl' => entails (clauses m) cl' -> entails (clauses m) cl + end. +Proof. Admitted. *) + +Definition thin_clauses m := + Clauses.fold (fun cl acc => + match thin_clause_opt m cl with + | Some cl' => Clauses.add cl' acc + | None => acc (* Impossible for consistent models *) + end) (clauses m) Clauses.empty. + +Lemma thin_clauses_spec m : + forall cl, Clauses.In cl (clauses m) -> + exists cl', thin_clause_opt m cl = Some cl' /\ Clauses.In cl' (thin_clauses m). +Proof. Admitted. + +Lemma thin_clauses_spec_inv m : + forall cl, Clauses.In cl (thin_clauses m) -> + exists clo, thin_clause_opt m clo = Some cl /\ Clauses.In clo (clauses m). +Proof. Admitted. + +(** The thinned clauses are stronger than the original clauses *) +Lemma thin_clauses_entails m : thin_clauses m ⊢ℋ clauses m. +Proof. + intros cl hin. + destruct (thin_clauses_spec m cl hin) as [cl' [heq hin']]. + have hs := thin_clause_opt_spec m cl. + rewrite heq in hs. destruct hs as [premsnl [premsl [eq eq' ent ent']]]. + destruct cl as [prems concl]. cbn in eq, eq', ent. + subst prems cl'. + now eapply entails_weak_union_opt, entails_in. +Qed. + +Lemma is_model_entails_H m cls cls' : + is_model m cls -> + cls ⊢ℋ cls' -> + is_model m cls'. +Proof. + move=> /[dup] ism. rewrite !is_modelP. + move=> ha hent cl /hent ent. + specialize (ha cl). + eapply entails_model_valid; tea. +Qed. + +Lemma thin_clauses_model model m : + is_model model (thin_clauses m) -> is_model model (clauses m). +Proof. + move=> ism. eapply is_model_entails_H; tea. + eapply thin_clauses_entails. +Qed. + +Lemma is_model_singleton m cl : is_model m (Clauses.singleton cl) <-> valid_clause m cl. +Proof. + rewrite is_modelP. split. + * move/(_ cl) => /fwd //. clsets. + * now move=> hv cl' /Clauses.singleton_spec ->. +Qed. + +Definition valid_non_vacuous m cl := + exists minp value, + [/\ min_premise m (premise cl) = Some minp, + level_value m (concl cl).1 = Some value & + minp + (concl cl).2 <= value]. + +Definition is_total_model_alt m cls := + forall cl, Clauses.In cl cls -> valid_non_vacuous m cl. + +Lemma is_total_model_altP m cls : + is_total_model m cls <-> is_total_model_alt m cls. +Proof. + split. + - move=> -[] en /is_modelP ism. + move=> [prems [concl k]] /[dup] /en [minp hmin] /ism. + move/valid_clause_elim/(_ _ hmin). + move/Some_leq => -[] z' [] hl hleq. + exists minp, z'. split => //. + - move=> ism; split. + * now move=> cl /ism -[] minp [] value [] => //; exists minp. + * apply/is_modelP => cl /ism -[] minp [] value [] => // hmin hl hle. + destruct cl as [prems [concl k]]. + apply valid_clause_intro => z hz. + rewrite hmin in hz. noconf hz. + rewrite hl; constructor. exact hle. +Qed. + +Lemma min_premise_union m prems prems' : + min_premise m (prems ∨ prems') = min_opt (min_premise m prems) (min_premise m prems'). +Proof. + pattern prems, (min_premise m prems). + set (P := fun t0 => _). + revert prems. + apply: (@min_premise_elim m _ _ _); subst P; cbn. + - intros le. now rewrite union_comm union_add_singleton min_premise_add. + - intros prems acc le he hnin. + rewrite -union_add_singleton (@union_comm prems) union_assoc union_comm union_add_singleton. + rewrite min_premise_add he. + now rewrite assoc. +Qed. + +Lemma valid_clauses_of_le m prems prems' : + m ⊨ prems ⋞ prems' -> + forall min min', min_premise m prems' = Some min -> + min_premise m prems = Some min' -> + min <= min'. +Proof. + revert prems'. + eapply min_premise_elim. + - intros [l k] prems'. + intros hl. specialize (hl (prems', (l, k))). + forward hl. rewrite clauses_of_le_spec. exists (l, k). split => //. + now apply singleton_spec. cbn in hl. + move/valid_clause_elim: hl => hz. + move=> min min' /hz /Some_leq -[y'] [] /level_value_MapsTo' hl leq hat. + rewrite (Model.min_atom_value_mapsto hl) in hat. cbn in hat. noconf hat. lia. + - intros prems' acc le ih hnin prems0 hadd min min' minp minp'. + move: (ih prems0) => /fwd. + { move=> cl. rewrite clauses_of_le_spec => -[lk [hin heq]]. + move: (hadd cl) => /fwd //. subst cl. rewrite clauses_of_le_spec. + exists lk. split => //. eapply LevelExprSet.add_spec; now right. } + move=>/(_ _ _ minp). + destruct (min_atom_value m le) eqn:hat => //. destruct acc; noconf minp'. + 2:{ cbn in minp'. destruct acc => //. } + move/(_ _ eq_refl). + move: (hadd (prems0, le)) => /fwd. + { rewrite clauses_of_le_spec. exists le. split => //. + eapply LevelExprSet.add_spec; now left. } + destruct le as [le lek]; move/valid_clause_elim/(_ _ minp) => /Some_leq. + apply min_atom_value_mapsto in hat. rewrite (level_value_MapsTo hat). + move=> -[y'] [] [=] <-. lia. +Qed. + +Lemma is_total_model_thin m m' : + is_total_model m' (clauses m) -> + is_total_model m' (thin_clauses m). +Proof. + move/is_total_model_altP => ism. + apply/is_total_model_altP => cl /thin_clauses_spec_inv -[] cl' [] heq /ism. + have := thin_clause_opt_spec m cl'. + rewrite heq => -[premsnl] [premsl] [eq eq' ent nent]. + subst cl. + move=> -[] minp [] value [] => hmin hl hle. + exists minp, value. cbn. split => //. + rewrite -hmin eq. + apply antisymmetry; revgoals. + { eapply min_premise_subset. destruct premsl; cbn; lesets. } + destruct premsl as [premsl|]; cbn => //; revgoals. reflexivity. + rewrite min_premise_union. + cbn in nent. + rewrite -to_entails_all in nent. + eapply entails_all_model_valid in nent. 2:{ apply is_model_valid. eapply is_total_model_altP in ism. apply ism. } + rewrite eq in nent. cbn in nent. + rewrite eq min_premise_union in hmin. + destruct (min_premise m' premsl) as [minl|] eqn:minle, (min_premise m' premsnl) as [minnl|] eqn:minnle; cbn in hmin |- * => //. + noconf hmin. constructor. + eapply valid_clauses_of_le in nent. 2:{ rewrite min_premise_union minle minnle //=. } + 2:{ rewrite (min_premise_add_prems minle); trea. } lia. +Qed. + Lemma check_clause_valid_Z m cl : check_clause m cl -> valid_clause_Z (clauses m) cl. Proof. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 812ab4ffe..01c6b4358 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -184,7 +184,6 @@ Qed. Module UnivLoopChecking. Module LoopCheck := LoopChecking LS. Import LoopCheck.Impl.Abstract. - Import LoopCheck.Impl.CorrectModel (clauses_sem, clause_sem, clauses_sem_union). Import LoopCheck.Impl.I. Import Universes (valuation). Import LoopCheck. @@ -475,7 +474,7 @@ End ZUnivConstraint. Proof. have := LoopCheck.zero_declared m. have := LoopCheck.Impl.Abstract.model_levels m.(model) Level.lzero. - rewrite /LoopCheck.Impl.CorrectModel.zero_declared. intros ->. + rewrite /Impl.zero_declared. intros ->. intros [k hm]. now exists (Z.of_nat (S k)). Qed. @@ -763,12 +762,10 @@ End ZUnivConstraint. rewrite interp_nes_union //=. Qed. - Import LoopCheck.Impl.CorrectModel (clause_sem, clauses_sem, clauses_sem_union, to_val, to_Z_val). - Lemma interp_cstr_clauses_sem {c} {S} {SL : Semilattice S Q.t} {v : Level.t -> S} : interp_univ_cstr v c <-> clauses_sem v (LoopCheck.to_clauses (to_constraint c)). Proof. - rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. + rewrite interp_rels_clauses_sem. rewrite relation_of_constraint_of_clause. rewrite /Clauses.ISL.interp_rels Forall_tip. destruct c as [[l []] r]; cbn => //. @@ -779,7 +776,7 @@ End ZUnivConstraint. interp_univ_cstrs v (constraints m) <-> clauses_sem v (LoopCheck.clauses m). Proof. rewrite interp_univ_cstrs_relations. - rewrite LoopCheck.Impl.Abstract.interp_rels_clauses_sem. + rewrite interp_rels_clauses_sem. now rewrite -[Clauses.relations_of_clauses _]equiv_constraints_clauses. Qed. @@ -920,8 +917,6 @@ End ZUnivConstraint. Definition valuation_to_Z (v : Universes.valuation) : Level.t -> Z := fun l => Z.of_nat (val v l). - Import LoopCheck.Impl.CorrectModel (Zopt_semi, positive_valuation). - Lemma positive_valuation_to_Z v : positive_valuation (valuation_to_Z v). Proof. @@ -1352,8 +1347,6 @@ End ZUnivConstraint. let add_val l := LevelMap.add l (val v l) in LevelSet.fold add_val V (LevelMap.empty _). - Import LoopCheck.Impl.CorrectModel (to_Z_val, clauses_sem, clause_sem). - Definition wf_valuation V v := forall l, LevelSet.In l V -> if l == Level.zero then v l = 0 @@ -1797,14 +1790,10 @@ End ZUnivConstraint. - exact ha. Qed. - Existing Instance Impl.CorrectModel.Zopt_semi. - Instance nat_opt_semi : Semilattice (option nat) nat := opt_semi Natsemilattice. - Import Impl.CorrectModel (positive_valuation, positive_opt_valuation, opt_valuation_of_model_pos). - Definition valid_Z_model m c := - (forall (v : Level.t -> Z), positive_valuation v -> interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + (forall (v : Level.t -> option Z), positive_opt_valuation v -> interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). Infix "⊩Z" := valid_Z_model (at level 70, no associativity). @@ -1820,7 +1809,7 @@ End ZUnivConstraint. Proof. rewrite LoopCheck.check_Z_complete_positive /valid_Z_model. setoid_rewrite interp_cstrs_clauses_sem; setoid_rewrite interp_cstr_clauses_sem. - rewrite /valid_clauses. todo "update". + rewrite /valid_clauses. reflexivity. Qed. Lemma interp_univ_cstrs_of_m m : @@ -1832,12 +1821,12 @@ End ZUnivConstraint. (** The current model must already imply the constraint. Note that the converse is not true: a constraint can be satisfied by chance in the model. *) - Theorem check_implies {m c} : + (* Theorem check_implies {m c} : check m c -> interp_univ_cstr (to_Z_val (valuation m)) c. Proof. - todo "update". - (* now rewrite check_completeness => /(_ (to_Z_val (opt_valuation m) (opt_valuation_of_model_pos) (interp_univ_cstrs_of_m m)). *) - Qed. + rewrite check_completeness => /(_ (model_opt_val m) (opt_valuation_of_model_pos) (interp_univ_cstrs_of_m m)). + + Qed. *) Definition valid_model m c := (forall S (SL : Semilattice S Q.t) (v : Level.t -> S), interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). diff --git a/common/theories/LoopChecking/ZModels.v b/common/theories/LoopChecking/ZModels.v new file mode 100644 index 000000000..eede3f508 --- /dev/null +++ b/common/theories/LoopChecking/ZModels.v @@ -0,0 +1,315 @@ + + +Definition split_clauses m cls := + Clauses.partition (is_enabled_clause m) cls. + +Definition enabled_clauses_of m cls := (split_clauses m cls).1. +Definition disabled_clauses_of m cls := (split_clauses m cls).2. + +Lemma split_clauses_spec_1 m cls : + cls =_clset Clauses.union (enabled_clauses_of m cls) (disabled_clauses_of m cls). +Proof. Admitted. + +Lemma enabled_clauses_spec m cl cls : Clauses.In cl (enabled_clauses_of m cls) <-> Clauses.In cl cls /\ enabled_clause m cl. +Admitted. + +Lemma disabled_clauses_spec m cl cls : Clauses.In cl (disabled_clauses_of m cls) <-> Clauses.In cl cls /\ ~ enabled_clause m cl. +Admitted. + +Lemma nenabled_clause m cl : ~ enabled_clause m cl <-> min_premise m (premise cl) = None. +Proof. + case: (reflect_enabled m cl) => //. + split => //. red in p. firstorder. congruence. + firstorder. cbn in H. destruct min_premise => //. + destruct (H _ eq_refl). +Qed. + +Lemma is_model_split m cls : + is_model m cls <-> (is_total_model m (enabled_clauses_of m cls)). +Proof. + split. + - move/Clauses.for_all_spec => ism. + split. + intros cl. now rewrite enabled_clauses_spec. tc. + apply Clauses.for_all_spec. tc. + move=> cl /enabled_clauses_spec => -[] /ism //. + - move=> -[]. intros en. red in en. red in en. + intros ism. rewrite (split_clauses_spec_1 m cls). + eapply is_model_union. auto. + eapply Clauses.for_all_spec. tc. + move=> [prems [concl k]] /disabled_clauses_spec -[] hin hen. + Search enabled_clause. + apply valid_clause_intro. + now move/nenabled_clause: hen => ->. +Qed. + +Lemma enabled_clause_defined {m cl} : + enabled_clause m cl -> + defined_model_of (NES.levels (premise cl)) m. +Proof. + destruct cl as [prems [concl k]]; cbn. + move=> -[] z //= /min_premise_spec' hl. + move=> l /NES.levels_spec -[] k' /hl [v] [] hm _. + eapply level_value_MapsTo' in hm. now eexists. +Qed. + +Lemma check_clause_invalid_Z cls cl mcheck : + check_gen cls cl = Invalid mcheck -> ~ valid_clause_Z (enabled_clauses_of mcheck cls) cl. +Proof. + move/check_invalid => -[ism mof min en inv] nv. + destruct cl as [prems [concl k]]. + destruct (level_value mcheck concl) eqn:he. + * specialize (nv (Z_valuation_of_model mcheck)). + forward nv. apply valuation_of_model_pos. + forward nv. apply is_model_split in ism. + apply valid_clauses_model. apply ism. apply ism. + move: nv. + rewrite def_clause_sem_valid. + unfold defined_model_of. + intros l; rewrite clause_levels_spec //=. + intros [hin|eq]. + move/enabled_clause_defined: en. + now move/(_ _ hin). subst. + eapply level_value_MapsTo' in he. now eexists. + contradiction. + * apply is_model_split in ism. + destruct en as [minp eqmin]. + remember (interp_nes (Z_valuation_of_model mcheck) prems) as iprems eqn:hprems. + symmetry in hprems. + set val := fun l => + if l == concl then iprems + 1 - k + else Z_valuation_of_model mcheck l. + specialize (nv val). + forward nv. admit. + forward nv. admit. + move: nv; cbn. + rewrite {1}/val eqb_refl. + have eqi : interp_nes val prems = interp_nes (Z_valuation_of_model mcheck) prems. + move/min_premise_spec': eqmin => //=. + eapply interp_nes_elim. tc. + intros [le lek] h. rewrite /interp_expr. + rewrite interp_nes_singleton /interp_expr //=. + specialize (h le lek). admit. + intros. admit. + rewrite !eqi hprems. lia. +Admitted. + +Lemma contra A B : (A -> B) -> (~ B -> ~ A). +Proof. intros f nb a. exact (nb (f a)). Qed. + +Lemma invalid_clause_Z_ex cls cl : + (exists v : Level.t -> Z, positive_valuation v /\ clauses_sem v cls /\ ~ clause_sem v cl) -> + ~ valid_clause_Z cls cl. +Proof. + intros [v [vpos [cs ncsem]]]. + red. move/(_ v vpos cs). contradiction. +Qed. + +(* + Check for validity in Z: cls |= cl. + + Take an existing total model m of cls. + Add clauses low: v -> Set forall v. Ensure m[Set] = model_max m. + Add clauses high Set + 1 + (model_max - m[v]) -> v for every v, trivially + satisfied: as min_premise m [Set + 1 + (model_max m - m[v])] = + model_max m - (1 + (model_max m - model_min m)) = - 1 - model_min m <= m[v]. + + So m is also a total model of cls + low + high. + Launch checking for cls' ⊃ cls. + If we find a loop we get cls' |- loop, but as m is a total model of cls', that implies false in Z. + Otherwise we get a valid model [mcheck |= cls'] + and either valid_clause mcheck cl or ~ valid_clause mcheck cl. + - If valid_clause mcheck cl, then + mcheck |= cls as cls ⊂ cls'. + So we have a valid clause in Zinf and Z, but not a proof + for every valuation... + + E.g check x >= 0, y >= 0 -> x >= y. + adds 0 >= x and 0 >= y, forcing x = y = 0! + Add instead just 0 >= y, not better, it entails x >= y = 0. + Add instead just ⊥ + 1 >= y: starting from { x = 0; y = None; ⊥ = None }. + we get + { x = 0; y = None; ⊥ = 0 }, + { x = 0; y = -1; ⊥ = 0 }. Good, does not entail x >= y + But x + 1 >= y ? + { x = 1; y = None; ⊥ = None } -> + { x = 1; y = None; ⊥ = 1 } -> + { x = 1; y = 0; ⊥ = 1 }. + Ok as well. + + - If ~ valid_clause mcheck cl. + Then we have clauses_sem (Z_valuation_of_model mcheck) cls', + so clauses_sem (Z_valuation_of_model mcheck) cls, and + ~ clause_sem (Z_valuation_of_model mcheck) cl. +*) + +Definition bound_clauses (m : Model.model) := + LevelMap.fold (fun l k => + Clauses.add (singleton (Level.zero, model_max m + 1 - option_get 0 k), (l, 0))) m Clauses.empty. + +Lemma bound_clauses_spec {cl m} : + Clauses.In cl (bound_clauses m) -> + exists l k, LevelMap.MapsTo l k m /\ cl = (singleton (Level.zero, model_max m + 1 - option_get 0 k), (l, 0)). +Proof. + rewrite /bound_clauses. + set (mmax := model_max m). clearbody mmax. + eapply LevelMapFact.fold_rec. + - intros s' he hin. clsets. + - intros x a cls s' s'' hin hnin hadd ih. + rsets. destruct H. + * subst cl. exists x, a. split. + eapply levelmap_add_spec in hadd. rewrite hadd. + apply LevelMapFact.F.add_mapsto_iff. now left. reflexivity. + * eapply levelmap_add_spec in hadd. + specialize (ih H) as [l []]. exists l, x0. split => //. + rewrite hadd. + apply LevelMapFact.F.add_mapsto_iff. right; split => //. + intros ->. destruct H0. subst cl. + apply hnin; now eexists. + apply H0. apply H0. +Qed. +(* +Lemma bound_clauses_spec_inv {l k V} : + LevelSet.In l V -> + Clauses.In (singleton (Level.zero, k), (l, 0)) (bound_clauses k V). +Proof. + rewrite /bound_clauses. + eapply LevelSetProp.fold_rec. + - intros s' he hin. lsets. + - intros x a s' s'' hin hnin hadd ih. + rsets. apply hadd in H as [H|H]. + * subst l. now left. + * specialize (ih H). now right. +Qed. *) + +Lemma bound_clauses_prop m cls : + is_model m cls -> is_model m (bound_clauses m). +Proof. + intros ism. + apply is_modelP => cl /bound_clauses_spec -[] l [k] [] hm heq. + subst cl. + apply valid_clause_intro => z. + rewrite min_premise_singleton /min_atom_value. + destruct level_value eqn:hl => //=. + have hz : z0 = model_max m. todo "zero spec". + subst z0. + intros [=]. + have hzeq : z = - 1 + option_get 0 k. lia. + rewrite hzeq. + rewrite (level_value_MapsTo hm). destruct k. cbn in *; subst. + constructor. lia. + cbn in *. subst z. + todo "defined level". +Qed. + +Lemma bound_clauses_ext m m' : + m' ⩽ m -> is_model m (bound_clauses m) -> is_model m' (bound_clauses m). +Proof. + intros hext. +Abort. + + +Definition check_gen_Z (m : t) cl := + check_gen (Clauses.union (bound_clauses m) (clauses m)) cl. + +Lemma enabled_clause_mcheck_zero_enabled mcheck cl cls : + enabled_clause mcheck cl -> + is_model mcheck cls -> + Deciders.above_zero_declared (clauses_levels cls) cls -> + exists k, LevelMap.MapsTo Level.zero (Some k) mcheck. +Proof. +Admitted. + +Lemma enabled_clause_mcheck_all_enabled mcheck cl cls : + enabled_clause mcheck cl -> + is_model mcheck cls -> + Deciders.above_zero_declared (clauses_levels cls) cls -> + forall l, LevelMap.In l mcheck -> exists k, LevelMap.MapsTo l (Some k) mcheck. +Proof. +Admitted. + +Lemma option_map_add_zero k : option_map (Z.add 0) k = k. +Proof. destruct k => //. Qed. + +Lemma check_clause_invalid_Z_dis m cl : + clause_levels cl ⊂_lset levels m -> + check_gen_Z m cl = Valid -> valid_clause_Z (clauses m) cl. +Proof. + intros hwf. + unfold check_gen_Z. + set (bcls := bound_clauses _). + set (cls' := Clauses.union _ _). + move/check_gen_entails. + rewrite entails_completeness. + intros hm. eapply valid_total_models_Z_models. + intros m' tot def. + specialize (hm (option Z) _ (opt_valuation_of_model m')). + apply clause_sem_valid. apply hm. + eapply clauses_sem_union. + destruct tot as [en ism]. + split; revgoals. + eapply clauses_sem_valid; exact ism. revgoals. eauto. + have hmin : minimal_above (clauses m) (check_init_model (clauses m) cl) m. + admit. + red in hmin. + specialize (hmin m'). forward hmin. admit. + forward hmin. exact ism. + intros cl' hin. + eapply bound_clauses_spec in hin as [l [k [hm' heq]]]. + subst cl'. cbn -[Semilattice.eq]. rewrite interp_nes_singleton /interp_expr. + rewrite /opt_valuation_of_model. + case: (find_spec l m'). + intros k0 hml. destruct k0 => //. 2:{ todo "m' must have a value for l". } + case: (find_spec Level.zero m'). + intros kz hmz. destruct kz. 2:{ todo "zero must have a value". } + rewrite option_map_add_zero. + destruct k. + have hmax : z0 = model_max m'. admit. + subst z0. + have hv := valuation_of_value_pos hml. + cbn -[Semilattice.le]. cbn. + eapply hmin in hm' as [k' []]. + eapply LevelMapFact.F.MapsTo_fun in hml; tea. subst k'. depelim H0. + rewrite /valuation_of_value. + have hmleq : model_max m <= model_max m'. admit. + unfold valuation_of_value in hv. + have hv' := valuation_of_value_pos H0. + unfold valuation_of_value in hv'. + have hmeq : (model_max m' - model_max m' - model_min m') = - model_min m'. lia. + rewrite hmeq. lia. + cbn. + todo "scope". + todo "zero defined". + todo "zero defined". +Qed. + +Lemma check_clause_invalid_Z_dis m cl mcheck : + clause_levels cl ⊂_lset levels m -> + check_gen_Z m cl = Invalid mcheck -> ~ valid_clause_Z (clauses m) cl. +Proof. + intros hwf. + unfold check_gen_Z. + set (bcls := bound_clauses _ _). + set (cls' := Clauses.union _ _). + move/check_invalid => -[ism mof hmin en inval]. + apply invalid_clause_Z_ex. + exists (Z_valuation_of_model mcheck). + split. apply valuation_of_model_pos. + have hab := above_zero_declared m. + have hdef0 : defined_model_of (clauses_levels cls') mcheck. + { eapply enabled_clause_defined in en. + specialize (hab (choose (premise cl)).1). + forward hab. apply hwf. + eapply clause_levels_spec. left. + eapply NES.levels_spec. exists (choose (premise cl)).2. + destruct (choose _) eqn:hc. cbn. rewrite -hc. + eapply choose_spec. + red in hab. + } + split. + eapply valid_clauses_model. admit. + eapply is_model_subset; tea. subst cls'; clsets. + intros csem. + eapply def_clause_sem_valid in csem. contradiction. + eapply enabled_clause_defined in en. admit. +Qed. \ No newline at end of file diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 2912eae95..f094d9a39 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -24,15 +24,24 @@ Hint Extern 10 => absurd : core. (** * Valuations *) -(** A valuation is a universe level (nat) given for each - universe lvariable (Level.t). - It is >= for polymorphic concrete_sort and > 0 for monomorphic concrete_sort. *) +(** A valuation gives a constant universe level (in nat) or +∞ for each + universe variable (Level.t). + It is >= 0 for polymorphic levels and > 0 for monomorphic / global levels. + It is = 0 for the bottom universe ("Set"). + If a universe level [l] is mapped to +∞, then [max (l, ...) >= k] is trivial + while [max (u_1, ... u_n)... >= l] is absurd (unless one of u_1 ... u_n is + mapped to +∞ as well). *) Record valuation := { valuation_mono : string -> positive ; valuation_poly : nat -> nat }. Class Evaluable (A : Type) := val : valuation -> A -> nat. +Record valuation_inf := + { valuation_inf_mono : string -> option positive ; + valuation_inf_poly : nat -> option nat }. + +Class EvaluableInf (A : Type) := val_inf : valuation_inf -> A -> option nat. (** Levels are Set or Level or lvar *) Module Level. @@ -63,6 +72,12 @@ Module Level. | lvar x => (v.(valuation_poly) x) end. + Global Instance EvaluableInf : EvaluableInf t + := fun v l => match l with + | lzero => Some 0%nat + | level s => (option_map Pos.to_nat (v.(valuation_inf_mono) s)) + | lvar x => (v.(valuation_inf_poly) x) + end. Definition compare (l1 l2 : t) : comparison := match l1, l2 with @@ -258,6 +273,9 @@ Module LevelExpr. Global Instance Evaluable : Evaluable t := fun v l => (snd l + val v (fst l)). + Global Instance EvaluableInf : EvaluableInf t + := fun v l => option_map (Nat.add (snd l)) (val_inf v (fst l)). + Definition succ (l : t) : t := (fst l, S (snd l)). Definition add (k : nat) (l : t) : t := (fst l, k + snd l). @@ -428,6 +446,11 @@ Module Universe. let '(e, u) := exprs u in List.fold_left (fun n e => Nat.max (val v e) n) u (val v e). + Global Instance EvaluableInf : EvaluableInf t + := fun v u => + let '(e, u) := exprs u in + List.fold_left (fun n e => option_map2 Nat.max (val_inf v e) n) u (val_inf v e). + (** Test if the universe is a lub of levels or contains +n's. *) Definition is_levels (u : t) : bool := LevelExprSet.for_all LevelExpr.is_level u. diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index 585558f12..2334b0156 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -53,7 +53,7 @@ Proof. - move/enforce_constraints_spec: ec => [] eql eqc. have hs := declare_levels_spec g uctx.1. rewrite Heq in hs. move: hs => [] hndecl hdecll hdeclc. - rewrite /levels in eql. rewrite -eql in hdecll. split => //. + rewrite -eql in hdecll. split => //. now rewrite eqc hdeclc. - move/enforce_constraints_None: ec. have := declare_levels_spec g uctx.1. @@ -217,11 +217,32 @@ Section CheckLeq. exact p. Qed. - Lemma posv v : LoopCheck.Impl.CorrectModel.positive_valuation (valuation_to_Z v). + Definition to_opt_val (v : Level.t -> Z) : Level.t -> option Z := + fun l => Some (v l). + + Lemma posv v : LoopCheck.Impl.I.Model.Model.positive_opt_valuation (to_opt_val (valuation_to_Z v)). Proof. - red. intros l k. unfold valuation_to_Z. intros [= <-]. lia. + red. intros l. unfold valuation_to_Z, to_opt_val. intros k [=]. lia. Qed. + Lemma interp_univ_cstr_to_opt_val v c : + interp_univ_cstr (to_opt_val v) c <-> interp_univ_cstr v c. + Proof. + destruct c as [[l []] r]; cbn -[SemiLattice.Semilattice.eq]. + Admitted. + + Lemma interp_univ_cstrs_to_opt_val v c : + interp_univ_cstrs (to_opt_val v) c <-> interp_univ_cstrs v c. + Proof. + Admitted. + + Import C (clauses_sem). + + Lemma clauses_sem_to_opt_val v c : + clauses_sem (to_opt_val v) c <-> clauses_sem v c. + Proof. + Admitted. + Lemma checkb_spec : check_spec checkb. Proof. intros c decl. @@ -232,8 +253,11 @@ Section CheckLeq. apply clauses_sem_satisfies0_equiv. red in mc. setoid_rewrite interp_cstrs_clauses_sem in mc. - specialize (mc (valuation_to_Z v)). - eapply interp_cstr_clauses_sem. apply mc. apply posv. + specialize (mc (to_opt_val (valuation_to_Z v))). + eapply interp_cstr_clauses_sem. + forward mc. apply posv. + rewrite -interp_univ_cstr_to_opt_val. apply mc. + rewrite clauses_sem_to_opt_val. apply satisfies_clauses_sem_to_Z. destruct HG as [hlev hcstrs]. rewrite hcstrs. eapply satisfies_union. split => //. @@ -241,6 +265,8 @@ Section CheckLeq. - rewrite check_completeness. intros hv. red in hv. destruct HG as [hlev hcstrs]. + intros v vpos cs. + Print valuation. red. rewrite valid_Z_pos_nat_model => v. rewrite hcstrs. diff --git a/template-rocq/theories/Junk.v b/template-rocq/theories/Junk.v index 90c103b83..2ce401cd1 100644 --- a/template-rocq/theories/Junk.v +++ b/template-rocq/theories/Junk.v @@ -1342,3 +1342,380 @@ Qed. *) Instance semilattice_CommMonoid {Q} (s : semilattice Q) : IsCommMonoid Q := comm_monoid s. Instance semilattice_Semilattice {Q} (s : semilattice Q) : @Semilattice (carrier s) Q (comm_monoid s) := sl s. + + + +Inductive simplified cls : Clause.t -> Prop := +| simpl_incl cl : cls cl -> simplified cls cl +| simpl_below {cl prems concl prems' k k'} : + simplified cls cl -> + cls (prems, (concl, k)) -> + (concl, k') ∈ prems -> + k' < k -> + remove_prem_opt (concl, k') prems = Some prems' -> + simplified cls (prems', (concl, k)). + +(* +Inductive simplified cls : Clauses.t -> Prop := +| simpl_below {cls' prems concl prems' k k'} : + simplified cls cls' -> + max_chain cls (prems, (concl, k)) -> + (concl, k') ∈ prems -> + k' < k -> + remove_prem_opt (concl, k') prems = Some prems' -> + Clauses.In (prems', (concl, k)) cls' -> + simplified cls cls'. *) + + + +(* Inductive simplified cls : Clause.t -> Prop := +| simpl_incl cl : entails cls cl -> simplified cls cl +| simpl_below {prems concl prems' k k'} : + simplified cls (prems, (concl, k)) -> + (concl, k') ∈ prems -> + k' < k -> + remove_prem_opt (concl, k') prems = Some prems' -> + simplified cls (prems', (concl, k)). *) + +Inductive simplified cls : Clauses.t -> Prop := +| simpl_incl cls' : entails_clauses cls' cls -> simplified cls cls' +| simpl_below {cls' prems concl prems' k k'} : + simplified cls cls' -> + cls' ⊢ prems → (concl, k) -> + (concl, k') ∈ prems -> + k' < k -> + remove_prem_opt (concl, k') prems = Some prems' -> + simplified cls (Clauses.add (prems', (concl, k)) cls'). + +Definition con_cls cls := ~ exists u, entails_all cls u (succ u). + +Lemma eq_inj concl le (prems : NES.t) : + ~ le ∈ prems -> + NES.add concl (singleton le) = union (singleton le) prems -> + prems = singleton concl. +Proof. + move=> hnin /equal_exprsets eq. + apply equal_exprsets => l. + rewrite LevelExprSet.singleton_spec /LevelExprSet.E.eq. + split. + - intros inp. + specialize (eq l). + have hneq : l <> le. + { intros ->. contradiction. } + destruct eq as [eq eq']. + forward eq'. rewrite LevelExprSet.union_spec. now right. + eapply LevelExprSet.add_spec in eq' as [eq'|eq']; auto. + eapply LevelExprSet.singleton_spec in eq'. contradiction. + - intros ->. + have hneq : concl <> le. + { intros ->. + have eqs : NES.add le (singleton le) = singleton le. + apply equal_exprsets. intros l. + rewrite LevelExprSet.add_spec. firstorder. red in H; subst l. + now apply LevelExprSet.singleton_spec. + rewrite eqs in eq. + specialize (eq (choose prems)). + destruct eq. forward H0. + apply LevelExprSet.union_spec. right; apply choose_spec. + eapply LevelExprSet.singleton_spec in H0. + red in H0; subst le. + apply hnin. apply choose_spec. } + specialize (eq concl). + destruct eq. + forward H. apply NES.add_spec. now left. + apply LevelExprSet.union_spec in H as [H|H] => //. + apply LevelExprSet.singleton_spec in H. red in H; subst. + congruence. +Qed. + +Definition simple_clauses cls cl := + let '(prems, (concl, k)) := cl in + ~ exists k', k' < k /\ (concl, k') ∈ prems /\ entails cls cl. + +(* Enforce x ∨ y + k' -> z + k. + If satisfiable, check for each premise if (m[l] - k') + k > m[concl] + if not, i.e. m[y] - k' + k > m[z] then remove the premise y + k'. + + Then the new clauses have the same model and entail the previous one. + For Z models they are equivalent. + *) + +Lemma simplified_entails cls cls' : + simplified cls cls' -> + forall cl, entails cls cl -> entails cls' cl. +Proof. + induction 1. + - intros cl. red in H. specialize (H cl). +Admitted. +Lemma con_cls_entails cls cl : + con_cls cls -> + entails cls cl -> + forall k', ((concl cl).1, k') ∈ premise cl -> + k' < (concl cl).2 -> + exists cls' prem', + remove_prem_opt ((concl cl).1, k') (premise cl) = Some prem' /\ + simplified cls cls' /\ + entails cls' (prem', concl cl). +Proof. + intros hcon. + induction 1. + - intros k' hin hlt. + destruct concl0 as [concl k]. + cbn -[lt remove_prem_opt] in *. + destruct remove_prem_opt eqn:hr. + * eapply remove_prem_opt_Some_eq in hr as [hr hneq]=> //. + subst prems. + exists cls. + eexists; split; trea. + eapply LevelExprSet.union_spec in H as [H|H]. + { apply LevelExprSet.singleton_spec in H. noconf H. cbn in hlt. lia. } + split. + { constructor. eapply entails_clauses_tauto. } + now constructor. + * eapply remove_prem_opt_None in hr. + apply hr in hin. subst prems. + eapply LevelExprSet.singleton_spec in H; noconf H. + cbn in hlt. lia. + - destruct concl0 as [concl k]. + cbn -[lt remove_prem_opt] in *. + intros k' hin hlt. + move: (IHentails k') => /fwd. + { eapply LevelExprSet.add_spec. now right. } + move/(_ hlt) => -[cls' [prem' [hr [hsimp hent]]]]. + eapply remove_prem_opt_Some_eq in hr as [hr hnin]. + rewrite hr in H0. + destruct (remove_prem_opt (concl, k') prems) eqn:hr'; revgoals. + * eapply remove_prem_opt_None in hr'. + eapply hr' in hin. subst prems. + exfalso. + apply eq_inj in hr. subst prem'. + apply subset_singleton in H1. subst prems'. + clear hr'. + eapply entails_cumul_one in H0. + 2:{ eapply in_pred_closure_entails_clause in H. now eapply entails_all_singleton. } + elim hcon; exists (singleton (concl, k')). + rewrite add_prems_singleton. + eapply entails_all_trans. + eapply entails_all_singleton; tea. + eapply entails_all_singleton; tea. + eapply entails_lower. exists k. split => //. + now eapply LevelExprSet.singleton_spec. + cbn in *. lia. exact hnin. + * destruct (LevelExprSet.mem (concl, k') prems') eqn:hm. + eapply LevelExprSet.mem_spec in hm. + destruct (remove_prem_opt (concl, k') prems') eqn:hr2. + { exists (Clauses.add (t1, concl') cls'). exists t0. split => //. + split => //. + { constructor. admit. } + have he : prem' = NES.add concl' t0. + admit. subst prem'. + eapply (entails_cumul_one (prems' := singleton concl')). + eapply entails_all_singleton. + have hinc : t1 ⊂_leset t0. admit. + eapply entails_subset; tea. eapply entails_in. + eapply Clauses.add_spec. now left. + eapply entails_clauses_subset. + rewrite union_add_singleton. exact hent. clsets. } + eapply remove_prem_opt_None in hr2. + apply hr2 in hm. subst prems'. + destruct (Classes.eq_dec concl' (concl, k')). subst. + exists cls', t0. split => //. split => //. + have eq : prem' = t0. admit. subst t0. exact hent. + exists (Clauses.add (t0, (concl, k)) cls'), t0. split => //. split => //. admit. + eapply entails_in. eapply Clauses.add_spec. now left. + Admitted. + +Lemma simplified_entails cls cl : + con_cls cls -> + simplified cls cl -> entails cls cl. +Proof. + intros con. induction 1. + - now eapply entails_in. + - eapply remove_prem_opt_Some_eq in H2. + subst prems. + + eapply (entails_cumul_one (prems' := singleton (concl0, k'))); revgoals. + + + now rewrite -NES.union_add_singleton in IHsimplified. + + { rewrite union_opt_union union_remove //. now eapply entails_weak_union. } + eapply (entails_shift (k' - k)) in IHmax_chain1. + cbn in IHmax_chain1. + have heq: k' - k + k = k' by lia. + rewrite heq in IHmax_chain1. + eapply entails_all_singleton. + now eapply entails_weak_union_opt. +Qed. + +Lemma strictly_updates_strengthen V m m' : + strictly_updates (clauses m) V (model m) m' -> + is_model m' (clauses m) -> + is_model m' (thin_clauses m). +Proof. + intros su. + remember (model m) as model. + remember (clauses m) as cls. + revert m Heqcls Heqmodel. + induction su. + - destruct cl as [prems [concl k]]. + destruct H1 as [vmin [hmin nabove eqm]]. + move/negPf: nabove => /[dup]. + move/update_model_not_above => ext /level_value_not_above_spec. + move=> hle m0 eqcls eqm0. subst cls m. + move=> /[dup] ism' /is_modelP /(_ (prems, (concl, k))) /fwd // /valid_clause_elim hz. + have [hf [[minp minl] [hin heq]]] := min_premise_spec_aux _ _ _ hmin. + destruct (Classes.eq_dec minp concl). + * (* Minimial premise is the conclusion *) + subst minp. + unfold min_atom_value in heq. + destruct (level_value _ concl) eqn:hl => //. + noconf heq. depelim hle. + (* We are updating the conclusion by k - minl > 0 *) + have hk : k - minl > 0 by lia. + have hpres := min_premise_pres prems ext. + rewrite hmin in hpres. + depelim hpres. + specialize (hz y). + rewrite eqm in hz. specialize (hz H3). + rewrite level_value_add in hz. depelim hz. + have [hf' hex'] := min_premise_spec_aux _ _ _ H3. + specialize (hf' _ hin). + rewrite /min_atom_value level_value_add in hf'. + depelim hf'. cbn in *. + destruct hex' as [[minp' minl'] [hin' heq']]. + have hz : z <= y + minl by lia. + have hz' : y + minl <= k + (z - minl) by lia. + destruct (Classes.eq_dec minp' concl). + { subst minp'. rewrite /min_atom_value level_value_add in heq'. noconf heq'. + have hm : minl' = minl. + apply antisymmetry. 2:lia. + have ha := hf _ hin. + have hb := hf _ hin'. + apply level_value_MapsTo' in hl. + rewrite !(Model.min_atom_value_mapsto hl) in ha, hb. + cbn in ha, hb. depelim hb. lia. lia. + } + have hne : exists le', (concl, minl) <> le' /\ LevelExprSet.In le' prems. + { exists (minp', minl'). split => //. intros [=]. congruence. } + set premsd := remove_prem (concl, minl) prems hne. + apply/is_modelP => cl /thin_clauses_spec_inv. + move=> -[cl0 [heqo hino]]. + have hs := thin_clause_opt_spec m0 cl0. + rewrite heqo in hs. + destruct hs as [premsnl [premsl [eq eq' ent nent]]]. + subst cl. + Search thin_clauses. + + + exists (Clauses.add (premsd, (concl, k)) cls). + split; [|split]. + { (* Weakening *) todo "weaking of entails H". } + { rewrite ClausesProp.add_union_singleton. eapply is_model_union => //. + eapply is_model_singleton. + eapply valid_clause_intro. setoid_rewrite eqm. + intros z' hz''. + eapply (min_premise_remove (hne := hne)) in H3; tea. + rewrite H3 in hz''. noconf hz''. + rewrite level_value_add. constructor. lia. + intros h'; noconf h'. congruence. } + red. + intros prems' concl' k0 k' ent hlt. + admit. + * +Qed. + + +Lemma strengthen_model m cls : + is_total_model m cls -> + exists cls', cls' ⊢ℋ cls /\ is_total_model m cls' /\ normalized cls'. +Proof. + intros ism. + +Qed. + + +(* + Suppose we have an entailment comming from strict updates which gaves us a model of: + + cls |- l + k' ∨ prems -> l + k + + Then we can remove l + k' from all premises in cls. + + If a clause mentionned l + k' in its premise and it was the minimal premise either + we found a loop or the minimal premise is another universe so the clause without the + l + k' premise is valid. + +*) + + +Definition normalized cls := + forall prems concl k k', + entails cls (NES.add (concl, k') prems, (concl, k)) -> + k' < k -> + entails cls (prems, (concl, k)). + +#[local] Obligation Tactic := idtac. +#[program] Definition remove_prem le (e : NES.t) (hne : exists le', le <> le' /\ LevelExprSet.In le' e) := + {| t_set := LevelExprSet.remove le e; + t_ne := _ |}. +Next Obligation with idtac. + intros le e [le' [diff hin]]. + rewrite -not_Empty_is_empty => /(_ le'); apply. + apply LevelExprSet.remove_spec. split => //. congruence. +Qed. + +Lemma remove_prem_spec le e hne le' : + LevelExprSet.In le' (remove_prem le e hne) <-> + LevelExprSet.In le' e /\ le <> le'. +Proof. Admitted. + +Lemma remove_prem_singleton le le' hne : + remove_prem le (singleton le') hne = singleton le'. +Proof. + apply equal_exprsets. + intros lk. + rewrite LevelExprSet.singleton_spec. + split. + - move/remove_prem_spec => -[/LevelExprSet.singleton_spec hdiff]. + red in hdiff; subst lk. reflexivity. + - intros ->. apply/remove_prem_spec. + destruct hne as [? [hd hs]]. + eapply LevelExprSet.singleton_spec in hs. red in hs; subst. + split => //. now apply singleton_spec. +Qed. + +Lemma remove_prem_add le le' prems hne hne' : + le <> le' -> + remove_prem le (NES.add le' prems) hne = NES.add le' (remove_prem le prems hne'). +Proof. + intros hdiff. apply equal_exprsets. + intros lk. + rewrite !remove_prem_spec !add_spec remove_prem_spec. + firstorder. subst. + eapply LevelExprSet.add_spec in H0 as [heq|hin] => //. +Qed. + +Lemma min_premise_remove {m le prems hne minv minp mink} : + min_premise m prems = Some minv -> + Some minv = min_atom_value m (minp, mink) -> + LevelExprSet.In (minp, mink) prems -> + le <> (minp, mink) -> + min_premise m (remove_prem le prems hne) = Some minv. +Proof. + move=> hmin mineq hin hdiff. + have [hf [[minp' minl] [heq hin']]] := min_premise_spec m (remove_prem le prems hne). + rewrite hin'. + eapply remove_prem_spec in heq as [hinr hdiff']. + enough (min_atom_value m (minp', minl) = min_atom_value m (minp, mink)). + noconf H. congruence. + apply antisymmetry. + * rewrite -mineq. + specialize (hf (minp, mink)). forward hf. + apply remove_prem_spec. split => //. + rewrite -mineq in hf. + now rewrite hin' in hf. + * have [hf' _] := min_premise_spec m prems. + specialize (hf' _ hinr). + now rewrite hmin mineq in hf'. +Qed. From 13a60f190ff5a4d0267262bb437ff9b4bf3fae2d Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 31 Oct 2025 12:14:38 +0100 Subject: [PATCH 109/164] Validity in Z is provably decided by enforcement of the inverse clause in a total model. --- common/theories/LoopChecking/Deciders.v | 424 +++++++++++++++++++++++- 1 file changed, 420 insertions(+), 4 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 2cdd07926..26596ce90 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -1225,8 +1225,7 @@ Module CorrectModel. *) Lemma enabled_clauses_union {m cls cls'} : - enabled_clauses m cls -> - enabled_clauses m cls' -> + enabled_clauses m cls /\ enabled_clauses m cls' <-> enabled_clauses m (Clauses.union cls cls'). Proof. Admitted. @@ -1303,7 +1302,7 @@ Module CorrectModel. eapply declared_pos_ext; tea. - eapply enabled_clauses_ext. have mupd := I.model_updates m. eapply is_update_of_ext in mupd. exact mupd. - eapply enabled_clauses_union => //. + rewrite -enabled_clauses_union; split => //. red in hdeclp. red in hdecla. eapply declared_pos_enabled; tea. @@ -3062,7 +3061,7 @@ Proof. now eapply valid_clause_model. intros cs. rewrite -def_clause_sem_valid //. - - intros vm v vpos csem. todo "admit". + - intros vm v vpos csem. red in vm. todo "admit". Qed. @@ -3759,6 +3758,423 @@ Proof. 2:{ rewrite (min_premise_add_prems minle); trea. } lia. Qed. +Lemma total_model m : is_total_model (model m) (clauses m). +Proof. + split. apply model_enabled. apply model_ok. +Qed. + +Lemma total_model_thin m : is_total_model (model m) (thin_clauses m). +Proof. + by eapply is_total_model_thin, total_model. +Qed. + +(* Lemma complete_thin_model m m' : + is_total_model m (thin_clauses m) -> + is_model m' (thin_clauses m) -> + exists m'', is_model (extend) *) + +Definition check_clauseZ m cl := + check_genb (thin_clauses m) cl. + +Lemma clauses_levels_thin m : clauses_levels (thin_clauses m) ⊂_lset clauses_levels (clauses m). +Proof. Admitted. + +Lemma check_gen_thin_model_looping m cl v vcls isl : + check_gen (thin_clauses m) cl = IsLooping v vcls isl -> False. +Proof. + intros. + have hm := m.(model_valid).(model_ok). + have hen := model_enabled m. + have htot : is_total_model (model m) (clauses m). + split => //. + eapply is_total_model_thin in htot. + eapply (check_valid_looping (cls := thin_clauses m)). apply htot. tea. + eapply defined_model_of_ext. eapply defined_model_of_subset. + 2:{ eapply defined_model. } + intros ? ?; eapply clauses_levels_declared. + instantiate (1 := m). now eapply clauses_levels_thin, vcls. + reflexivity. +Qed. + +Lemma checkb_thin_entails m cl : + check_genb (thin_clauses m) cl <-> entails (thin_clauses m) cl. +Proof. + unfold check_genb. + destruct (check_gen) eqn:ec. + - now move/check_gen_thin_model_looping: ec. + - split => //. + now move/check_invalid_entails: ec. + - now move/check_gen_entails: ec. +Qed. + +Lemma entails_clauses_completeness cls cls' : + cls ⊢ℋ cls' -> + valid_clauses_Z cls cls'. +Proof. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -completeness_all. + intros vr v vpos csem. + specialize (vr Z _ v). + rewrite -!interp_rels_clauses_sem in vr. + eauto. +Qed. + +Lemma entails_thin_disj m cl : + entails (thin_clauses m) cl -> + thin_clauses m ⊢ℋ inverse_clauses cl -> False. +Proof. + have ht := is_total_model_thin m m. + forward ht. split. eapply model_enabled. apply model_ok. + rewrite entails_completeness => ha. + move/entails_clauses_completeness => hz. + move: (hz (Z_valuation_of_model m)) => /fwd. + apply valuation_of_model_pos. move=> /fwd. + eapply valid_clauses_model; apply ht. + specialize (ha Z _ (Z_valuation_of_model m)). + forward ha. + eapply valid_clauses_model; apply ht. + move: ha. rewrite -neg_inverse_Z. contradiction. +Qed. + +Definition thinned_clause cls cl := + forall e, e ∈ premise cl -> ~ cls ⊢ premise cl → succ_expr e. + +Lemma nthinned_clause cls cl : ~ thinned_clause cls cl <-> + (exists e, e ∈ premise cl /\ cls ⊢ premise cl → succ_expr e). +Proof. + split. intros. + admit. intros [e [hin heent]] hf. + specialize (hf e hin). contradiction. +Admitted. + +Definition thinned_clauses cls := + forall cl, Clauses.In cl cls -> thinned_clause cls cl. + +Definition unique_prems (prems : NES.t) := + forall l k k', (l, k) ∈ prems -> (l, k') ∈ prems -> k = k'. + +Definition increasing cl := + (exists k', LevelExprSet.In ((concl cl).1, k') (premise cl)) /\ + (forall k', LevelExprSet.In ((concl cl).1, k') (premise cl) -> (k' < (concl cl).2)%Z). + +Lemma increasing_dec cl : { increasing cl } + { ~ increasing cl }. +Admitted. + +Lemma nincreasing_spec cl : (~ increasing cl) <-> + (~ exists k', LevelExprSet.In ((concl cl).1, k') (premise cl)) \/ + (exists k', LevelExprSet.In ((concl cl).1, k') (premise cl) /\ (concl cl).2 <= k')%Z. +Proof. +Admitted. + +Lemma entails_thin_dup cls prems concl : + entails cls (prems, concl) -> + forall l k k', (l, k) ∈ prems -> (l, k') ∈ prems -> k < k' -> + exists prems', remove_prem_opt (l, k) prems = Some prems' /\ + entails cls (prems', concl). +Proof. + intros ent l k k' ha hb hlt. + destruct (remove_prem_opt) eqn:rm. + - eapply remove_prem_opt_Some_eq in rm as []. subst prems. + exists t0. split => //. + eapply (entails_cumul_one (prems' := singleton (l, k))). + eapply entails_all_singleton. + move/LevelExprSet.union_spec: hb => -[]. + * move/LevelExprSet.singleton_spec => [=] eq. subst k'. cbn in hlt; lia. + * intros he. eapply entails_lower. exists k'. split => //. cbn in *; lia. + * now rewrite union_comm. + * exact ha. + - eapply remove_prem_opt_None in rm. + apply rm in ha. + cbn in ha; subst prems. + apply LevelExprSet.singleton_spec in hb. noconf hb. + cbn in hlt. lia. +Qed. +(* + Inductive entailsS (cls : Clauses.t) : clause -> Prop := + | clause_in (prems : premises) (concl : LevelExpr.t) : + LevelExprSet.In concl prems -> entailsS cls (prems, concl) + + | clause_cut prems' concl' prems concl : + in_pred_closure cls (prems', concl') -> + ~ (exists k', (concl'.1, k') ∈ prems /\ concl'.2 <= k') -> + entailsS cls (NES.add concl' prems, concl) -> + LevelExprSet.Subset prems' prems -> + entailsS cls (prems, concl). + +About entailsS_ind. + + Lemma entails_entailsS cls cl : + entailsS cls cl -> + entails cls cl. + Proof. + induction 1. + - now constructor. + - eapply Clauses.clause_cut; tea. + Qed. *) + + + +(* Print entails. *) + +Lemma entails_thinned cls : + (* thinned_clauses cls -> *) + forall cl, entails cls cl -> + (increasing cl /\ exists cl, Clauses.In cl cls /\ ~ thinned_clause cls cl) \/ + (~ increasing cl). +Proof. + intros cl. + induction 1. + - right. move=> -[[k' hin] ha]. + destruct concl0 as [concl k]. + cbn in *. + specialize (ha _ H). lia. + - cbn. + destruct IHentails. + destruct H2 as [inc nthin]. + destruct inc as [[k' hink'] hf]. + * cbn -[lt] in *. + eapply LevelExprSet.add_spec in hink' as [heq|hinc]. + red in heq; subst concl'. + destruct (increasing_dec (prems, concl0)). + now left. now right. + left. split => //. + split; cbn -[lt]. now exists k'. + intros. apply hf. apply LevelExprSet.add_spec; now right. + * apply nincreasing_spec in H2. + cbn -[lt] in *. + destruct H2. + right. move=> [h h']. apply H2. cbn in *. + destruct h as [k' ?]; exists k'; apply LevelExprSet.add_spec; now right. + destruct H2. + destruct (increasing_dec (prems, concl0)). + left. split => //. destruct H2. + apply LevelExprSet.add_spec in H2. destruct H2. + red in H2; subst concl'. + red in i. cbn in i. + Admitted. + + (** We are inferring (concl0, n + kc') from a clause (premsc, (concl0, kc')) + in cls where premsc + n ⊂ prems and prems has all it concl0 atoms smaller + than kc'. If the premsc contains concl0 it cannot be thinned. + Otherwise it might be introducing concl0, n + kc', e.g. + + x -> (concl0, kc') allows to prove x -> (concl0, kc). + + *) + + +Lemma thin_clauses_levels m : clauses_levels (thin_clauses m) ⊂_lset clauses_levels (clauses m). +Proof. Admitted. + +Lemma entails_dec_thin (m : t) cl : + { entails (thin_clauses m) cl } + { ~ entails (thin_clauses m) cl }. +Proof. + destruct (check_gen (thin_clauses m) cl) eqn:ch. + - move/check_looping: ch; elim. + exists (model_of m). split. + { have dm := defined_model m. + eapply defined_model_of_subset; tea. + eapply defined_model_of_subset; tea. + intros ?; rewrite -clauses_levels_declared. + apply thin_clauses_levels. } + apply total_model_thin. + - move/check_invalid_entails: ch. intros ne. now right. + - move/check_gen_entails: ch. now left. +Qed. + +(** If a clause cl is not entailed then its inverse must be consistent. *) +Lemma nentails_thin_con m cl : + ~ entails (thin_clauses m) cl -> + (exists l, Clauses.union (thin_clauses m) (inverse_clauses cl) ⊢ℋ (succ l ⋞ l)%cls) -> False. +Proof. + intros _ hl. + set (cl' := (singleton (concl cl), succ_expr (concl cl))). + destruct (entails_dec_thin m cl'). + { eapply entails_completeness in e. + specialize (e Z _ (Z_valuation_of_model m)). + forward e. apply valid_clauses_model; + apply total_model_thin. + destruct cl as [prems [concl k]]; cbn in e. rewrite /interp_expr in e. + rewrite interp_nes_singleton //= in e. lia. } + { destruct hl as [l hl]. + unfold inverse_clauses in hl. + destruct cl as [prems concl]. cbn in cl'. + admit. } +Admitted. + +Lemma total_model_sem {m cls} : + is_total_model m cls -> + clauses_sem (Z_valuation_of_model m) cls. +Proof. + intros [en ism]. + now eapply valid_clauses_model. +Qed. + +Lemma inverse_clauses_levels {m cl} : + clause_levels cl ⊂_lset levels m -> + clauses_levels (inverse_clauses cl) ⊂_lset levels m. +Proof. + intros hs. now rewrite clause_levels_inverse. +Qed. + +Search inverse_clauses. +Equations check_clause_enf m cl (wf : clause_levels cl ⊂_lset levels m) : bool := + check_clause_enf m cl wf with enforce_dec m (inverse_clauses cl) (inverse_clauses_levels wf) := + | left con => false + | right incon => true. +Print inverse_clauses. +Lemma check_clause_enf_invalid m cl wf : + check_clause_enf m cl wf = false -> ~ valid_clause_Z (clauses m) cl. +Proof. + unfold check_clause_enf. + destruct (enforce_dec m (inverse_clauses cl)) => //= _. + intros inv. destruct c as [v [vpos csem]]. + specialize (inv v vpos). + apply clauses_sem_union in csem as [csem clsem]. + apply inv in csem. + apply neg_inverse_Z in clsem. contradiction. +Qed. + +Lemma is_model_union m cls cls' : + is_model m (Clauses.union cls cls') <-> + is_model m cls /\ is_model m cls'. +Proof. + unfold is_model. + split. + - move/Clauses.for_all_spec => hf. split; apply Clauses.for_all_spec; tc. + all:move=> cl hin; move: (hf cl) => /fwd //; clsets. + - move=> -[] /Clauses.for_all_spec ha /Clauses.for_all_spec hb. + apply Clauses.for_all_spec; tc => cl /Clauses.union_spec. + firstorder. +Qed. + +Lemma is_total_model_union m cls cls' : + is_total_model m (Clauses.union cls cls') <-> + is_total_model m cls /\ is_total_model m cls'. +Proof. + unfold is_total_model. + rewrite -enabled_clauses_union is_model_union. + firstorder. +Qed. + +Lemma ntot_forall {m cl} : + (~ exists m' : Model.model, + is_total_model m' (Clauses.union (clauses m) (inverse_clauses cl))) -> + forall m' : Model.model, + is_total_model m' (clauses m) -> + enabled_clauses m' (inverse_clauses cl) -> + ~ valid_clauses m' (inverse_clauses cl). +Proof. + intros ne m' ist en hv. + apply ne. exists m'. apply is_total_model_union. split => //. + split => //. + now eapply is_modelP. +Qed. + +Lemma check_clause_enf_valid m cl wf : + check_clause_enf m cl wf -> valid_clause_Z (clauses m) cl. +Proof. + unfold check_clause_enf. + destruct (enforce_dec m (inverse_clauses cl)) => //= _ v vpos csem. + red in i. destruct i as [loop [hincl hloop]]. + have nev : ~ exists v, positive_valuation v /\ clauses_sem v (Clauses.union (clauses m) (inverse_clauses cl)). + { intros [vz [hpos hv]]. + eapply entails_clauses_completeness in hloop. + move: (hloop vz) => /fwd //. + move/(_ hv). + move/clauses_sem_clauses_of_le; rewrite interp_add_prems. cbn. lia. } + destruct (clause_sem_Z_dec v cl) => //. + apply neg_inverse_Z in H. + elim nev. exists v. split => //. + apply clauses_sem_union. split => //. +Qed. + +Lemma check_clause_enf_spec m cl wf : + check_clause_enf m cl wf <-> valid_clause_Z (clauses m) cl. +Proof. + destruct (check_clause_enf m cl) eqn:ec. + - split => // _. + now apply check_clause_enf_valid in ec. + - split => // hv. + apply check_clause_enf_invalid in ec. + contradiction. +Qed. + +Lemma check_clauseZ_invalid m cl : + check_clauseZ m cl = false -> ~ valid_clause_Z (thin_clauses m) cl. +Proof. + unfold check_clauseZ => ec inv. + move/negP: ec. + unfold check_genb. + destruct check_gen eqn:ec => //. + now eapply check_gen_thin_model_looping in ec. + intros _. + move: ec => /[dup]/check_invalid_entails ne. + move/check_invalid => [ism mof hmin en inva]. + have tm := total_model_thin m. + specialize (hmin (model m)). + (* specialize (inv (Z_valuation_of_model m0)). forward inv. admit. *) + destruct (enforce_dec m (inverse_clauses cl)). + * admit. + * red in c. admit. + * red in i. red in i. + destruct i as [loop [hincl hloop]]. + have hloop' : Clauses.union (thin_clauses m) (inverse_clauses cl) ⊢ℋ succ loop ⋞ loop. + eapply entails_clauses_trans; tea. admit. + have nem : ~ exists m', is_total_model m' (Clauses.union (thin_clauses m) (inverse_clauses cl)). + intros [m' istm]. + eapply entails_clauses_completeness in hloop'. + red in hloop'. + move: (hloop' (Z_valuation_of_model m')) => /fwd. + apply valuation_of_model_pos. + move/(_ (total_model_sem istm)). + move/clauses_sem_clauses_of_le; rewrite interp_add_prems. cbn. lia. + apply valid_total_models_Z_models in inv. + red in inv. + Search clauses_sem. + + + + + clear hloop. + eapply nentails_thin_con in ne => //. + now exists loop. +Qed. + +Lemma check_clauseZ_valid m cl : + check_clauseZ m cl <-> valid_clause_Z (thin_clauses m) cl. +Proof. + rewrite /check_clauseZ. + split. + - move/checkb_thin_entails => ent. + eapply entails_completeness in ent. + move=> v posv csem. + specialize (ent Z _ v csem). + exact ent. + - intros valid. + rewrite valid_total_models_Z_models in valid. + red in valid. + specialize (valid (model m)). + forward valid. apply is_total_model_thin. + split. apply (model_enabled m). + apply m.(model_valid).(model_ok). + forward valid. admit. + unfold check_genb. + destruct check_gen eqn:ec => //. + now eapply check_gen_thin_model_looping in ec. + have inv : is_model m0 (inverse_clauses cl). admit. + eapply check_invalid in ec. + destruct ec. + red in H1. specialize (H1 (model m)). + forward H1. admit. forward H1. admit. + specialize (valid (Z_valuation_of_model m)). + eapply entails_completeness. + intros v. + Search entails. + destruct (entails_dec (thin_clauses )) + + Lemma check_clause_valid_Z m cl : check_clause m cl -> valid_clause_Z (clauses m) cl. Proof. From 06ea4a7a69a08fefe8d80e67cfe465313b290df9 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 31 Oct 2025 12:22:48 +0100 Subject: [PATCH 110/164] Fill admitted proofs. --- common/theories/LoopChecking/Deciders.v | 144 +++++++----------------- 1 file changed, 42 insertions(+), 102 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 26596ce90..1f54419b3 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -1224,10 +1224,46 @@ Module CorrectModel. *) + Lemma clauses_For_all_union f cls cls' : + Clauses.For_all f (Clauses.union cls cls') <-> + Clauses.For_all f cls /\ Clauses.For_all f cls'. + Proof. + split. + - move=> hf. split. + all:move=> cl hin; move: (hf cl) => /fwd //; clsets. + - move=> -[] ha hb cl /Clauses.union_spec. + firstorder. + Qed. + + Lemma clauses_for_all_union f cls cls' : + Clauses.for_all f (Clauses.union cls cls') <-> + Clauses.for_all f cls /\ Clauses.for_all f cls'. + Proof. + rewrite ![is_true _]Clauses.for_all_spec. + apply clauses_For_all_union. + Qed. + Lemma enabled_clauses_union {m cls cls'} : - enabled_clauses m cls /\ enabled_clauses m cls' <-> - enabled_clauses m (Clauses.union cls cls'). - Proof. Admitted. + enabled_clauses m (Clauses.union cls cls') <-> + enabled_clauses m cls /\ enabled_clauses m cls'. + Proof. + unfold enabled_clauses. now apply clauses_For_all_union. + Qed. + + Lemma is_model_union m cls cls' : + is_model m (Clauses.union cls cls') <-> is_model m cls /\ is_model m cls'. + Proof. + unfold is_model. now rewrite clauses_for_all_union. + Qed. + + Lemma is_total_model_union m cls cls' : + is_total_model m (Clauses.union cls cls') <-> + is_total_model m cls /\ is_total_model m cls'. + Proof. + unfold is_total_model. + rewrite enabled_clauses_union is_model_union. + firstorder. + Qed. Lemma declared_pos_enabled {m V cls} : clauses_levels cls ⊂_lset V -> @@ -1302,7 +1338,7 @@ Module CorrectModel. eapply declared_pos_ext; tea. - eapply enabled_clauses_ext. have mupd := I.model_updates m. eapply is_update_of_ext in mupd. exact mupd. - rewrite -enabled_clauses_union; split => //. + rewrite enabled_clauses_union; split => //. red in hdeclp. red in hdecla. eapply declared_pos_enabled; tea. @@ -1816,6 +1852,7 @@ Module Abstract. + right; lsets. * apply LevelSetFact.not_mem_iff in hneq. rewrite ClausesProp.add_union_singleton is_model_union //. + split => //. rewrite is_model_valid. intros cl; rsets. subst cl. rewrite /init_clause_of_level. @@ -4018,12 +4055,11 @@ Proof. intros hs. now rewrite clause_levels_inverse. Qed. -Search inverse_clauses. Equations check_clause_enf m cl (wf : clause_levels cl ⊂_lset levels m) : bool := check_clause_enf m cl wf with enforce_dec m (inverse_clauses cl) (inverse_clauses_levels wf) := | left con => false | right incon => true. -Print inverse_clauses. + Lemma check_clause_enf_invalid m cl wf : check_clause_enf m cl wf = false -> ~ valid_clause_Z (clauses m) cl. Proof. @@ -4036,28 +4072,6 @@ Proof. apply neg_inverse_Z in clsem. contradiction. Qed. -Lemma is_model_union m cls cls' : - is_model m (Clauses.union cls cls') <-> - is_model m cls /\ is_model m cls'. -Proof. - unfold is_model. - split. - - move/Clauses.for_all_spec => hf. split; apply Clauses.for_all_spec; tc. - all:move=> cl hin; move: (hf cl) => /fwd //; clsets. - - move=> -[] /Clauses.for_all_spec ha /Clauses.for_all_spec hb. - apply Clauses.for_all_spec; tc => cl /Clauses.union_spec. - firstorder. -Qed. - -Lemma is_total_model_union m cls cls' : - is_total_model m (Clauses.union cls cls') <-> - is_total_model m cls /\ is_total_model m cls'. -Proof. - unfold is_total_model. - rewrite -enabled_clauses_union is_model_union. - firstorder. -Qed. - Lemma ntot_forall {m cl} : (~ exists m' : Model.model, is_total_model m' (Clauses.union (clauses m) (inverse_clauses cl))) -> @@ -4101,80 +4115,6 @@ Proof. contradiction. Qed. -Lemma check_clauseZ_invalid m cl : - check_clauseZ m cl = false -> ~ valid_clause_Z (thin_clauses m) cl. -Proof. - unfold check_clauseZ => ec inv. - move/negP: ec. - unfold check_genb. - destruct check_gen eqn:ec => //. - now eapply check_gen_thin_model_looping in ec. - intros _. - move: ec => /[dup]/check_invalid_entails ne. - move/check_invalid => [ism mof hmin en inva]. - have tm := total_model_thin m. - specialize (hmin (model m)). - (* specialize (inv (Z_valuation_of_model m0)). forward inv. admit. *) - destruct (enforce_dec m (inverse_clauses cl)). - * admit. - * red in c. admit. - * red in i. red in i. - destruct i as [loop [hincl hloop]]. - have hloop' : Clauses.union (thin_clauses m) (inverse_clauses cl) ⊢ℋ succ loop ⋞ loop. - eapply entails_clauses_trans; tea. admit. - have nem : ~ exists m', is_total_model m' (Clauses.union (thin_clauses m) (inverse_clauses cl)). - intros [m' istm]. - eapply entails_clauses_completeness in hloop'. - red in hloop'. - move: (hloop' (Z_valuation_of_model m')) => /fwd. - apply valuation_of_model_pos. - move/(_ (total_model_sem istm)). - move/clauses_sem_clauses_of_le; rewrite interp_add_prems. cbn. lia. - apply valid_total_models_Z_models in inv. - red in inv. - Search clauses_sem. - - - - - clear hloop. - eapply nentails_thin_con in ne => //. - now exists loop. -Qed. - -Lemma check_clauseZ_valid m cl : - check_clauseZ m cl <-> valid_clause_Z (thin_clauses m) cl. -Proof. - rewrite /check_clauseZ. - split. - - move/checkb_thin_entails => ent. - eapply entails_completeness in ent. - move=> v posv csem. - specialize (ent Z _ v csem). - exact ent. - - intros valid. - rewrite valid_total_models_Z_models in valid. - red in valid. - specialize (valid (model m)). - forward valid. apply is_total_model_thin. - split. apply (model_enabled m). - apply m.(model_valid).(model_ok). - forward valid. admit. - unfold check_genb. - destruct check_gen eqn:ec => //. - now eapply check_gen_thin_model_looping in ec. - have inv : is_model m0 (inverse_clauses cl). admit. - eapply check_invalid in ec. - destruct ec. - red in H1. specialize (H1 (model m)). - forward H1. admit. forward H1. admit. - specialize (valid (Z_valuation_of_model m)). - eapply entails_completeness. - intros v. - Search entails. - destruct (entails_dec (thin_clauses )) - - Lemma check_clause_valid_Z m cl : check_clause m cl -> valid_clause_Z (clauses m) cl. Proof. From 581adf644d5b0ea29e3b855cdc96a0fe8151a634 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 31 Oct 2025 12:24:00 +0100 Subject: [PATCH 111/164] Remove some unused proofs from Deciders: TODO cleanup Deciders more --- common/theories/LoopChecking/Deciders.v | 203 ------------------------ template-rocq/theories/Junk.v | 183 +++++++++++++++++++++ 2 files changed, 183 insertions(+), 203 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 1f54419b3..ce3584f25 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -503,214 +503,11 @@ Proof. rewrite levelset_not_Empty_is_empty. intros he; specialize (he x). lsets. Qed. -Lemma strictly_updates_update cls W m m' : - strictly_updates cls W m m' -> - forall prems concl k minp, - Clauses.In (prems, (concl, k)) cls -> - min_premise m prems = Some minp -> - opt_le Z.lt (level_value m concl) (Some (k + minp)) -> - (Some (k + minp) ≤ level_value m' concl)%opt -> - updates cls m (LevelMap.add concl (Some (k + minp)) m) /\ - updates cls (LevelMap.add concl (Some (k + minp)) m) m'. -Proof. - move: W m m'. apply: strictly_updates_elim. - - intros l l' h ? ? x ? ? y. subst x0 x1. - unfold updates, is_update_of. - reflexivity. - - intros m [prems [concl k]] m' hin su prems' concl' k' minp hin' eqminp lt le'. - destruct su as [z [minp' nabove]]. - move/not_value_above: nabove => nabove. - cbn. - destruct (Classes.eq_dec concl concl'). - { (* Updates the same level *) - subst concl'. - (* have eql : LevelSet.add concl (LevelSet.singleton concl) =_lset LevelSet.singleton concl. *) - (* { rsets. lsets. } *) - (* rewrite eql. *) - rewrite H. rewrite H in le'. - rewrite level_value_add in le'. depelim le'. - destruct (Z.eq_dec (k' + minp) (k + z))%Z. - { (* No real update *) - cbn in e; rewrite e. - split. - * exists (LevelSet.singleton concl). - rewrite /is_update_of levelset_is_empty_singleton. - apply (one_update (cl := (prems, (concl, k)))); tea. - cbn. exists z. split => //. - now apply/not_value_above. - * exists LevelSet.empty. - rewrite /is_update_of levelset_is_empty_empty. - reflexivity. } - { (* Real updates to compose *) - cbn in n. - have hlt : (k' + minp < k + z)%Z by lia. - clear n H0. split. - * exists (LevelSet.singleton concl). - rewrite /is_update_of levelset_is_empty_singleton. - eapply (one_update (cl := (prems', (concl, k')))). exact hin'. - cbn. exists minp. split => //. - now apply/not_value_above. - * exists (LevelSet.singleton concl). - rewrite /is_update_of levelset_is_empty_singleton. - eapply (one_update (cl := (prems, (concl, k)))). exact hin. - cbn. exists z. split => //. 2:{ apply/not_value_above. rewrite level_value_add. - constructor => //. } - have [hf hex] := min_premise_spec_aux _ _ _ minp'. - destruct hex as [[minpl minpk] [inmin eqmin]]. - unfold min_atom_value in eqmin. - destruct (level_value m minpl) as [minpv|] eqn:hl => //. noconf eqmin. - destruct (Classes.eq_dec minpl concl). subst minpl. - rewrite hl in lt. depelim lt. rewrite hl in nabove. depelim nabove. - have hk : (minpk < k)%Z by lia. - have hk' : (k' + minp - minpk = minpv - minpk). -Admitted. - (* rewrite min_premise_add_down - rewrite level_value_add. - - have [hf' hex'] := min_premise_spec_aux _ _ _ eqminp. - destruct hex' as [[minpl' minpk'] [inmin' eqmin']]. - unfold min_atom_value in eqmin'. - destruct (level_value m minpl') as [minpv'|] eqn:hl' => //. noconf eqmin'. - destruct (Classes.eq_dec minpl' concl). subst minpl'. - rewrite hl in hl'. noconf hl'. -Admitted.*) - (* rewrite hl in lt. depelim lt. rewrite hl in nabove. depelim nabove. - - - rewrite -eql. - rewrite -(union_idem cls). - rewrite LevelSetProp.add_union_singleton. - eapply strictly_updates_trans. - - - - - } - - - Admitted. *) -(* -Lemma strictly_updates_use_ext cls W m m' m0 : - strictly_updates cls W m m' -> - m ⩽ m0 -> - m0 ⩽ m' -> - updates cls m0 m'. -Proof. - move: W m m'. - apply: (strictly_updates_elim cls). - - intros l l' h ? ? x ? ? y. subst x0 x1. - unfold updates. reflexivity. - - destruct cl as [prems [concl k]]. - move=> m' hin [minp [hmin /not_value_above habove]]. - rewrite /updates. intros h. setoid_rewrite h. - move=> ext ext'. - have := @min_premise_pres m m0 prems ext. - rewrite hmin; move/Some_leq => -[minm0] [] minp0 hle. - exists (LevelSet.singleton concl). - rewrite /is_update_of levelset_is_empty_singleton. - - /hz /Some_leq [mfconcl] [] vmconcl leq' leq. hle. - - - eapply is_model_valid in ism. - specialize (ism _ hin). cbn in ism. - move/valid_clause_elim: ism. - intros hz. - - -Qed. -*) -Lemma minimal_above_updates_updates cls W m m' : - strictly_updates cls W m m' -> - minimal_above_updates cls m m'. -Proof. - move: W m m'. - apply: (strictly_updates_elim cls). - - intros l l' h ? ? x ? ? y. subst x0 x1. - unfold minimal_above_updates. reflexivity. - - destruct cl as [prems [concl k]]. - move=> m' hin [minp [hmin habove]]. - rewrite /minimal_above_updates. intros h. setoid_rewrite h. - move=> mf ext ism. - eapply is_model_valid in ism. - specialize (ism _ hin). cbn in ism. - move/valid_clause_elim: ism. - intros hz. - have := @min_premise_pres m mf prems (updates_ext ext). - rewrite hmin. move/Some_leq => -[minmf] [] /hz /Some_leq [mfconcl] [] vmconcl leq' leq. - destruct ext as [W ext]. - exists (LevelSet.add concl W). red. - destruct LevelSet.is_empty eqn:ise. - { exfalso. eapply LevelSet.is_empty_spec in ise. apply (ise concl). lsets. } - move/is_update_of_case: ext => -[[emp eq]|su]. - { exfalso. move: vmconcl habove. rewrite -eq. - move=> hl /not_value_above. rewrite hl => hlt. - depelim hlt. lia. } - { move/not_value_above: habove => hlt. - (* The conclusion is higher in mf. *) - todo "commutation". } - (* eapply strictly_updates_update; tea. *) - - - (* rewrite vmconcl. constructor. lia. } *) - - intros * su ma su' ma'. - intros mf extinit ism. - move: (ma mf extinit ism) => hext. - exact (ma' mf hext ism). -Qed. - -Lemma updates_extends {cls m m'} : updates cls m m' -> m ⩽ m'. -Admitted. -(* Lemma minimal_above_valid cls minit m : - minimal_above_updates cls minit m -> - updates cls minit m -> - forall cl, valid_clause m cl -> - forall m', updates cls m m' -> is_model m cls' -> valid_clause m' cl. -Proof. - intros hmin hupd [prems [concl k]]. - move/valid_clause_elim => hz m' ext ism. - unfold valid_clause. cbn. - destruct (min_premise m' prems) eqn:hminp => //. - specialize (hmin m' ext ism). - destruct (min_premise m prems) eqn:hl. - specialize (hz _ eq_refl). - have minp := min_premise_pres prems (updates_extends hmin). - rewrite hl in minp. rewrite hminp in minp. depelim minp. - depelim hz. rewrite /level_value_above. - have mle := model_le_values concl (updates_extends hmin). - rewrite H0 in mle. depelim mle. rewrite H3. apply Z.leb_le. - - specialize (min' m). - Search level_value. - Search valid_clause. *) - Definition minimal_above cls minit m := forall m', minit ⩽ m' -> is_model m' cls -> m ⩽ m'. -(* -Lemma minimal_above_valid cls minit m : minimal_above cls minit m -> - forall cl, valid_clause m cl -> forall m', minit ⩽ m' -> is_model m cls' -> - minimal_above cls minit m' -> valid_clause m' cl. -Proof. - intros hmin [prems [concl k]]. - move/valid_clause_elim => hz m' ext ism min'. - unfold valid_clause. cbn. - destruct (min_premise m' prems) eqn:hminp => //. - red in hmin. specialize (hmin _ ext ism). - destruct (min_premise m prems) eqn:hl. - specialize (hz _ eq_refl). - have minp := min_premise_pres prems hmin. - rewrite hl in minp. rewrite hminp in minp. depelim minp. - depelim hz. rewrite /level_value_above. - have mle := model_le_values concl hmin. - rewrite H0 in mle. depelim mle. rewrite H3. apply Z.leb_le. - specialize (min' m). - Search level_value. - Search valid_clause. *) - - Definition check_init_model cls cl := (premises_model (clauses_levels cls) None cl).2. diff --git a/template-rocq/theories/Junk.v b/template-rocq/theories/Junk.v index 2ce401cd1..40b4e29a6 100644 --- a/template-rocq/theories/Junk.v +++ b/template-rocq/theories/Junk.v @@ -1719,3 +1719,186 @@ Proof. specialize (hf' _ hinr). now rewrite hmin mineq in hf'. Qed. + + + +Lemma strictly_updates_update cls W m m' : + strictly_updates cls W m m' -> + forall prems concl k minp, + Clauses.In (prems, (concl, k)) cls -> + min_premise m prems = Some minp -> + opt_le Z.lt (level_value m concl) (Some (k + minp)) -> + (Some (k + minp) ≤ level_value m' concl)%opt -> + updates cls m (LevelMap.add concl (Some (k + minp)) m) /\ + updates cls (LevelMap.add concl (Some (k + minp)) m) m'. +Proof. + move: W m m'. apply: strictly_updates_elim. + - intros l l' h ? ? x ? ? y. subst x0 x1. + unfold updates, is_update_of. + reflexivity. + - intros m [prems [concl k]] m' hin su prems' concl' k' minp hin' eqminp lt le'. + destruct su as [z [minp' nabove]]. + move/not_value_above: nabove => nabove. + cbn. + destruct (Classes.eq_dec concl concl'). + { (* Updates the same level *) + subst concl'. + (* have eql : LevelSet.add concl (LevelSet.singleton concl) =_lset LevelSet.singleton concl. *) + (* { rsets. lsets. } *) + (* rewrite eql. *) + rewrite H. rewrite H in le'. + rewrite level_value_add in le'. depelim le'. + destruct (Z.eq_dec (k' + minp) (k + z))%Z. + { (* No real update *) + cbn in e; rewrite e. + split. + * exists (LevelSet.singleton concl). + rewrite /is_update_of levelset_is_empty_singleton. + apply (one_update (cl := (prems, (concl, k)))); tea. + cbn. exists z. split => //. + now apply/not_value_above. + * exists LevelSet.empty. + rewrite /is_update_of levelset_is_empty_empty. + reflexivity. } + { (* Real updates to compose *) + cbn in n. + have hlt : (k' + minp < k + z)%Z by lia. + clear n H0. split. + * exists (LevelSet.singleton concl). + rewrite /is_update_of levelset_is_empty_singleton. + eapply (one_update (cl := (prems', (concl, k')))). exact hin'. + cbn. exists minp. split => //. + now apply/not_value_above. + * exists (LevelSet.singleton concl). + rewrite /is_update_of levelset_is_empty_singleton. + eapply (one_update (cl := (prems, (concl, k)))). exact hin. + cbn. exists z. split => //. 2:{ apply/not_value_above. rewrite level_value_add. + constructor => //. } + have [hf hex] := min_premise_spec_aux _ _ _ minp'. + destruct hex as [[minpl minpk] [inmin eqmin]]. + unfold min_atom_value in eqmin. + destruct (level_value m minpl) as [minpv|] eqn:hl => //. noconf eqmin. + destruct (Classes.eq_dec minpl concl). subst minpl. + rewrite hl in lt. depelim lt. rewrite hl in nabove. depelim nabove. + have hk : (minpk < k)%Z by lia. + have hk' : (k' + minp - minpk = minpv - minpk). +Admitted. + (* rewrite min_premise_add_down + rewrite level_value_add. + + have [hf' hex'] := min_premise_spec_aux _ _ _ eqminp. + destruct hex' as [[minpl' minpk'] [inmin' eqmin']]. + unfold min_atom_value in eqmin'. + destruct (level_value m minpl') as [minpv'|] eqn:hl' => //. noconf eqmin'. + destruct (Classes.eq_dec minpl' concl). subst minpl'. + rewrite hl in hl'. noconf hl'. +Admitted.*) + (* rewrite hl in lt. depelim lt. rewrite hl in nabove. depelim nabove. + + + rewrite -eql. + rewrite -(union_idem cls). + rewrite LevelSetProp.add_union_singleton. + eapply strictly_updates_trans. + + + + + } + + + Admitted. *) +(* +Lemma strictly_updates_use_ext cls W m m' m0 : + strictly_updates cls W m m' -> + m ⩽ m0 -> + m0 ⩽ m' -> + updates cls m0 m'. +Proof. + move: W m m'. + apply: (strictly_updates_elim cls). + - intros l l' h ? ? x ? ? y. subst x0 x1. + unfold updates. reflexivity. + - destruct cl as [prems [concl k]]. + move=> m' hin [minp [hmin /not_value_above habove]]. + rewrite /updates. intros h. setoid_rewrite h. + move=> ext ext'. + have := @min_premise_pres m m0 prems ext. + rewrite hmin; move/Some_leq => -[minm0] [] minp0 hle. + exists (LevelSet.singleton concl). + rewrite /is_update_of levelset_is_empty_singleton. + + /hz /Some_leq [mfconcl] [] vmconcl leq' leq. hle. + + + eapply is_model_valid in ism. + specialize (ism _ hin). cbn in ism. + move/valid_clause_elim: ism. + intros hz. + + +Qed. +*) +Lemma minimal_above_updates_updates cls W m m' : + strictly_updates cls W m m' -> + minimal_above_updates cls m m'. +Proof. + move: W m m'. + apply: (strictly_updates_elim cls). + - intros l l' h ? ? x ? ? y. subst x0 x1. + unfold minimal_above_updates. reflexivity. + - destruct cl as [prems [concl k]]. + move=> m' hin [minp [hmin habove]]. + rewrite /minimal_above_updates. intros h. setoid_rewrite h. + move=> mf ext ism. + eapply is_model_valid in ism. + specialize (ism _ hin). cbn in ism. + move/valid_clause_elim: ism. + intros hz. + have := @min_premise_pres m mf prems (updates_ext ext). + rewrite hmin. move/Some_leq => -[minmf] [] /hz /Some_leq [mfconcl] [] vmconcl leq' leq. + destruct ext as [W ext]. + exists (LevelSet.add concl W). red. + destruct LevelSet.is_empty eqn:ise. + { exfalso. eapply LevelSet.is_empty_spec in ise. apply (ise concl). lsets. } + move/is_update_of_case: ext => -[[emp eq]|su]. + { exfalso. move: vmconcl habove. rewrite -eq. + move=> hl /not_value_above. rewrite hl => hlt. + depelim hlt. lia. } + { move/not_value_above: habove => hlt. + (* The conclusion is higher in mf. *) + todo "commutation". } + (* eapply strictly_updates_update; tea. *) + + + (* rewrite vmconcl. constructor. lia. } *) + - intros * su ma su' ma'. + intros mf extinit ism. + move: (ma mf extinit ism) => hext. + exact (ma' mf hext ism). +Qed. + +Lemma updates_extends {cls m m'} : updates cls m m' -> m ⩽ m'. +Admitted. +(* Lemma minimal_above_valid cls minit m : + minimal_above_updates cls minit m -> + updates cls minit m -> + forall cl, valid_clause m cl -> + forall m', updates cls m m' -> is_model m cls' -> valid_clause m' cl. +Proof. + intros hmin hupd [prems [concl k]]. + move/valid_clause_elim => hz m' ext ism. + unfold valid_clause. cbn. + destruct (min_premise m' prems) eqn:hminp => //. + specialize (hmin m' ext ism). + destruct (min_premise m prems) eqn:hl. + specialize (hz _ eq_refl). + have minp := min_premise_pres prems (updates_extends hmin). + rewrite hl in minp. rewrite hminp in minp. depelim minp. + depelim hz. rewrite /level_value_above. + have mle := model_le_values concl (updates_extends hmin). + rewrite H0 in mle. depelim mle. rewrite H3. apply Z.leb_le. + + specialize (min' m). + Search level_value. + Search valid_clause. *) From 10af466c0fdc183e96d9cb19ebb6da393e5e0316 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 31 Oct 2025 16:56:32 +0100 Subject: [PATCH 112/164] Cleanup deciders --- common/theories/LoopChecking/Deciders.v | 645 +----------------------- common/theories/LoopChecking/Thinning.v | 417 +++++++++++++++ template-rocq/theories/Junk.v | 186 +++++++ 3 files changed, 605 insertions(+), 643 deletions(-) create mode 100644 common/theories/LoopChecking/Thinning.v diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index ce3584f25..baa1be98f 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -504,13 +504,11 @@ Proof. Qed. -Definition minimal_above cls minit m := - forall m', minit ⩽ m' -> is_model m' cls -> m ⩽ m'. - - Definition check_init_model cls cl := (premises_model (clauses_levels cls) None cl).2. +Definition minimal_above cls minit m := + forall m', minit ⩽ m' -> is_model m' cls -> m ⩽ m'. Lemma minimal_above_refl cls m : minimal_above cls m m. Proof. @@ -884,30 +882,6 @@ Proof. eapply m. now rewrite (clauses_conclusions_levels cls). Qed. -(* - have ms := min_model_map_spec cls' (model_model m). - set (map := min_model_map _ _) in *. - destruct ms as [hm [hcls hext]]. - rewrite LevelSet.union_spec => [] []. - * move/clauses_levels_spec. - intros [cl [hin ink]]. - now move: hcls => /(_ _ hin _ ink). - * move/(model_of_V m k). - move=> [] x /hext. firstorder. - - have ms := min_model_map_spec cls' (model_model m). - set (map := min_model_map _ _) in *. - destruct ms as [hm [hcls hext]]. - rewrite LevelSet.union_spec. - move=> [] v /hm [] [[cl [incl inclv]]|hm'] ihcls mmap. - * left. - red in inclv. eapply clauses_levels_spec. - exists cl. split => //. eapply clause_levels_spec. - destruct inclv as [[? []]|]. - + left. eapply levels_spec. now eexists. - + right. intuition. - * have [_ ho] := valid_model_only_model _ _ _ _ m hincl k. - forward ho by now exists v. now right. -Qed. *) Section InitModels. @@ -1009,18 +983,6 @@ Module CorrectModel. eapply declared_pos_ext; tea. Qed. - (* Lemma zero_is_max {V cls} (x : t V cls) : - level_value (model_of x) Level.zero = Some (model_max (model_of x)). - Proof. - intros hl. - have ha : forall l, (level_value (model_of x) l ≤ level_value (model_of x) Level.zero)%opt. - { todo "semi". } - have hmax := model_max_spec. - have hmax' := model_max_spec2. - Print model_max. - - *) - Lemma clauses_For_all_union f cls cls' : Clauses.For_all f (Clauses.union cls cls') <-> Clauses.For_all f cls /\ Clauses.For_all f cls'. @@ -3097,151 +3059,6 @@ Qed. End CounterExample2. -(** To ensure validity in Z, one must remove "latent" loops from the clauses. - As we start validity checking from a set of satisfiable clauses, we know - that there exists an equivalent set of clauses (for Z valuations) with - no latent loop. - It is basically computed by the inference algorithm. - - E.g. if we encountered a clause l ∨ x + 1 -> l+1 during inference and found - a total model m of this clause, then necessarily the model also validates - x + 1 -> l + 1 as: - - min_premise m (l ∨ x + 1) = (min m[l] m[x]-1)+1 <= m[l] <-> m[x] <= m[l] - - So, instead of checking d - - -*) - -Class In T E := in_pred : E -> T -> Prop. -Instance Ines : In LevelExprSet.t LevelExpr.t := LevelExprSet.In. -Instance Inprems : In NES.t LevelExpr.t := fun x s => LevelExprSet.In x s. - -Notation " x ∈ S " := (in_pred x S) (at level 20). - -Equations remove_prem_opt (le : LevelExpr.t) (e : NES.t) : option NES.t := - remove_prem_opt le e with inspect (LevelExprSet.is_empty (LevelExprSet.remove le e)) := - | exist true _ => None - | exist false he => Some {| t_set := LevelExprSet.remove le e; t_ne := he |}. - -Lemma remove_prem_opt_Some le e e' le' : - remove_prem_opt le e = Some e' -> - LevelExprSet.In le' e' <-> - LevelExprSet.In le' e /\ le <> le'. -Proof. - funelim (remove_prem_opt le e) => //. - intros [= <-]; cbn. - rewrite LevelExprSet.remove_spec /LevelExprSet.E.eq. - intuition auto. -Qed. - -Lemma remove_prem_opt_Some_eq le e e' : - le ∈ e -> - remove_prem_opt le e = Some e' -> - e = union (singleton le) e' /\ ~ le ∈ e'. -Proof. - intros hin. - move/remove_prem_opt_Some => hl. - split. - - apply equal_exprsets => lk. - rewrite LevelExprSet.union_spec LevelExprSet.singleton_spec. - rewrite hl. - destruct (Classes.eq_dec lk le). - * subst. split => // _. now left. - * split => //. intros hin'. now right. - intros []. congruence. apply H. - - intros hin'. specialize (hl le). - apply hl in hin'. destruct hin'. congruence. -Qed. - -Lemma remove_prem_opt_None le e : - remove_prem_opt le e = None -> - LevelExprSet.In le e <-> e = singleton le. -Proof. - funelim (remove_prem_opt le e) => //. - intros _. clear H. move: e0. - rewrite LevelExprSet.is_empty_spec. - intros he. - split. intros. - - red in he. - apply equal_exprsets => l. - rewrite LevelExprSet.singleton_spec /LevelExprSet.E.eq. - split. intros hin. - setoid_rewrite LevelExprSet.remove_spec in he. - destruct (Classes.eq_dec l le0) => //. - elim (he l). split => //. - now intros ->. - - intros ->. now eapply LevelExprSet.singleton_spec. -Qed. - -Definition union_opt (e : NES.t) (e' : option NES.t) : NES.t := - match e' with - | Some e' => union e e' - | None => e - end. - -Lemma union_opt_union e e' e'' : union (union_opt e e') e'' = union e (union_opt e'' e'). -Proof. - destruct e'; cbn. - now rewrite union_assoc (@union_comm t0). - reflexivity. -Qed. - -Lemma union_remove le prems : - le ∈ prems -> - union_opt (singleton le) (remove_prem_opt le prems) = prems. -Proof. - intros hin. - destruct (remove_prem_opt le prems) eqn:hr. - - apply equal_exprsets => lk. - cbn. rsets; rewrite /LevelExprSet.E.eq. - eapply remove_prem_opt_Some in hr. erewrite hr. - firstorder auto. subst. apply hin. - destruct (Classes.eq_dec lk le). now left. - right. firstorder. - - apply remove_prem_opt_None in hr. - apply hr in hin. subst prems. now cbn. -Qed. - -Lemma entails_weak_union_opt cls prems prems' concl : - entails cls (prems, concl) -> - entails cls (union_opt prems prems', concl). -Proof. - destruct prems'; cbn => //. - now intros ent; rewrite union_comm; eapply entails_weak_union. -Qed. - -Inductive max_chain cls : Clause.t -> Prop := -| incl cl : entails cls cl -> max_chain cls cl -| chain {prems concl k k'} {prems' : NES.t} {concl'} : - max_chain cls (prems, (concl, k)) -> - max_chain cls (prems', concl') -> - (concl, k') ∈ prems' -> - max_chain cls (union_opt (add_prems (k' - k) prems) (remove_prem_opt (concl, k') prems'), concl'). - -Lemma max_chain_entails cls cl : - max_chain cls cl <-> entails cls cl. -Proof. - split. - + induction 1. - - exact H. - - eapply (entails_cumul_one (prems' := singleton (concl0, k'))); revgoals. - { rewrite union_opt_union union_remove //. now eapply entails_weak_union. } - eapply (entails_shift (k' - k)) in IHmax_chain1. - cbn in IHmax_chain1. - have heq: k' - k + k = k' by lia. - rewrite heq in IHmax_chain1. - eapply entails_all_singleton. - now eapply entails_weak_union_opt. - + intros ent; now apply incl. -Qed. - -Definition thin_clause m cl := - let prems := premise cl in - let filter '(l, k) := if entails_dec m (prems, (l, k + 1)) then false else true in - LevelExprSet.filter filter (premise cl). - Lemma empty_filter f les : LevelExprSet.is_empty (LevelExprSet.filter f les) -> forall l, LevelExprSet.In l les -> f l = false. @@ -3270,203 +3087,6 @@ Proof. destruct (f lk); firstorder. Qed. -Lemma thin_clause_spec m cl : - let prems := thin_clause m cl in - if LevelExprSet.is_empty prems then - entails_all (clauses m) (premise cl) (succ (premise cl)) - else - exists premsnl premsl, - [/\ premise cl = (union_opt premsnl premsl)%nes, - prems = premsnl, - (forall l k, (l, k) ∈ premsnl -> ~ entails (clauses m) (premise cl, (l, k+1))) & - on_Some_or_None (fun premsl => entails_all (clauses m) (premise cl) (succ premsl)) premsl]. -Proof. - intros prems. - destruct (LevelExprSet.is_empty prems) eqn:ise. - - have ha : forall l k, LevelExprSet.In (l, k) (premise cl) -> entails (clauses m) (premise cl, (l, k + 1)). - intros l k hin. - eapply (empty_filter _ _ ise) in hin. - destruct entails_dec => //. - move=> -[] l k /In_add_prems -[[l' k']] [] hin ->. - eapply ha in hin. rewrite /succ_expr //=. now rewrite Z.add_comm. - - subst prems; unfold thin_clause in *. - set (fn := fun '(l, k) => _) in *. - set (fil := LevelExprSet.filter _ _) in *. - have hs := LevelExprSet.partition_spec2 (f:=fn) (premise cl). forward hs. tc. - have hs' := LevelExprSet.partition_spec1 (f:=fn) (premise cl). forward hs'. tc. - set (part := LevelExprSet.partition _ _) in *. - exists {| t_set := fil; t_ne := ise |}. - destruct (LevelExprSet.is_empty part.2) eqn:ise2. - * exists None. - cbn. split => //. - { apply equal_exprsets; cbn. - move=> lk. rewrite LevelExprSet.filter_spec. - intuition auto. - rewrite hs in ise2. - have he := empty_filter _ _ ise2. - specialize (he lk H). - destruct (fn lk) => //. } - { move=> l k /LevelExprSet.filter_spec -[] hin hf hent. - unfold fn in hf. destruct entails_dec => //. } - * exists (Some {| t_set := part.2; t_ne := ise2 |}). - cbn. split => //. - apply equal_exprsets => l. cbn. - rewrite LevelExprSet.union_spec. - rewrite -[fil]hs'. - now rewrite -partition_in. - { move=> l k /LevelExprSet.filter_spec -[] hin' hf hent. - unfold fn in hf. destruct entails_dec => //. } - { move=> l /In_add_prems -[[le' le'k]] []. - cbn. rewrite hs => /LevelExprSet.filter_spec [] hin heq. - intros ->. unfold fn in heq. destruct entails_dec => //. - cbn in heq. now rewrite Z.add_comm. } -Qed. - -Equations thin_clause_opt (m : t) (cl : clause) : option clause := - | m, cl with inspect (LevelExprSet.is_empty (thin_clause m cl)) := - | exist true _ => None - | exist false ne => Some ({| t_set := thin_clause m cl; t_ne := ne |}, concl cl). - - -Lemma thin_clause_opt_spec m cl : - match thin_clause_opt m cl with - | None => False - | Some cl' => - exists premsnl premsl, - [/\ premise cl = union_opt premsnl premsl, - cl' = (premsnl, concl cl), - (forall l k, (l, k) ∈ premsnl -> ~ entails (clauses m) (premise cl, (l, k+1))) & - on_Some_or_None (fun premsl => entails_all (clauses m) (premise cl) (succ premsl)) premsl] - end. -Proof. - funelim (thin_clause_opt m cl); clear H. - - assert (h := thin_clause_spec m cl). - cbn in h. - rewrite e in h. - now eapply model_entails_loop in h. - - assert (h := thin_clause_spec m cl). - cbn in h. - clear Heqcall. - rewrite ne in h. - destruct h as [premsnl [premsl []]]. - exists premsnl, premsl; split => //. - f_equal. apply equal_exprsets; cbn. now rewrite H0. -Qed. - -Lemma interp_nes_thin_clause (v : Level.t -> Z) {m cl ne} {premsnl : NES.t} : - thin_clause m cl = premsnl -> - interp_nes v ({| t_set := thin_clause m cl; t_ne := ne |}) = - interp_nes v premsnl. -Proof. - intros eq. - destruct premsnl. - destruct cl as [prems concl]; cbn in eq. - subst t_set0. f_equal. - apply equal_exprsets. cbn. reflexivity. -Qed. - -Lemma interp_nes_union_opt v e e' : - interp_nes v (union_opt e e') = - match e' with - | Some e' => Z.max (interp_nes v e) (interp_nes v e') - | None => interp_nes v e - end. -Proof. - destruct e' => //=. - now rewrite interp_nes_union; cbn. -Qed. - -Lemma thin_clause_opt_valid m cl : - match thin_clause_opt m cl with - | None => False - | Some cl' => valid_clause_Z (clauses m) cl <-> valid_clause_Z (clauses m) cl' - end. -Proof. - (* intros hent. *) - funelim (thin_clause_opt m cl). - - clear H Heqcall. - have hs := thin_clause_spec m cl. - cbn in hs. rewrite e in hs. - now eapply model_entails_loop in hs. - - clear H Heqcall. - have hs := thin_clause_spec m cl. - cbn in hs. rewrite ne in hs. - destruct cl as [prems [concl k]]. - rewrite /valid_clause_Z. cbn. - cbn in hs. destruct hs as [premsl [premsnl [heq heq' hent' hentl]]]. - split. - * move=> hv v vpos csem. - have hi := interp_nes_thin_clause v (ne := ne) heq'. - move: hv => /(_ v vpos csem). - rewrite hi. subst prems. - rewrite interp_nes_union_opt. - destruct premsnl => //. - destruct heq'. - move/to_entails_all: hentl. - move/entails_L_entails_ℋ_equiv/entails_L_rels_entails_L_clauses/completeness_all. - move/(_ Z _ v). - rewrite -interp_rels_clauses_sem. - move/(_ csem). - rewrite -interp_rels_clauses_sem. - move/clauses_sem_clauses_of_le. - rewrite interp_add_prems interp_nes_union. - cbn in hent' |- *. lia. - * move=> hv v vpos csem. - have hi := interp_nes_thin_clause v (ne := ne) heq'. - move: hv => /(_ v vpos csem). - rewrite hi. - subst prems. - rewrite interp_nes_union_opt. - destruct premsnl => //. - destruct heq'. - move/to_entails_all: hentl. - move/entails_L_entails_ℋ_equiv/entails_L_rels_entails_L_clauses/completeness_all. - move/(_ Z _ v). - rewrite -interp_rels_clauses_sem. - move/(_ csem). - rewrite -interp_rels_clauses_sem. - move/clauses_sem_clauses_of_le. - rewrite interp_add_prems interp_nes_union. - cbn in hent' |- *. lia. -Qed. - -(* -Lemma thin_clause_opt_entails m cl : - match thin_clause_opt m cl with - | None => False - | Some cl' => entails (clauses m) cl' -> entails (clauses m) cl - end. -Proof. Admitted. *) - -Definition thin_clauses m := - Clauses.fold (fun cl acc => - match thin_clause_opt m cl with - | Some cl' => Clauses.add cl' acc - | None => acc (* Impossible for consistent models *) - end) (clauses m) Clauses.empty. - -Lemma thin_clauses_spec m : - forall cl, Clauses.In cl (clauses m) -> - exists cl', thin_clause_opt m cl = Some cl' /\ Clauses.In cl' (thin_clauses m). -Proof. Admitted. - -Lemma thin_clauses_spec_inv m : - forall cl, Clauses.In cl (thin_clauses m) -> - exists clo, thin_clause_opt m clo = Some cl /\ Clauses.In clo (clauses m). -Proof. Admitted. - -(** The thinned clauses are stronger than the original clauses *) -Lemma thin_clauses_entails m : thin_clauses m ⊢ℋ clauses m. -Proof. - intros cl hin. - destruct (thin_clauses_spec m cl hin) as [cl' [heq hin']]. - have hs := thin_clause_opt_spec m cl. - rewrite heq in hs. destruct hs as [premsnl [premsl [eq eq' ent ent']]]. - destruct cl as [prems concl]. cbn in eq, eq', ent. - subst prems cl'. - now eapply entails_weak_union_opt, entails_in. -Qed. - Lemma is_model_entails_H m cls cls' : is_model m cls -> cls ⊢ℋ cls' -> @@ -3478,13 +3098,6 @@ Proof. eapply entails_model_valid; tea. Qed. -Lemma thin_clauses_model model m : - is_model model (thin_clauses m) -> is_model model (clauses m). -Proof. - move=> ism. eapply is_model_entails_H; tea. - eapply thin_clauses_entails. -Qed. - Lemma is_model_singleton m cl : is_model m (Clauses.singleton cl) <-> valid_clause m cl. Proof. rewrite is_modelP. split. @@ -3565,82 +3178,11 @@ Proof. move=> -[y'] [] [=] <-. lia. Qed. -Lemma is_total_model_thin m m' : - is_total_model m' (clauses m) -> - is_total_model m' (thin_clauses m). -Proof. - move/is_total_model_altP => ism. - apply/is_total_model_altP => cl /thin_clauses_spec_inv -[] cl' [] heq /ism. - have := thin_clause_opt_spec m cl'. - rewrite heq => -[premsnl] [premsl] [eq eq' ent nent]. - subst cl. - move=> -[] minp [] value [] => hmin hl hle. - exists minp, value. cbn. split => //. - rewrite -hmin eq. - apply antisymmetry; revgoals. - { eapply min_premise_subset. destruct premsl; cbn; lesets. } - destruct premsl as [premsl|]; cbn => //; revgoals. reflexivity. - rewrite min_premise_union. - cbn in nent. - rewrite -to_entails_all in nent. - eapply entails_all_model_valid in nent. 2:{ apply is_model_valid. eapply is_total_model_altP in ism. apply ism. } - rewrite eq in nent. cbn in nent. - rewrite eq min_premise_union in hmin. - destruct (min_premise m' premsl) as [minl|] eqn:minle, (min_premise m' premsnl) as [minnl|] eqn:minnle; cbn in hmin |- * => //. - noconf hmin. constructor. - eapply valid_clauses_of_le in nent. 2:{ rewrite min_premise_union minle minnle //=. } - 2:{ rewrite (min_premise_add_prems minle); trea. } lia. -Qed. - Lemma total_model m : is_total_model (model m) (clauses m). Proof. split. apply model_enabled. apply model_ok. Qed. -Lemma total_model_thin m : is_total_model (model m) (thin_clauses m). -Proof. - by eapply is_total_model_thin, total_model. -Qed. - -(* Lemma complete_thin_model m m' : - is_total_model m (thin_clauses m) -> - is_model m' (thin_clauses m) -> - exists m'', is_model (extend) *) - -Definition check_clauseZ m cl := - check_genb (thin_clauses m) cl. - -Lemma clauses_levels_thin m : clauses_levels (thin_clauses m) ⊂_lset clauses_levels (clauses m). -Proof. Admitted. - -Lemma check_gen_thin_model_looping m cl v vcls isl : - check_gen (thin_clauses m) cl = IsLooping v vcls isl -> False. -Proof. - intros. - have hm := m.(model_valid).(model_ok). - have hen := model_enabled m. - have htot : is_total_model (model m) (clauses m). - split => //. - eapply is_total_model_thin in htot. - eapply (check_valid_looping (cls := thin_clauses m)). apply htot. tea. - eapply defined_model_of_ext. eapply defined_model_of_subset. - 2:{ eapply defined_model. } - intros ? ?; eapply clauses_levels_declared. - instantiate (1 := m). now eapply clauses_levels_thin, vcls. - reflexivity. -Qed. - -Lemma checkb_thin_entails m cl : - check_genb (thin_clauses m) cl <-> entails (thin_clauses m) cl. -Proof. - unfold check_genb. - destruct (check_gen) eqn:ec. - - now move/check_gen_thin_model_looping: ec. - - split => //. - now move/check_invalid_entails: ec. - - now move/check_gen_entails: ec. -Qed. - Lemma entails_clauses_completeness cls cls' : cls ⊢ℋ cls' -> valid_clauses_Z cls cls'. @@ -3654,189 +3196,6 @@ Proof. eauto. Qed. -Lemma entails_thin_disj m cl : - entails (thin_clauses m) cl -> - thin_clauses m ⊢ℋ inverse_clauses cl -> False. -Proof. - have ht := is_total_model_thin m m. - forward ht. split. eapply model_enabled. apply model_ok. - rewrite entails_completeness => ha. - move/entails_clauses_completeness => hz. - move: (hz (Z_valuation_of_model m)) => /fwd. - apply valuation_of_model_pos. move=> /fwd. - eapply valid_clauses_model; apply ht. - specialize (ha Z _ (Z_valuation_of_model m)). - forward ha. - eapply valid_clauses_model; apply ht. - move: ha. rewrite -neg_inverse_Z. contradiction. -Qed. - -Definition thinned_clause cls cl := - forall e, e ∈ premise cl -> ~ cls ⊢ premise cl → succ_expr e. - -Lemma nthinned_clause cls cl : ~ thinned_clause cls cl <-> - (exists e, e ∈ premise cl /\ cls ⊢ premise cl → succ_expr e). -Proof. - split. intros. - admit. intros [e [hin heent]] hf. - specialize (hf e hin). contradiction. -Admitted. - -Definition thinned_clauses cls := - forall cl, Clauses.In cl cls -> thinned_clause cls cl. - -Definition unique_prems (prems : NES.t) := - forall l k k', (l, k) ∈ prems -> (l, k') ∈ prems -> k = k'. - -Definition increasing cl := - (exists k', LevelExprSet.In ((concl cl).1, k') (premise cl)) /\ - (forall k', LevelExprSet.In ((concl cl).1, k') (premise cl) -> (k' < (concl cl).2)%Z). - -Lemma increasing_dec cl : { increasing cl } + { ~ increasing cl }. -Admitted. - -Lemma nincreasing_spec cl : (~ increasing cl) <-> - (~ exists k', LevelExprSet.In ((concl cl).1, k') (premise cl)) \/ - (exists k', LevelExprSet.In ((concl cl).1, k') (premise cl) /\ (concl cl).2 <= k')%Z. -Proof. -Admitted. - -Lemma entails_thin_dup cls prems concl : - entails cls (prems, concl) -> - forall l k k', (l, k) ∈ prems -> (l, k') ∈ prems -> k < k' -> - exists prems', remove_prem_opt (l, k) prems = Some prems' /\ - entails cls (prems', concl). -Proof. - intros ent l k k' ha hb hlt. - destruct (remove_prem_opt) eqn:rm. - - eapply remove_prem_opt_Some_eq in rm as []. subst prems. - exists t0. split => //. - eapply (entails_cumul_one (prems' := singleton (l, k))). - eapply entails_all_singleton. - move/LevelExprSet.union_spec: hb => -[]. - * move/LevelExprSet.singleton_spec => [=] eq. subst k'. cbn in hlt; lia. - * intros he. eapply entails_lower. exists k'. split => //. cbn in *; lia. - * now rewrite union_comm. - * exact ha. - - eapply remove_prem_opt_None in rm. - apply rm in ha. - cbn in ha; subst prems. - apply LevelExprSet.singleton_spec in hb. noconf hb. - cbn in hlt. lia. -Qed. -(* - Inductive entailsS (cls : Clauses.t) : clause -> Prop := - | clause_in (prems : premises) (concl : LevelExpr.t) : - LevelExprSet.In concl prems -> entailsS cls (prems, concl) - - | clause_cut prems' concl' prems concl : - in_pred_closure cls (prems', concl') -> - ~ (exists k', (concl'.1, k') ∈ prems /\ concl'.2 <= k') -> - entailsS cls (NES.add concl' prems, concl) -> - LevelExprSet.Subset prems' prems -> - entailsS cls (prems, concl). - -About entailsS_ind. - - Lemma entails_entailsS cls cl : - entailsS cls cl -> - entails cls cl. - Proof. - induction 1. - - now constructor. - - eapply Clauses.clause_cut; tea. - Qed. *) - - - -(* Print entails. *) - -Lemma entails_thinned cls : - (* thinned_clauses cls -> *) - forall cl, entails cls cl -> - (increasing cl /\ exists cl, Clauses.In cl cls /\ ~ thinned_clause cls cl) \/ - (~ increasing cl). -Proof. - intros cl. - induction 1. - - right. move=> -[[k' hin] ha]. - destruct concl0 as [concl k]. - cbn in *. - specialize (ha _ H). lia. - - cbn. - destruct IHentails. - destruct H2 as [inc nthin]. - destruct inc as [[k' hink'] hf]. - * cbn -[lt] in *. - eapply LevelExprSet.add_spec in hink' as [heq|hinc]. - red in heq; subst concl'. - destruct (increasing_dec (prems, concl0)). - now left. now right. - left. split => //. - split; cbn -[lt]. now exists k'. - intros. apply hf. apply LevelExprSet.add_spec; now right. - * apply nincreasing_spec in H2. - cbn -[lt] in *. - destruct H2. - right. move=> [h h']. apply H2. cbn in *. - destruct h as [k' ?]; exists k'; apply LevelExprSet.add_spec; now right. - destruct H2. - destruct (increasing_dec (prems, concl0)). - left. split => //. destruct H2. - apply LevelExprSet.add_spec in H2. destruct H2. - red in H2; subst concl'. - red in i. cbn in i. - Admitted. - - (** We are inferring (concl0, n + kc') from a clause (premsc, (concl0, kc')) - in cls where premsc + n ⊂ prems and prems has all it concl0 atoms smaller - than kc'. If the premsc contains concl0 it cannot be thinned. - Otherwise it might be introducing concl0, n + kc', e.g. - - x -> (concl0, kc') allows to prove x -> (concl0, kc). - - *) - - -Lemma thin_clauses_levels m : clauses_levels (thin_clauses m) ⊂_lset clauses_levels (clauses m). -Proof. Admitted. - -Lemma entails_dec_thin (m : t) cl : - { entails (thin_clauses m) cl } + { ~ entails (thin_clauses m) cl }. -Proof. - destruct (check_gen (thin_clauses m) cl) eqn:ch. - - move/check_looping: ch; elim. - exists (model_of m). split. - { have dm := defined_model m. - eapply defined_model_of_subset; tea. - eapply defined_model_of_subset; tea. - intros ?; rewrite -clauses_levels_declared. - apply thin_clauses_levels. } - apply total_model_thin. - - move/check_invalid_entails: ch. intros ne. now right. - - move/check_gen_entails: ch. now left. -Qed. - -(** If a clause cl is not entailed then its inverse must be consistent. *) -Lemma nentails_thin_con m cl : - ~ entails (thin_clauses m) cl -> - (exists l, Clauses.union (thin_clauses m) (inverse_clauses cl) ⊢ℋ (succ l ⋞ l)%cls) -> False. -Proof. - intros _ hl. - set (cl' := (singleton (concl cl), succ_expr (concl cl))). - destruct (entails_dec_thin m cl'). - { eapply entails_completeness in e. - specialize (e Z _ (Z_valuation_of_model m)). - forward e. apply valid_clauses_model; - apply total_model_thin. - destruct cl as [prems [concl k]]; cbn in e. rewrite /interp_expr in e. - rewrite interp_nes_singleton //= in e. lia. } - { destruct hl as [l hl]. - unfold inverse_clauses in hl. - destruct cl as [prems concl]. cbn in cl'. - admit. } -Admitted. - Lemma total_model_sem {m cls} : is_total_model m cls -> clauses_sem (Z_valuation_of_model m) cls. diff --git a/common/theories/LoopChecking/Thinning.v b/common/theories/LoopChecking/Thinning.v new file mode 100644 index 000000000..19bd1176a --- /dev/null +++ b/common/theories/LoopChecking/Thinning.v @@ -0,0 +1,417 @@ + +(** To ensure validity in Z, one must remove "latent" loops from the clauses. + As we start validity checking from a set of satisfiable clauses, we know + that there exists an equivalent set of clauses (for Z valuations) with + no latent loop. + It is basically computed by the inference algorithm. + + E.g. if we encountered a clause l ∨ x + 1 -> l+1 during inference and found + a total model m of this clause, then necessarily the model also validates + x + 1 -> l + 1 as: + + min_premise m (l ∨ x + 1) = (min m[l] m[x]-1)+1 <= m[l] <-> m[x] <= m[l] + + So, instead of checking d + + +*) + +Class In T E := in_pred : E -> T -> Prop. +Instance Ines : In LevelExprSet.t LevelExpr.t := LevelExprSet.In. +Instance Inprems : In NES.t LevelExpr.t := fun x s => LevelExprSet.In x s. + +Notation " x ∈ S " := (in_pred x S) (at level 20). + +Equations remove_prem_opt (le : LevelExpr.t) (e : NES.t) : option NES.t := + remove_prem_opt le e with inspect (LevelExprSet.is_empty (LevelExprSet.remove le e)) := + | exist true _ => None + | exist false he => Some {| t_set := LevelExprSet.remove le e; t_ne := he |}. + +Lemma remove_prem_opt_Some le e e' le' : + remove_prem_opt le e = Some e' -> + LevelExprSet.In le' e' <-> + LevelExprSet.In le' e /\ le <> le'. +Proof. + funelim (remove_prem_opt le e) => //. + intros [= <-]; cbn. + rewrite LevelExprSet.remove_spec /LevelExprSet.E.eq. + intuition auto. +Qed. + +Lemma remove_prem_opt_Some_eq le e e' : + le ∈ e -> + remove_prem_opt le e = Some e' -> + e = union (singleton le) e' /\ ~ le ∈ e'. +Proof. + intros hin. + move/remove_prem_opt_Some => hl. + split. + - apply equal_exprsets => lk. + rewrite LevelExprSet.union_spec LevelExprSet.singleton_spec. + rewrite hl. + destruct (Classes.eq_dec lk le). + * subst. split => // _. now left. + * split => //. intros hin'. now right. + intros []. congruence. apply H. + - intros hin'. specialize (hl le). + apply hl in hin'. destruct hin'. congruence. +Qed. + +Lemma remove_prem_opt_None le e : + remove_prem_opt le e = None -> + LevelExprSet.In le e <-> e = singleton le. +Proof. + funelim (remove_prem_opt le e) => //. + intros _. clear H. move: e0. + rewrite LevelExprSet.is_empty_spec. + intros he. + split. intros. + - red in he. + apply equal_exprsets => l. + rewrite LevelExprSet.singleton_spec /LevelExprSet.E.eq. + split. intros hin. + setoid_rewrite LevelExprSet.remove_spec in he. + destruct (Classes.eq_dec l le0) => //. + elim (he l). split => //. + now intros ->. + - intros ->. now eapply LevelExprSet.singleton_spec. +Qed. + +Definition union_opt (e : NES.t) (e' : option NES.t) : NES.t := + match e' with + | Some e' => union e e' + | None => e + end. + +Lemma union_opt_union e e' e'' : union (union_opt e e') e'' = union e (union_opt e'' e'). +Proof. + destruct e'; cbn. + now rewrite union_assoc (@union_comm t0). + reflexivity. +Qed. + +Lemma union_remove le prems : + le ∈ prems -> + union_opt (singleton le) (remove_prem_opt le prems) = prems. +Proof. + intros hin. + destruct (remove_prem_opt le prems) eqn:hr. + - apply equal_exprsets => lk. + cbn. rsets; rewrite /LevelExprSet.E.eq. + eapply remove_prem_opt_Some in hr. erewrite hr. + firstorder auto. subst. apply hin. + destruct (Classes.eq_dec lk le). now left. + right. firstorder. + - apply remove_prem_opt_None in hr. + apply hr in hin. subst prems. now cbn. +Qed. + +Lemma entails_weak_union_opt cls prems prems' concl : + entails cls (prems, concl) -> + entails cls (union_opt prems prems', concl). +Proof. + destruct prems'; cbn => //. + now intros ent; rewrite union_comm; eapply entails_weak_union. +Qed. + +Inductive max_chain cls : Clause.t -> Prop := +| incl cl : entails cls cl -> max_chain cls cl +| chain {prems concl k k'} {prems' : NES.t} {concl'} : + max_chain cls (prems, (concl, k)) -> + max_chain cls (prems', concl') -> + (concl, k') ∈ prems' -> + max_chain cls (union_opt (add_prems (k' - k) prems) (remove_prem_opt (concl, k') prems'), concl'). + +Lemma max_chain_entails cls cl : + max_chain cls cl <-> entails cls cl. +Proof. + split. + + induction 1. + - exact H. + - eapply (entails_cumul_one (prems' := singleton (concl0, k'))); revgoals. + { rewrite union_opt_union union_remove //. now eapply entails_weak_union. } + eapply (entails_shift (k' - k)) in IHmax_chain1. + cbn in IHmax_chain1. + have heq: k' - k + k = k' by lia. + rewrite heq in IHmax_chain1. + eapply entails_all_singleton. + now eapply entails_weak_union_opt. + + intros ent; now apply incl. +Qed. + +Definition thin_clause m cl := + let prems := premise cl in + let filter '(l, k) := if entails_dec m (prems, (l, k + 1)) then false else true in + LevelExprSet.filter filter (premise cl). + + +Lemma thin_clause_spec m cl : + let prems := thin_clause m cl in + if LevelExprSet.is_empty prems then + entails_all (clauses m) (premise cl) (succ (premise cl)) + else + exists premsnl premsl, + [/\ premise cl = (union_opt premsnl premsl)%nes, + prems = premsnl, + (forall l k, (l, k) ∈ premsnl -> ~ entails (clauses m) (premise cl, (l, k+1))) & + on_Some_or_None (fun premsl => entails_all (clauses m) (premise cl) (succ premsl)) premsl]. +Proof. + intros prems. + destruct (LevelExprSet.is_empty prems) eqn:ise. + - have ha : forall l k, LevelExprSet.In (l, k) (premise cl) -> entails (clauses m) (premise cl, (l, k + 1)). + intros l k hin. + eapply (empty_filter _ _ ise) in hin. + destruct entails_dec => //. + move=> -[] l k /In_add_prems -[[l' k']] [] hin ->. + eapply ha in hin. rewrite /succ_expr //=. now rewrite Z.add_comm. + - subst prems; unfold thin_clause in *. + set (fn := fun '(l, k) => _) in *. + set (fil := LevelExprSet.filter _ _) in *. + have hs := LevelExprSet.partition_spec2 (f:=fn) (premise cl). forward hs. tc. + have hs' := LevelExprSet.partition_spec1 (f:=fn) (premise cl). forward hs'. tc. + set (part := LevelExprSet.partition _ _) in *. + exists {| t_set := fil; t_ne := ise |}. + destruct (LevelExprSet.is_empty part.2) eqn:ise2. + * exists None. + cbn. split => //. + { apply equal_exprsets; cbn. + move=> lk. rewrite LevelExprSet.filter_spec. + intuition auto. + rewrite hs in ise2. + have he := empty_filter _ _ ise2. + specialize (he lk H). + destruct (fn lk) => //. } + { move=> l k /LevelExprSet.filter_spec -[] hin hf hent. + unfold fn in hf. destruct entails_dec => //. } + * exists (Some {| t_set := part.2; t_ne := ise2 |}). + cbn. split => //. + apply equal_exprsets => l. cbn. + rewrite LevelExprSet.union_spec. + rewrite -[fil]hs'. + now rewrite -partition_in. + { move=> l k /LevelExprSet.filter_spec -[] hin' hf hent. + unfold fn in hf. destruct entails_dec => //. } + { move=> l /In_add_prems -[[le' le'k]] []. + cbn. rewrite hs => /LevelExprSet.filter_spec [] hin heq. + intros ->. unfold fn in heq. destruct entails_dec => //. + cbn in heq. now rewrite Z.add_comm. } +Qed. + +Equations thin_clause_opt (m : t) (cl : clause) : option clause := + | m, cl with inspect (LevelExprSet.is_empty (thin_clause m cl)) := + | exist true _ => None + | exist false ne => Some ({| t_set := thin_clause m cl; t_ne := ne |}, concl cl). + + +Lemma thin_clause_opt_spec m cl : + match thin_clause_opt m cl with + | None => False + | Some cl' => + exists premsnl premsl, + [/\ premise cl = union_opt premsnl premsl, + cl' = (premsnl, concl cl), + (forall l k, (l, k) ∈ premsnl -> ~ entails (clauses m) (premise cl, (l, k+1))) & + on_Some_or_None (fun premsl => entails_all (clauses m) (premise cl) (succ premsl)) premsl] + end. +Proof. + funelim (thin_clause_opt m cl); clear H. + - assert (h := thin_clause_spec m cl). + cbn in h. + rewrite e in h. + now eapply model_entails_loop in h. + - assert (h := thin_clause_spec m cl). + cbn in h. + clear Heqcall. + rewrite ne in h. + destruct h as [premsnl [premsl []]]. + exists premsnl, premsl; split => //. + f_equal. apply equal_exprsets; cbn. now rewrite H0. +Qed. + +Lemma interp_nes_thin_clause (v : Level.t -> Z) {m cl ne} {premsnl : NES.t} : + thin_clause m cl = premsnl -> + interp_nes v ({| t_set := thin_clause m cl; t_ne := ne |}) = + interp_nes v premsnl. +Proof. + intros eq. + destruct premsnl. + destruct cl as [prems concl]; cbn in eq. + subst t_set0. f_equal. + apply equal_exprsets. cbn. reflexivity. +Qed. + +Lemma interp_nes_union_opt v e e' : + interp_nes v (union_opt e e') = + match e' with + | Some e' => Z.max (interp_nes v e) (interp_nes v e') + | None => interp_nes v e + end. +Proof. + destruct e' => //=. + now rewrite interp_nes_union; cbn. +Qed. + +Lemma thin_clause_opt_valid m cl : + match thin_clause_opt m cl with + | None => False + | Some cl' => valid_clause_Z (clauses m) cl <-> valid_clause_Z (clauses m) cl' + end. +Proof. + (* intros hent. *) + funelim (thin_clause_opt m cl). + - clear H Heqcall. + have hs := thin_clause_spec m cl. + cbn in hs. rewrite e in hs. + now eapply model_entails_loop in hs. + - clear H Heqcall. + have hs := thin_clause_spec m cl. + cbn in hs. rewrite ne in hs. + destruct cl as [prems [concl k]]. + rewrite /valid_clause_Z. cbn. + cbn in hs. destruct hs as [premsl [premsnl [heq heq' hent' hentl]]]. + split. + * move=> hv v vpos csem. + have hi := interp_nes_thin_clause v (ne := ne) heq'. + move: hv => /(_ v vpos csem). + rewrite hi. subst prems. + rewrite interp_nes_union_opt. + destruct premsnl => //. + destruct heq'. + move/to_entails_all: hentl. + move/entails_L_entails_ℋ_equiv/entails_L_rels_entails_L_clauses/completeness_all. + move/(_ Z _ v). + rewrite -interp_rels_clauses_sem. + move/(_ csem). + rewrite -interp_rels_clauses_sem. + move/clauses_sem_clauses_of_le. + rewrite interp_add_prems interp_nes_union. + cbn in hent' |- *. lia. + * move=> hv v vpos csem. + have hi := interp_nes_thin_clause v (ne := ne) heq'. + move: hv => /(_ v vpos csem). + rewrite hi. + subst prems. + rewrite interp_nes_union_opt. + destruct premsnl => //. + destruct heq'. + move/to_entails_all: hentl. + move/entails_L_entails_ℋ_equiv/entails_L_rels_entails_L_clauses/completeness_all. + move/(_ Z _ v). + rewrite -interp_rels_clauses_sem. + move/(_ csem). + rewrite -interp_rels_clauses_sem. + move/clauses_sem_clauses_of_le. + rewrite interp_add_prems interp_nes_union. + cbn in hent' |- *. lia. +Qed. + +(* +Lemma thin_clause_opt_entails m cl : + match thin_clause_opt m cl with + | None => False + | Some cl' => entails (clauses m) cl' -> entails (clauses m) cl + end. +Proof. Admitted. *) + +Definition thin_clauses m := + Clauses.fold (fun cl acc => + match thin_clause_opt m cl with + | Some cl' => Clauses.add cl' acc + | None => acc (* Impossible for consistent models *) + end) (clauses m) Clauses.empty. + +Lemma thin_clauses_spec m : + forall cl, Clauses.In cl (clauses m) -> + exists cl', thin_clause_opt m cl = Some cl' /\ Clauses.In cl' (thin_clauses m). +Proof. Admitted. + +Lemma thin_clauses_spec_inv m : + forall cl, Clauses.In cl (thin_clauses m) -> + exists clo, thin_clause_opt m clo = Some cl /\ Clauses.In clo (clauses m). +Proof. Admitted. + +(** The thinned clauses are stronger than the original clauses *) +Lemma thin_clauses_entails m : thin_clauses m ⊢ℋ clauses m. +Proof. + intros cl hin. + destruct (thin_clauses_spec m cl hin) as [cl' [heq hin']]. + have hs := thin_clause_opt_spec m cl. + rewrite heq in hs. destruct hs as [premsnl [premsl [eq eq' ent ent']]]. + destruct cl as [prems concl]. cbn in eq, eq', ent. + subst prems cl'. + now eapply entails_weak_union_opt, entails_in. +Qed. +Lemma thin_clauses_model model m : + is_model model (thin_clauses m) -> is_model model (clauses m). +Proof. + move=> ism. eapply is_model_entails_H; tea. + eapply thin_clauses_entails. +Qed. + + +Lemma is_total_model_thin m m' : + is_total_model m' (clauses m) -> + is_total_model m' (thin_clauses m). +Proof. + move/is_total_model_altP => ism. + apply/is_total_model_altP => cl /thin_clauses_spec_inv -[] cl' [] heq /ism. + have := thin_clause_opt_spec m cl'. + rewrite heq => -[premsnl] [premsl] [eq eq' ent nent]. + subst cl. + move=> -[] minp [] value [] => hmin hl hle. + exists minp, value. cbn. split => //. + rewrite -hmin eq. + apply antisymmetry; revgoals. + { eapply min_premise_subset. destruct premsl; cbn; lesets. } + destruct premsl as [premsl|]; cbn => //; revgoals. reflexivity. + rewrite min_premise_union. + cbn in nent. + rewrite -to_entails_all in nent. + eapply entails_all_model_valid in nent. 2:{ apply is_model_valid. eapply is_total_model_altP in ism. apply ism. } + rewrite eq in nent. cbn in nent. + rewrite eq min_premise_union in hmin. + destruct (min_premise m' premsl) as [minl|] eqn:minle, (min_premise m' premsnl) as [minnl|] eqn:minnle; cbn in hmin |- * => //. + noconf hmin. constructor. + eapply valid_clauses_of_le in nent. 2:{ rewrite min_premise_union minle minnle //=. } + 2:{ rewrite (min_premise_add_prems minle); trea. } lia. +Qed. + + +Lemma total_model_thin m : is_total_model (model m) (thin_clauses m). +Proof. + by eapply is_total_model_thin, total_model. +Qed. + +Definition check_clauseZ m cl := + check_genb (thin_clauses m) cl. + +Lemma clauses_levels_thin m : clauses_levels (thin_clauses m) ⊂_lset clauses_levels (clauses m). +Proof. Admitted. + +Lemma check_gen_thin_model_looping m cl v vcls isl : + check_gen (thin_clauses m) cl = IsLooping v vcls isl -> False. +Proof. + intros. + have hm := m.(model_valid).(model_ok). + have hen := model_enabled m. + have htot : is_total_model (model m) (clauses m). + split => //. + eapply is_total_model_thin in htot. + eapply (check_valid_looping (cls := thin_clauses m)). apply htot. tea. + eapply defined_model_of_ext. eapply defined_model_of_subset. + 2:{ eapply defined_model. } + intros ? ?; eapply clauses_levels_declared. + instantiate (1 := m). now eapply clauses_levels_thin, vcls. + reflexivity. +Qed. + +Lemma checkb_thin_entails m cl : + check_genb (thin_clauses m) cl <-> entails (thin_clauses m) cl. +Proof. + unfold check_genb. + destruct (check_gen) eqn:ec. + - now move/check_gen_thin_model_looping: ec. + - split => //. + now move/check_invalid_entails: ec. + - now move/check_gen_entails: ec. +Qed. diff --git a/template-rocq/theories/Junk.v b/template-rocq/theories/Junk.v index 40b4e29a6..f82a7d583 100644 --- a/template-rocq/theories/Junk.v +++ b/template-rocq/theories/Junk.v @@ -1902,3 +1902,189 @@ Proof. specialize (min' m). Search level_value. Search valid_clause. *) + + + +(** If a clause cl is not entailed then its inverse must be consistent. *) +Lemma nentails_thin_con m cl : + ~ entails (thin_clauses m) cl -> + (exists l, Clauses.union (thin_clauses m) (inverse_clauses cl) ⊢ℋ (succ l ⋞ l)%cls) -> False. +Proof. + intros _ hl. + set (cl' := (singleton (concl cl), succ_expr (concl cl))). + destruct (entails_dec_thin m cl'). + { eapply entails_completeness in e. + specialize (e Z _ (Z_valuation_of_model m)). + forward e. apply valid_clauses_model; + apply total_model_thin. + destruct cl as [prems [concl k]]; cbn in e. rewrite /interp_expr in e. + rewrite interp_nes_singleton //= in e. lia. } + { destruct hl as [l hl]. + unfold inverse_clauses in hl. + destruct cl as [prems concl]. cbn in cl'. + admit. } +Admitted. + + +Lemma entails_thin_disj m cl : + entails (thin_clauses m) cl -> + thin_clauses m ⊢ℋ inverse_clauses cl -> False. +Proof. + have ht := is_total_model_thin m m. + forward ht. split. eapply model_enabled. apply model_ok. + rewrite entails_completeness => ha. + move/entails_clauses_completeness => hz. + move: (hz (Z_valuation_of_model m)) => /fwd. + apply valuation_of_model_pos. move=> /fwd. + eapply valid_clauses_model; apply ht. + specialize (ha Z _ (Z_valuation_of_model m)). + forward ha. + eapply valid_clauses_model; apply ht. + move: ha. rewrite -neg_inverse_Z. contradiction. +Qed. + +Definition thinned_clause cls cl := + forall e, e ∈ premise cl -> ~ cls ⊢ premise cl → succ_expr e. + +Lemma nthinned_clause cls cl : ~ thinned_clause cls cl <-> + (exists e, e ∈ premise cl /\ cls ⊢ premise cl → succ_expr e). +Proof. + split. intros. + admit. intros [e [hin heent]] hf. + specialize (hf e hin). contradiction. +Admitted. + +Definition thinned_clauses cls := + forall cl, Clauses.In cl cls -> thinned_clause cls cl. + +Definition unique_prems (prems : NES.t) := + forall l k k', (l, k) ∈ prems -> (l, k') ∈ prems -> k = k'. + +Definition increasing cl := + (exists k', LevelExprSet.In ((concl cl).1, k') (premise cl)) /\ + (forall k', LevelExprSet.In ((concl cl).1, k') (premise cl) -> (k' < (concl cl).2)%Z). + +Lemma increasing_dec cl : { increasing cl } + { ~ increasing cl }. +Admitted. + +Lemma nincreasing_spec cl : (~ increasing cl) <-> + (~ exists k', LevelExprSet.In ((concl cl).1, k') (premise cl)) \/ + (exists k', LevelExprSet.In ((concl cl).1, k') (premise cl) /\ (concl cl).2 <= k')%Z. +Proof. +Admitted. + +Lemma entails_thin_dup cls prems concl : + entails cls (prems, concl) -> + forall l k k', (l, k) ∈ prems -> (l, k') ∈ prems -> k < k' -> + exists prems', remove_prem_opt (l, k) prems = Some prems' /\ + entails cls (prems', concl). +Proof. + intros ent l k k' ha hb hlt. + destruct (remove_prem_opt) eqn:rm. + - eapply remove_prem_opt_Some_eq in rm as []. subst prems. + exists t0. split => //. + eapply (entails_cumul_one (prems' := singleton (l, k))). + eapply entails_all_singleton. + move/LevelExprSet.union_spec: hb => -[]. + * move/LevelExprSet.singleton_spec => [=] eq. subst k'. cbn in hlt; lia. + * intros he. eapply entails_lower. exists k'. split => //. cbn in *; lia. + * now rewrite union_comm. + * exact ha. + - eapply remove_prem_opt_None in rm. + apply rm in ha. + cbn in ha; subst prems. + apply LevelExprSet.singleton_spec in hb. noconf hb. + cbn in hlt. lia. +Qed. +(* + Inductive entailsS (cls : Clauses.t) : clause -> Prop := + | clause_in (prems : premises) (concl : LevelExpr.t) : + LevelExprSet.In concl prems -> entailsS cls (prems, concl) + + | clause_cut prems' concl' prems concl : + in_pred_closure cls (prems', concl') -> + ~ (exists k', (concl'.1, k') ∈ prems /\ concl'.2 <= k') -> + entailsS cls (NES.add concl' prems, concl) -> + LevelExprSet.Subset prems' prems -> + entailsS cls (prems, concl). + +About entailsS_ind. + + Lemma entails_entailsS cls cl : + entailsS cls cl -> + entails cls cl. + Proof. + induction 1. + - now constructor. + - eapply Clauses.clause_cut; tea. + Qed. *) + + + +(* Print entails. *) + +Lemma entails_thinned cls : + (* thinned_clauses cls -> *) + forall cl, entails cls cl -> + (increasing cl /\ exists cl, Clauses.In cl cls /\ ~ thinned_clause cls cl) \/ + (~ increasing cl). +Proof. + intros cl. + induction 1. + - right. move=> -[[k' hin] ha]. + destruct concl0 as [concl k]. + cbn in *. + specialize (ha _ H). lia. + - cbn. + destruct IHentails. + destruct H2 as [inc nthin]. + destruct inc as [[k' hink'] hf]. + * cbn -[lt] in *. + eapply LevelExprSet.add_spec in hink' as [heq|hinc]. + red in heq; subst concl'. + destruct (increasing_dec (prems, concl0)). + now left. now right. + left. split => //. + split; cbn -[lt]. now exists k'. + intros. apply hf. apply LevelExprSet.add_spec; now right. + * apply nincreasing_spec in H2. + cbn -[lt] in *. + destruct H2. + right. move=> [h h']. apply H2. cbn in *. + destruct h as [k' ?]; exists k'; apply LevelExprSet.add_spec; now right. + destruct H2. + destruct (increasing_dec (prems, concl0)). + left. split => //. destruct H2. + apply LevelExprSet.add_spec in H2. destruct H2. + red in H2; subst concl'. + red in i. cbn in i. + Admitted. + + (** We are inferring (concl0, n + kc') from a clause (premsc, (concl0, kc')) + in cls where premsc + n ⊂ prems and prems has all it concl0 atoms smaller + than kc'. If the premsc contains concl0 it cannot be thinned. + Otherwise it might be introducing concl0, n + kc', e.g. + + x -> (concl0, kc') allows to prove x -> (concl0, kc). + + *) + + +Lemma thin_clauses_levels m : clauses_levels (thin_clauses m) ⊂_lset clauses_levels (clauses m). +Proof. Admitted. + +Lemma entails_dec_thin (m : t) cl : + { entails (thin_clauses m) cl } + { ~ entails (thin_clauses m) cl }. +Proof. + destruct (check_gen (thin_clauses m) cl) eqn:ch. + - move/check_looping: ch; elim. + exists (model_of m). split. + { have dm := defined_model m. + eapply defined_model_of_subset; tea. + eapply defined_model_of_subset; tea. + intros ?; rewrite -clauses_levels_declared. + apply thin_clauses_levels. } + apply total_model_thin. + - move/check_invalid_entails: ch. intros ne. now right. + - move/check_gen_entails: ch. now left. +Qed. From 690ddcaf38cb48e75a85b70245d5c85d22c3d640 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 31 Oct 2025 18:02:54 +0100 Subject: [PATCH 113/164] Lift to checking whole set of clauses --- common/theories/LoopChecking/Deciders.v | 575 +++++++++++++----------- 1 file changed, 315 insertions(+), 260 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index baa1be98f..75a8e2cd2 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -326,8 +326,8 @@ Proof. rewrite clause_levels_spec. now right. Qed. -Equations check_gen (cls : clauses) (cl : clause) : check_result cls := -check_gen cls cl with inspect (loop_check cls cl) := +Equations check_entails (cls : clauses) (cl : clause) : check_result cls := +check_entails cls cl with inspect (loop_check cls cl) := { | exist (Loop v _ isl) he => IsLooping v _ isl | exist (Model W v _) he with inspect (LevelMap.find (concl cl).1 v.(model_model)) := { | exist (Some val) he' with check_atom_value (Some (concl cl).2) val := @@ -338,11 +338,11 @@ check_gen cls cl with inspect (loop_check cls cl) := }. (* If a clause checks, then it is entailed (and will be valid in any extension of the model) *) -Theorem check_gen_entails {cls cl} : - check_gen cls cl = Valid -> entails cls cl. +Theorem check_entails_entails {cls cl} : + check_entails cls cl = Valid -> entails cls cl. Proof. destruct cl as [prems [concl k]]. - funelim (check_gen cls _) => // _. + funelim (check_entails cls _) => // _. set (V := (clause_levels _ ∪ clauses_levels cls)%levels) in *. clear Heqcall H H0. cbn [concl fst snd] in *. move/check_atom_value_spec: Heq; intros h; depelim h. rename H into hgt. @@ -365,17 +365,17 @@ Proof. Qed. -Lemma check_gen_entails_looping {cls cl v vcls isl} : - check_gen cls cl = IsLooping v vcls isl -> cls ⊢a v → succ_prems v. +Lemma check_entails_entails_looping {cls cl v vcls isl} : + check_entails cls cl = IsLooping v vcls isl -> cls ⊢a v → succ_prems v. Proof. - funelim (check_gen cls cl) => //. + funelim (check_entails cls cl) => //. Qed. Lemma check_looping {cls cl v vcls isl} : - check_gen cls cl = IsLooping v vcls isl -> + check_entails cls cl = IsLooping v vcls isl -> ~ (exists m, defined_model_of (levels v) m /\ is_model m cls). Proof. - move/check_gen_entails_looping. + move/check_entails_entails_looping. intros loop [m' [en clssem]]. apply to_entails_all in loop. apply is_model_valid in clssem. @@ -386,7 +386,7 @@ Qed. Lemma check_valid_looping {cls cl m v vcls isl} : is_model m cls -> - check_gen cls cl = IsLooping v vcls isl -> + check_entails cls cl = IsLooping v vcls isl -> defined_model_of (levels v) m -> False. Proof. move=> ism. @@ -560,13 +560,13 @@ Proof. Qed. Theorem check_invalid {cls cl m} : - check_gen cls cl = Invalid m -> + check_entails cls cl = Invalid m -> [/\ is_model m cls, model_of (clauses_levels cls ∪ clause_levels cl) m, minimal_above cls (check_init_model cls cl) m, enabled_clause m cl & ~ valid_clause m cl]. Proof. - funelim (check_gen cls cl) => //. + funelim (check_entails cls cl) => //. clear H H0 he. set (V := (clause_levels cl ∪ clauses_levels cls)%levels) in *. destruct cl as [prems [concl k]]. @@ -811,7 +811,7 @@ Qed. Theorem check_invalid_inverse {cls cl mcheck} : - check_gen cls (checking_clause cl) = Invalid mcheck -> + check_entails cls (checking_clause cl) = Invalid mcheck -> is_model mcheck (inverse_clauses (checking_clause cl)). Proof. move/check_invalid => [ism mofm minm encl invcl]. @@ -821,7 +821,7 @@ Proof. Qed. Lemma check_invalid_entails {cls cl m} : - check_gen cls cl = Invalid m -> ~ entails cls cl. + check_entails cls cl = Invalid m -> ~ entails cls cl. Proof. move/check_invalid => [ism mof mabove en nv]. now move/entails_model_valid/(_ m ism). @@ -2264,7 +2264,7 @@ Lemma opt_valuation_of_model_equiv m l : Qed. Theorem check_invalid_valuation {cls cl m} : - check_gen cls cl = Invalid m -> + check_entails cls cl = Invalid m -> let v := opt_valuation_of_model m in [/\ positive_opt_valuation v, clauses_sem v cls, defined_valuation_of (clause_premises_levels cl) v & ~ clause_sem v cl]. @@ -2355,7 +2355,7 @@ Lemma opt_valuation_of_model_equiv m l : Lemma entails_dec (m : t) cl : { entails (clauses m) cl } + { ~ entails (clauses m) cl }. Proof. - destruct (check_gen (clauses m) cl) eqn:ch. + destruct (check_entails (clauses m) cl) eqn:ch. - move/check_looping: ch; elim. exists (model_of m). split. { have dm := defined_model m. @@ -2364,30 +2364,9 @@ Lemma opt_valuation_of_model_equiv m l : apply clauses_levels_declared. } exact: is_model_of m. - move/check_invalid_entails: ch. intros ne. now right. - - move/check_gen_entails: ch. now left. + - move/check_entails_entails: ch. now left. Qed. - Lemma entails_dec_clauses (m : t) cls : - { entails_clauses (clauses m) cls } + { ~ entails_clauses (clauses m) cls /\ - forall cl, Clauses.In cl cls -> - exists v : Level.t -> option Z, - [/\ positive_opt_valuation v, clauses_sem v (clauses m), defined_valuation_of (clause_premises_levels cl) v & ~ clause_sem v cl] }. - Proof. - Admitted. - (* destruct (check_gen (clauses m) cl) eqn:ch. - - move/check_looping: ch; elim. - exists (model_of m). split. - { have dm := defined_model m. - eapply defined_model_of_subset; tea. - eapply defined_model_of_subset; tea. - apply clauses_levels_declared. } - exact: is_model_of m. - - have ci := check_invalid_valuation ch. - move/check_invalid_entails: ch. intros ne. right. split => //. - - move/check_gen_entails: ch. now left. - Qed. - *) - Definition valid_clause_opt cls cl := forall v : Level.t -> option Z, positive_opt_valuation v -> @@ -2544,18 +2523,15 @@ Lemma opt_valuation_of_model_equiv m l : intros x; cbn. lia. Qed. - - - -Definition check_genb cls cl := - match check_gen cls cl with +Definition check_entailsb cls cl := + match check_entails cls cl with | IsLooping _ _ _ => false | Valid => true | Invalid _ => false end. -Lemma check_gen_model_looping m cl v vcls isl : - check_gen (clauses m) cl = IsLooping v vcls isl -> False. +Lemma check_entails_model_looping m cl v vcls isl : + check_entails (clauses m) cl = IsLooping v vcls isl -> False. Proof. intros. eapply check_valid_looping; tea. apply m.(model_valid).(model_ok). @@ -2567,29 +2543,29 @@ Proof. Qed. Lemma checkb_entails m cl : - check_genb (clauses m) cl <-> entails (clauses m) cl. + check_entailsb (clauses m) cl <-> entails (clauses m) cl. Proof. - unfold check_genb. - destruct (check_gen) eqn:ec. - - now move/check_gen_model_looping: ec. + unfold check_entailsb. + destruct (check_entails) eqn:ec. + - now move/check_entails_model_looping: ec. - split => //. now move/check_invalid_entails: ec. - - now move/check_gen_entails: ec. + - now move/check_entails_entails: ec. Qed. -Lemma check_gen_model m cl : - check_genb (clauses m) cl <-> +Lemma check_entails_model m cl : + check_entailsb (clauses m) cl <-> (forall m', is_model m' (clauses m) -> enabled_clause m' cl -> valid_clause m' cl). Proof. - unfold check_genb. - destruct (check_gen) eqn:ec. - - now move/check_gen_model_looping: ec. + unfold check_entailsb. + destruct (check_entails) eqn:ec. + - now move/check_entails_model_looping: ec. - split => //. move/check_invalid: ec. intros [ism mof hmin en inval]. move/(_ m0 ism en). contradiction. - split => // _. intros m' ism. - move/check_gen_entails: ec => ent. + move/check_entails_entails: ec => ent. intros _. eapply entails_model_valid; tea. Qed. @@ -2599,7 +2575,7 @@ Definition valid_model_clause m cl := Lemma entails_models m cl : entails (clauses m) cl <-> valid_model_clause m cl. Proof. - now rewrite -checkb_entails check_gen_model. + now rewrite -checkb_entails check_entails_model. Qed. Definition valid_all_model_clauses m cls := @@ -2636,32 +2612,32 @@ Qed. intros; red; eauto. - now rewrite -checkb_entails check_gen_model. + now rewrite -checkb_entails check_entails_model. Qed. *) -Lemma check_gen_exists_model m cl : - check_genb (clauses m) cl -> exists m', [/\ is_model m' (clauses m), enabled_clause m' cl & valid_clause m' cl]. +Lemma check_entails_exists_model m cl : + check_entailsb (clauses m) cl -> exists m', [/\ is_model m' (clauses m), enabled_clause m' cl & valid_clause m' cl]. Proof. - unfold check_genb. - funelim (check_gen (clauses m) cl) => // _. + unfold check_entailsb. + funelim (check_entails (clauses m) cl) => // _. clear H H0. symmetry in Heqcall. - move/check_gen_entails: Heqcall => ent. + move/check_entails_entails: Heqcall => ent. exists v.(model_model). split. apply model_ok. todo "enabled". eapply entails_model_valid; tea. apply model_ok. Qed. -Lemma check_gen_neg_exists_model m cl : - check_genb (clauses m) cl = false <-> +Lemma check_entails_neg_exists_model m cl : + check_entailsb (clauses m) cl = false <-> exists m', [/\ is_model m' (clauses m), enabled_clause m' cl & ~ valid_clause m' cl]. Proof. - unfold check_genb. - funelim (check_gen (clauses m) cl) => //. + unfold check_entailsb. + funelim (check_entails (clauses m) cl) => //. - clear H. symmetry in Heqcall. - now move/check_gen_model_looping: Heqcall. + now move/check_entails_model_looping: Heqcall. - clear H H0. symmetry in Heqcall. split => //. - move/check_gen_entails: Heqcall => ent. + move/check_entails_entails: Heqcall => ent. intros [m' []]; exfalso. eapply entails_model_valid in ent; tea. contradiction. - clear H H0. symmetry in Heqcall. split => //. @@ -2677,12 +2653,9 @@ Lemma nentails_model m cl : Proof. rewrite -checkb_entails. rewrite negb_iff /is_true negb_true_iff. - apply check_gen_neg_exists_model. + apply check_entails_neg_exists_model. Qed. -Definition check_clause m cl := - check_genb (clauses m) (checking_clause cl). - Definition consistent_clauses cls := exists val : Level.t -> Z, positive_valuation val /\ clauses_sem val cls. @@ -2737,9 +2710,8 @@ Proof. Qed. Lemma check_clause_invalid_Zinf m mcheck cl : - check_gen (clauses m) cl = Invalid mcheck -> ~ valid_clause_Zinf (clauses m) cl. + check_entails (clauses m) cl = Invalid mcheck -> ~ valid_clause_Zinf (clauses m) cl. Proof. - unfold check_clause. move/check_invalid_valuation => [vpos csem hdef clsem]. now move=> /(_ (opt_valuation_of_model mcheck) vpos csem). Qed. @@ -2811,7 +2783,6 @@ Lemma consistent_clauses_dec (m : t) cls : clauses_levels cls ⊂_lset levels m -> { m' | clauses m' =_clset Clauses.union (clauses m) cls } + (* consistent *) { ~ exists m', clauses m' =_clset (Clauses.union (clauses m) cls) }. - (* { exists cl, Clauses.In cl cls /\ consistent (Clauses.union (clauses m) (inverse_clauses cl)) }. *) Proof. intros hwf. destruct (enforce_clauses m cls) eqn:hl. @@ -2826,17 +2797,17 @@ Proof. - now move/enforce_clauses_None: hl. Qed. -Definition check_clauses (cls : Clauses.t) (cls' : Clauses.t) : bool := - Clauses.for_all (check_genb cls) cls'. +Definition check_entails_clauses (cls : Clauses.t) (cls' : Clauses.t) : bool := + Clauses.for_all (check_entailsb cls) cls'. -Lemma check_clauses_spec m cls' : - check_clauses (clauses m) cls' <-> clauses m ⊢ℋ cls'. +Lemma check_entails_clauses_spec m cls' : + check_entails_clauses (clauses m) cls' <-> clauses m ⊢ℋ cls'. Proof. - rewrite /check_clauses. + rewrite /check_entails_clauses. rewrite [is_true _]Clauses.for_all_spec. split. move=> ha cl /ha. - rewrite -/(is_true (check_genb (clauses m) cl)). + rewrite -/(is_true (check_entailsb (clauses m) cl)). now rewrite checkb_entails. move=> hent cl /hent. now rewrite -checkb_entails. @@ -2888,7 +2859,12 @@ Proof. apply LevelExprSet.singleton_spec in hadd. red in hadd. congruence. Qed. - +(** Due to the possible models of entailments in arbitrary semilattices + with an inflationary and injective endomorphism, one cannot rule out + models where + is the identity, hence the following counterexamples: + a clause can be declared invalid by checking while it is valid + when considering only models in (Z, max, +). +*) Module CounterExample1. (* x ∨ y -> y + 1 *) Definition valid_Z_counterexample_cls (x y : Level.t) : clause := @@ -2902,7 +2878,7 @@ Example check_clause_invalid_Z_counterexample (x y : Level.t) : x <> y -> let cls := Clauses.singleton (valid_Z_counterexample_cls x y) in let cl := valid_Z_counterexample_cl x y in - exists mcheck, check_gen cls cl = Invalid mcheck /\ valid_clause_Z cls cl. + exists mcheck, check_entails cls cl = Invalid mcheck /\ valid_clause_Z cls cl. Proof. move=> hdiff cls cl. set (v := (fun l : Level.t => if eqb l x then 1 else 0)%Z). @@ -2915,8 +2891,8 @@ Proof. have hcon : consistent cls. { exists v. split => //. intros l. unfold v. case: eqb_spec => //. } - destruct check_gen eqn:ec. - - move/check_gen_entails_looping: ec. + destruct check_entails eqn:ec. + - move/check_entails_entails_looping: ec. move/consistent_no_loop. contradiction. - exists m. split => //. intros v' vpos csem. @@ -2924,7 +2900,7 @@ Proof. rewrite interp_nes_singleton //=. move: (csem (valid_Z_counterexample_cls x y)) => /fwd. now eapply Clauses.singleton_spec. cbn. rewrite !interp_nes_union !interp_nes_singleton //=. lia. - - exfalso. move/check_gen_entails: ec. + - exfalso. move/check_entails_entails: ec. rewrite entails_completeness. intros ent. set (vopt := (fun l : Level.t => if eqb l x then Some 0 else None)%Z). @@ -2944,7 +2920,7 @@ Example check_clause_checking_invalid_Z_example (x y : Level.t) : x <> y -> let cls := Clauses.singleton (valid_Z_counterexample_cls x y) in let cl := valid_Z_counterexample_cl x y in - check_gen cls (checking_clause cl) = Valid. + check_entails cls (checking_clause cl) = Valid. Proof. move=> hdiff cls cl. set (v := (fun l : Level.t => if eqb l x then 1 else 0)%Z). @@ -2957,8 +2933,8 @@ Proof. have hcon : consistent cls. { exists v. split => //. intros l. unfold v. case: eqb_spec => //. } - destruct check_gen eqn:ec. - - move/check_gen_entails_looping: ec. + destruct check_entails eqn:ec. + - move/check_entails_entails_looping: ec. move/consistent_no_loop. contradiction. - exfalso. move/check_invalid_entails: ec. apply. apply entails_completeness. @@ -2986,7 +2962,7 @@ Example check_clause_invalid_Z_counterexample (x y : Level.t) : x <> y -> let cls := Clauses.singleton (valid_Z_counterexample_cls x y) in let cl := valid_Z_counterexample_cl x y in - exists mcheck, check_gen cls cl = Invalid mcheck /\ valid_clause_Z cls cl. + exists mcheck, check_entails cls cl = Invalid mcheck /\ valid_clause_Z cls cl. Proof. move=> hdiff cls cl. set (v := (fun l : Level.t => if eqb l x then 1 else 0)%Z). @@ -2999,8 +2975,8 @@ Proof. have hcon : consistent cls. { exists v. split => //. intros l. unfold v. case: eqb_spec => //. } - destruct check_gen eqn:ec. - - move/check_gen_entails_looping: ec. + destruct check_entails eqn:ec. + - move/check_entails_entails_looping: ec. move/consistent_no_loop. contradiction. - exists m. split => //. intros v' vpos csem. @@ -3008,7 +2984,7 @@ Proof. rewrite interp_nes_singleton //=. move: (csem (valid_Z_counterexample_cls x y)) => /fwd. now eapply Clauses.singleton_spec. cbn. rewrite !interp_nes_union !interp_nes_singleton //=. lia. - - exfalso. move/check_gen_entails: ec. + - exfalso. move/check_entails_entails: ec. rewrite entails_completeness. intros ent. set (vopt := (fun l : Level.t => if eqb l x then Some 0 else None)%Z). @@ -3028,7 +3004,7 @@ Example check_clause_checking_invalid_Z_example (x y : Level.t) : x <> y -> let cls := Clauses.singleton (valid_Z_counterexample_cls x y) in let cl := valid_Z_counterexample_cl x y in - check_gen cls (checking_clause cl) = Valid. + check_entails cls (checking_clause cl) = Valid. Proof. move=> hdiff cls cl. set (v := (fun l : Level.t => if eqb l x then 1 else 0)%Z). @@ -3041,8 +3017,8 @@ Proof. have hcon : consistent cls. { exists v. split => //. intros l. unfold v. case: eqb_spec => //. } - destruct check_gen eqn:ec. - - move/check_gen_entails_looping: ec. + destruct check_entails eqn:ec. + - move/check_entails_entails_looping: ec. move/consistent_no_loop. contradiction. - exfalso. move/check_invalid_entails: ec. apply. apply entails_completeness. @@ -3211,15 +3187,71 @@ Proof. intros hs. now rewrite clause_levels_inverse. Qed. -Equations check_clause_enf m cl (wf : clause_levels cl ⊂_lset levels m) : bool := - check_clause_enf m cl wf with enforce_dec m (inverse_clauses cl) (inverse_clauses_levels wf) := +Lemma check_entails_valid_Z m cl : + check_entailsb (clauses m) cl -> valid_clause_Z (clauses m) cl. +Proof. + rewrite checkb_entails. + move=> ent v posv csem. + apply entails_completeness in ent. + red in ent. + now move: {ent}(ent Z _ v csem). +Qed. + +Definition consistent_clauses_model cls := + exists m, Model.enabled_clauses m cls /\ is_model m cls. + +Lemma consistent_model m : consistent_clauses_model (clauses m). +Proof. + exists (model m). split. + eapply model_enabled. + apply model_ok. +Qed. + +Lemma check_entails_clauses_gen_spec cls cls' : + consistent_clauses_model cls -> + check_entails_clauses cls cls' <-> entails_clauses cls cls'. +Proof. + intros hcon. + split. + - rewrite /check_entails_clauses. + move/Clauses.for_all_spec => ha cl /ha. + unfold check_entailsb; destruct check_entails eqn:hc => //. + now move/check_entails_entails: hc. + - intros hv. + rewrite /check_entails_clauses /check_entailsb. + eapply Clauses.for_all_spec; tc => cl hin. + destruct check_entails eqn:hc => //. + * exfalso. destruct hcon as [m [en ism]]. + eapply check_entails_entails_looping in hc; tea. + eapply model_entails_succ in hc; tea. + * move/check_invalid_entails: hc => he. + exfalso. elim he. now apply hv. +Qed. + + +Equations check_clause_wf m cl (wf : clause_levels cl ⊂_lset levels m) : bool := + check_clause_wf m cl wf with enforce_dec m (inverse_clauses cl) (inverse_clauses_levels wf) := | left con => false | right incon => true. -Lemma check_clause_enf_invalid m cl wf : - check_clause_enf m cl wf = false -> ~ valid_clause_Z (clauses m) cl. +Equations? check_clause (m : t) (cl : clause) : option bool := + check_clause m cl with inspect (LevelSet.subset (clause_levels cl) (levels m)) := + | exist true hl => Some (check_clause_wf m cl _) + | exist false _ => None. +Proof. apply LevelSet.subset_spec in hl; now apply hl. Qed. + +Definition check_clauses m (cls : Clauses.t) : option bool := + Clauses.fold (fun cl acc => + match acc with + | None => None + | Some false => acc + | Some true => check_clause m cl + end) cls (Some true). + +Lemma check_clause_invalid m cl wf : + check_clause_wf m cl wf = false -> ~ valid_clause_Z (clauses m) cl. Proof. - unfold check_clause_enf. + unfold check_clause_wf. destruct (enforce_dec m (inverse_clauses cl)) => //= _. intros inv. destruct c as [v [vpos csem]]. specialize (inv v vpos). @@ -3228,24 +3260,10 @@ Proof. apply neg_inverse_Z in clsem. contradiction. Qed. -Lemma ntot_forall {m cl} : - (~ exists m' : Model.model, - is_total_model m' (Clauses.union (clauses m) (inverse_clauses cl))) -> - forall m' : Model.model, - is_total_model m' (clauses m) -> - enabled_clauses m' (inverse_clauses cl) -> - ~ valid_clauses m' (inverse_clauses cl). +Lemma check_clause_valid m cl wf : + check_clause_wf m cl wf -> valid_clause_Z (clauses m) cl. Proof. - intros ne m' ist en hv. - apply ne. exists m'. apply is_total_model_union. split => //. - split => //. - now eapply is_modelP. -Qed. - -Lemma check_clause_enf_valid m cl wf : - check_clause_enf m cl wf -> valid_clause_Z (clauses m) cl. -Proof. - unfold check_clause_enf. + unfold check_clause_wf. destruct (enforce_dec m (inverse_clauses cl)) => //= _ v vpos csem. red in i. destruct i as [loop [hincl hloop]]. have nev : ~ exists v, positive_valuation v /\ clauses_sem v (Clauses.union (clauses m) (inverse_clauses cl)). @@ -3260,171 +3278,208 @@ Proof. apply clauses_sem_union. split => //. Qed. -Lemma check_clause_enf_spec m cl wf : - check_clause_enf m cl wf <-> valid_clause_Z (clauses m) cl. +Lemma check_clause_wf_spec m cl wf : + check_clause_wf m cl wf <-> valid_clause_Z (clauses m) cl. Proof. - destruct (check_clause_enf m cl) eqn:ec. + destruct (check_clause_wf m cl) eqn:ec. - split => // _. - now apply check_clause_enf_valid in ec. + now apply check_clause_valid in ec. - split => // hv. - apply check_clause_enf_invalid in ec. + apply check_clause_invalid in ec. contradiction. Qed. -Lemma check_clause_valid_Z m cl : - check_clause m cl -> valid_clause_Z (clauses m) cl. +Lemma check_clause_undeclared m cl : + check_clause m cl = None <-> ~ clause_levels cl ⊂_lset (levels m). Proof. - unfold check_clause. - rewrite checkb_entails. - move=> ent v posv csem. - apply entails_completeness in ent. - red in ent. - move: {ent}(ent Z _ v csem). - destruct cl as [prems [concl k]]. - rewrite //= !interp_nes_union interp_nes_singleton //= /interp_expr //=. - lia. + funelim (check_clause m cl) => //. + - split => //. intros ne; exfalso. clear H Heqcall. + apply LevelSet.subset_spec in hl. contradiction. + - split => // _ hincl. + apply LevelSet.subset_spec in hincl. congruence. Qed. -Definition consistent_clauses_model cls := - exists m, Model.enabled_clauses m cls /\ is_model m cls. - -Lemma consistent_model m : consistent_clauses_model (clauses m). +Lemma check_clause_spec m cl : + forall b, check_clause m cl = Some b -> + b <-> valid_clause_Z (clauses m) cl. Proof. - exists (model m). split. - eapply model_enabled. - apply model_ok. + funelim (check_clause m cl) => //. + clear H Heqcall. intros b [= <-]. + apply check_clause_wf_spec. Qed. +Print reflect. +Inductive reflect_opt (PN PS : Prop) : option bool -> Prop := + | ReflectNone : PN -> reflect_opt PN PS None + | ReflectSomeT : PS -> reflect_opt PN PS (Some true) + | ReflectSomeF : ~ PS -> reflect_opt PN PS (Some false). +Derive Signature for reflect_opt. -Lemma check_clauses_gen_spec cls cls' : - consistent_clauses_model cls -> - check_clauses cls cls' <-> entails_clauses cls cls'. +Lemma check_clauseP {m cl} : reflect_opt + (~ clause_levels cl ⊂_lset (levels m)) + (valid_clause_Z (clauses m) cl) + (check_clause m cl). Proof. - intros hcon. - split. - - rewrite /check_clauses. - move/Clauses.for_all_spec => ha cl /ha. - unfold check_genb; destruct check_gen eqn:hc => //. - now move/check_gen_entails: hc. - - intros hv. - rewrite /check_clauses /check_genb. - eapply Clauses.for_all_spec; tc => cl hin. - destruct check_gen eqn:hc => //. - * exfalso. destruct hcon as [m [en ism]]. - eapply check_gen_entails_looping in hc; tea. - eapply model_entails_succ in hc; tea. - * move/check_invalid_entails: hc => he. - exfalso. elim he. now apply hv. + destruct (check_clause m cl) as [b|] eqn:ec. + - apply check_clause_spec in ec. + destruct b; constructor; try apply ec => //. + destruct ec. now move/H0. + - constructor. now apply check_clause_undeclared. Qed. - -Definition check_model_clauses m cls := - check_clauses (clauses m) cls. - -Lemma check_model_clauses_entails m cls : - check_model_clauses m cls <-> entails_clauses (clauses m) cls. -Proof. - rewrite check_clauses_gen_spec //. +Definition valid_clauses cls cls' := + forall v : Level.t -> Z, + positive_valuation v -> + clauses_sem v cls -> clauses_sem v cls'. + +Lemma check_clausesP {m cls} : reflect_opt + (~ clauses_levels cls ⊂_lset (levels m)) + (valid_clauses (clauses m) cls) + (check_clauses m cls). +Proof. + unfold check_clauses. + eapply ClausesProp.fold_rec. + - intros s' he. constructor. + now move=> v vpos csem cl /he. + - intros x a s' s'' hin hnin hadd ih. + destruct a => //. + depelim ih. + * elim: (@check_clauseP m x). + { move=> hdecl. constructor => hincl. + apply hdecl. rewrite -hincl. + red in hadd. + have hcl := clauses_levels_mon (Clauses.singleton x) s''. + rewrite -hcl => l. rewrite hadd. + rewrite Clauses.singleton_spec. intros; now left. + rewrite clauses_levels_spec => hin'. exists x; split => //. clsets. } + { move=> hv. constructor. intros v vpos csem. + specialize (H v vpos csem). + specialize (hv v vpos csem). + move=> cl /hadd -[]. + now intros ->. apply H. } + { move=> hv. constructor. intros inv. + apply hv => v vpos csem. apply (inv v vpos csem x). + apply hadd. now left. } + * constructor. intros inv. + apply H => v vpos csem. specialize (inv v vpos csem). + move=> cl hin'. specialize (hadd cl). + destruct hadd. forward H1. now right. + now apply inv. + * constructor. depelim ih. + move=> hincl. apply H. + rewrite -hincl. + eapply clauses_levels_mon. + intros cl; rewrite (hadd cl). + now right. +Qed. + +Definition check_entails_model_clauses m cls := + check_entails_clauses (clauses m) cls. + +Lemma check_entails_model_clauses_entails m cls : + check_entails_model_clauses m cls <-> entails_clauses (clauses m) cls. +Proof. + rewrite check_entails_clauses_gen_spec //. apply consistent_model. Qed. -Theorem check_spec m cl : +Theorem check_entailsb_spec m cl : clause_levels cl ⊂_lset levels m -> - check_clause m cl -> valid_clause_Z (clauses m) cl. + check_entailsb (clauses m) cl -> valid_clause_Z (clauses m) cl. Proof. - move=> hwf; apply check_clause_valid_Z. + move=> hwf; apply check_entails_valid_Z. Qed. - Definition valid_clauses cls cls' := - forall v : Level.t -> option Z, - positive_opt_valuation v -> - clauses_sem v cls -> clauses_sem v cls'. +Definition valid_clauses_inf cls cls' := + forall v : Level.t -> option Z, + positive_opt_valuation v -> + clauses_sem v cls -> clauses_sem v cls'. - Lemma check_clauses_complete m cls : - check_model_clauses m cls <-> valid_entailments (clauses m) cls. - Proof. - rewrite check_model_clauses_entails. +Lemma check_entails_clauses_complete m cls : + check_entails_model_clauses m cls <-> valid_entailments (clauses m) cls. +Proof. + rewrite check_entails_model_clauses_entails. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -completeness_all. + split. + - move=> vr s sl v. + move: (vr _ sl v). + rewrite !interp_rels_clauses_sem //. + - intros ve S s v. + move: (ve S s v). + now rewrite //= !interp_rels_clauses_sem. +Qed. + +Lemma check_entails_clauses_Z_positive_complete m cls : + check_entails_model_clauses m cls <-> valid_clauses_inf (clauses m) cls. +Proof. + split. + - rewrite check_entails_model_clauses_entails. rewrite -entails_L_entails_ℋ_equiv. rewrite -entails_L_rels_entails_L_clauses. rewrite -completeness_all. - split. - - move=> vr s sl v. - move: (vr _ sl v). - rewrite !interp_rels_clauses_sem //. - - intros ve S s v. - move: (ve S s v). - now rewrite //= !interp_rels_clauses_sem. - Qed. - - Lemma check_clauses_Z_positive_complete m cls : - check_model_clauses m cls <-> valid_clauses (clauses m) cls. - Proof. - split. - - rewrite check_model_clauses_entails. + move=> vr v. + red in vr. + move: (vr (option Z) Zopt_semi v). + rewrite !interp_rels_clauses_sem //. + - intros sem. unfold check_entails_model_clauses. + eapply Clauses.for_all_spec. tc. + move=> cl /sem => semcl. + unfold check_entailsb. + destruct check_entails eqn:hc => //. + * move/check_entails_entails_looping : hc. + rewrite -to_entails_all. rewrite -entails_L_entails_ℋ_equiv. rewrite -entails_L_rels_entails_L_clauses. - rewrite -completeness_all. - move=> vr v. - red in vr. - move: (vr (option Z) Zopt_semi v). - rewrite !interp_rels_clauses_sem //. - - intros sem. unfold check_model_clauses. - eapply Clauses.for_all_spec. tc. - move=> cl /sem => semcl. - unfold check_genb. - destruct check_gen eqn:hc => //. - * move/check_gen_entails_looping : hc. - rewrite -to_entails_all. - rewrite -entails_L_entails_ℋ_equiv. - rewrite -entails_L_rels_entails_L_clauses. - rewrite -ISL.completeness_all. - move/(_ Z _ (Z_valuation_of_model m)). - rewrite -interp_rels_clauses_sem. - move/(_ (model_valuation m)). - rewrite -interp_rels_clauses_sem. - rewrite clauses_sem_leq. cbn. - rewrite interp_add_prems //=. lia. - * move/check_invalid_valuation: hc. - move=> [hpos semcls def ncl]. specialize (semcl _ hpos semcls). - now elim ncl. - Qed. - - Lemma check_clauses_Z_complete m cls : - check_model_clauses m cls <-> valid_semilattice_entailments Zopt_semi (clauses m) cls. - Proof. - split. - - rewrite check_model_clauses_entails. + rewrite -ISL.completeness_all. + move/(_ Z _ (Z_valuation_of_model m)). + rewrite -interp_rels_clauses_sem. + move/(_ (model_valuation m)). + rewrite -interp_rels_clauses_sem. + rewrite clauses_sem_leq. cbn. + rewrite interp_add_prems //=. lia. + * move/check_invalid_valuation: hc. + move=> [hpos semcls def ncl]. specialize (semcl _ hpos semcls). + now elim ncl. +Qed. + +Lemma check_entails_clauses_Z_complete m cls : + check_entails_model_clauses m cls <-> valid_semilattice_entailments Zopt_semi (clauses m) cls. +Proof. + split. + - rewrite check_entails_model_clauses_entails. + rewrite -entails_L_entails_ℋ_equiv. + rewrite -entails_L_rels_entails_L_clauses. + rewrite -completeness_all. + move=> vr v. + red in vr. + move: (vr (option Z) Zopt_semi v). + rewrite !interp_rels_clauses_sem //. + - intros sem. unfold check_entails_model_clauses, check_entails_clauses. + eapply Clauses.for_all_spec. tc. + move=> cl /sem => semcl. + unfold check_entailsb; destruct check_entails eqn:hc => //. + * move/check_entails_entails_looping : hc. + rewrite -to_entails_all. rewrite -entails_L_entails_ℋ_equiv. rewrite -entails_L_rels_entails_L_clauses. - rewrite -completeness_all. - move=> vr v. - red in vr. - move: (vr (option Z) Zopt_semi v). - rewrite !interp_rels_clauses_sem //. - - intros sem. unfold check_model_clauses, check_clauses. - eapply Clauses.for_all_spec. tc. - move=> cl /sem => semcl. - unfold check_genb; destruct check_gen eqn:hc => //. - * move/check_gen_entails_looping : hc. - rewrite -to_entails_all. - rewrite -entails_L_entails_ℋ_equiv. - rewrite -entails_L_rels_entails_L_clauses. - rewrite -ISL.completeness_all. - move/(_ Z _ (Z_valuation_of_model m)). - rewrite -interp_rels_clauses_sem. - move/(_ (model_valuation m)). - rewrite -interp_rels_clauses_sem. - rewrite clauses_sem_leq. cbn. - rewrite interp_add_prems //=. lia. - * move/check_invalid_valuation: hc. - move=> [_ semcls def ncl]. specialize (semcl (opt_valuation_of_model m0)). elim ncl; now apply semcl. - Qed. - - Definition pred (le : LevelExpr.t) := (le.1, le.2 - 1). - - Lemma nRopt {A} (x y : A) : ~ R_opt Logic.eq (Some x) (Some y) -> x <> y. - Proof. - intros hr heq. apply hr. now cbn. - Qed. + rewrite -ISL.completeness_all. + move/(_ Z _ (Z_valuation_of_model m)). + rewrite -interp_rels_clauses_sem. + move/(_ (model_valuation m)). + rewrite -interp_rels_clauses_sem. + rewrite clauses_sem_leq. cbn. + rewrite interp_add_prems //=. lia. + * move/check_invalid_valuation: hc. + move=> [_ semcls def ncl]. specialize (semcl (opt_valuation_of_model m0)). elim ncl; now apply semcl. +Qed. + +Definition pred (le : LevelExpr.t) := (le.1, le.2 - 1). + +Lemma nRopt {A} (x y : A) : ~ R_opt Logic.eq (Some x) (Some y) -> x <> y. +Proof. + intros hr heq. apply hr. now cbn. +Qed. End Abstract. End Deciders. @@ -3558,26 +3613,26 @@ Module LoopChecking (LS : LevelSets). Returns false if the constraint results in an inconsistent set of constraints or it simply is not valid. *) Definition check m c := - check_model_clauses m (to_clauses c). + check_entails_model_clauses m (to_clauses c). (* Checking corresponds to entailment in the free semilattice *) Lemma check_spec {m c} : check m c <-> entails_clauses (clauses m) (to_clauses c). - Proof. apply check_model_clauses_entails. Qed. + Proof. apply check_entails_model_clauses_entails. Qed. (* Checking corresponds to validity in *all* semilattices, including degenerate ones. *) Lemma check_complete m c : check m c <-> valid_entailments (clauses m) (to_clauses c). - Proof. apply check_clauses_complete. Qed. + Proof. apply check_entails_clauses_complete. Qed. (* Checking corresponds to validity in the lifted Z semilattice. *) Lemma check_Z_complete m c : check m c <-> valid_semilattice_entailments Zopt_semi (clauses m) (to_clauses c). - Proof. apply check_clauses_Z_complete. Qed. + Proof. apply check_entails_clauses_Z_complete. Qed. Lemma check_Z_complete_positive m c : check m c <-> valid_clauses (clauses m) (to_clauses c). - Proof. apply check_clauses_Z_positive_complete. Qed. + Proof. apply check_entails_clauses_Z_positive_complete. Qed. Lemma zero_declared m : Impl.zero_declared (model m). Proof. eapply zero_declared. Qed. From be888a6c06c2c163943051b54a47e93d39d6dac7 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 1 Nov 2025 18:30:49 +0100 Subject: [PATCH 114/164] Show that check is complete for validity in nat --- common/theories/LoopChecking/Deciders.v | 76 ++++++++++--- .../theories/LoopChecking/UnivLoopChecking.v | 103 +++++++++++++++--- template-rocq/theories/Junk.v | 18 +++ 3 files changed, 164 insertions(+), 33 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 75a8e2cd2..555668d03 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -3382,11 +3382,30 @@ Proof. apply consistent_model. Qed. + +Equations? check_clauses_wf m cls (wf : clauses_levels cls ⊂_lset levels m) : bool := + check_clauses_wf m cls wf with inspect (check_clauses m cls) := + | exist None heq := False_rect _ _ + | exist (Some b) heq => b. +Proof. + move: heq; elim: check_clausesP => //. +Qed. + +Lemma check_clauses_spec m cls (wf : clauses_levels cls ⊂_lset (levels m)) : + check_clauses_wf m cls wf <-> valid_clauses_Z (clauses m) cls. +Proof. + funelim (check_clauses_wf m cls wf) => //. + clear H Heqcall. + move: heq; elim: check_clausesP => //. + - intros vc [= <-]. split => //. + - intros inv [= <-]. split => //. + - bang. +Qed. + Theorem check_entailsb_spec m cl : - clause_levels cl ⊂_lset levels m -> check_entailsb (clauses m) cl -> valid_clause_Z (clauses m) cl. Proof. - move=> hwf; apply check_entails_valid_Z. + apply check_entails_valid_Z. Qed. Definition valid_clauses_inf cls cls' := @@ -3602,36 +3621,63 @@ Module LoopChecking (LS : LevelSets). Definition valid_entailments cls cls' := forall S (SL : Semilattice.Semilattice S Q.t) (V : Level.t -> S), clauses_sem V cls -> clauses_sem V cls'. - (* Definition check m c : - clause_levels (to_clauses c) ⊂_lset levels m -> - { valid_clauses_Z (clauses m) (to_clauses c) } + { ~ valid_clauses_Z (clauses m) (to_clauses c) } := - Impl.check m.(Impl.Abstract.clauses) (to_clauses c). *) + Definition check_wf m cls (wf : clauses_levels cls ⊂_lset levels m) := + check_clauses_wf m cls wf. + + Lemma check_wfP m c wf : check_wf m c wf <-> valid_clauses_Z (clauses m) c. + Proof. + apply check_clauses_spec. + Qed. + + Definition check m cls := + match check_clauses m cls with + | None => false + | Some b => b + end. + + Lemma check_spec m cls : + clauses_levels cls ⊂_lset levels m -> + check m cls <-> valid_clauses_Z (clauses m) cls. + Proof. + intros hwf. + rewrite /check. + elim: check_clausesP; intuition. + Qed. + + Definition check_constraint m c := check m (to_clauses c). + Lemma check_constraintS m c : + clauses_levels (to_clauses c) ⊂_lset levels m -> + check_constraint m c <-> valid_clauses_Z (clauses m) (to_clauses c). + Proof. + apply check_spec. + Qed. + (** Entailment is weaker than validity in Z: it is equivalent to validity in Z^∞ *) (* Returns true is the constraint is valid in the model and all its possible consistent extensions. Returns false if the constraint results in an inconsistent set of constraints or it simply is not valid. *) - Definition check m c := + Definition check_entails m c := check_entails_model_clauses m (to_clauses c). (* Checking corresponds to entailment in the free semilattice *) - Lemma check_spec {m c} : - check m c <-> entails_clauses (clauses m) (to_clauses c). + Lemma check_entails_spec {m c} : + check_entails m c <-> entails_clauses (clauses m) (to_clauses c). Proof. apply check_entails_model_clauses_entails. Qed. (* Checking corresponds to validity in *all* semilattices, including degenerate ones. *) - Lemma check_complete m c : - check m c <-> valid_entailments (clauses m) (to_clauses c). + Lemma check_entails_complete m c : + check_entails m c <-> valid_entailments (clauses m) (to_clauses c). Proof. apply check_entails_clauses_complete. Qed. - (* Checking corresponds to validity in the lifted Z semilattice. *) - Lemma check_Z_complete m c : - check m c <-> valid_semilattice_entailments Zopt_semi (clauses m) (to_clauses c). + (* Checking corresponds to validity in the Z^∞ semilattice. *) + Lemma check_entails_Z_complete m c : + check_entails m c <-> valid_semilattice_entailments Zopt_semi (clauses m) (to_clauses c). Proof. apply check_entails_clauses_Z_complete. Qed. Lemma check_Z_complete_positive m c : - check m c <-> valid_clauses (clauses m) (to_clauses c). + check_entails m c <-> valid_clauses_inf (clauses m) (to_clauses c). Proof. apply check_entails_clauses_Z_positive_complete. Qed. Lemma zero_declared m : Impl.zero_declared (model m). diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 01c6b4358..4fb9580b1 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -1645,10 +1645,8 @@ End ZUnivConstraint. - intros x y. rewrite interp_nes_union; cbn. lia. Qed. - - Definition check (m : univ_model) (c : UnivConstraint.t) : bool := - LoopCheck.check m.(UnivLoopChecking.model) (to_constraint c). + LoopCheck.check_constraint m.(UnivLoopChecking.model) (to_constraint c). Derive Signature for satisfies0. @@ -1793,25 +1791,97 @@ End ZUnivConstraint. Instance nat_opt_semi : Semilattice (option nat) nat := opt_semi Natsemilattice. Definition valid_Z_model m c := - (forall (v : Level.t -> option Z), positive_opt_valuation v -> interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c). + forall (v : Level.t -> Z), + positive_valuation v -> + interp_univ_cstrs v (constraints m) -> interp_univ_cstr v c. Infix "⊩Z" := valid_Z_model (at level 70, no associativity). - Definition defined_valuation_of V (v : Level.t -> option nat) := - forall l, LevelSet.In l V -> exists x, v l = Some x. + Definition to_nat_val (v : Level.t -> Z) := + fun l => Z.to_nat (v l). Definition valid_nat_model m c := - (forall (v : Level.t -> option nat), defined_valuation_of (UnivLoopChecking.levels m ∪ univ_constraint_levels c) v -> - interp_cstrs v (constraints m) -> interp_nat_cstr v c). + forall (v : Level.t -> nat), + interp_cstrs v (constraints m) -> interp_nat_cstr v c. + + Infix "⊩𝐍" := valid_nat_model (at level 70, no associativity). + + Section InterpNatZ. + Context (v : Level.t -> Z). + Context (v' : Level.t -> nat). + Context (hv : forall l, v l = Z.of_nat (v' l)). +Print interp_z_cstr. + + Lemma interp_nes_equiv u : interp_nes v (to_atoms u) = Z.of_nat (Universe.interp_nes v' u). + Proof. + move: u; apply: Universe.elim. + - intros [l k]. rewrite to_atoms_singleton + interp_nes_singleton Universe.interp_nes_singleton /interp_expr //=. + rewrite (hv l). lia. + - intros [l k] u he hnin. + rewrite to_atoms_add + interp_nes_add Universe.interp_nes_add /interp_expr //= he. + rewrite (hv l). lia. + Qed. - Theorem check_completeness {m c} : + Lemma interp_cstr_to_nat c : + interp_nat_cstr v' c <-> interp_univ_cstr v c. + Proof. + destruct c as [[l []] r]; cbn; + rewrite !interp_nes_equiv; lia. + Qed. + + Lemma interp_cstrs_to_nat cstrs : + interp_cstrs v' cstrs <-> interp_univ_cstrs v cstrs. + Proof. + rewrite /interp_cstrs /interp_univ_cstrs. + split; now move=> hf c /hf /interp_cstr_to_nat. + Qed. + End InterpNatZ. + + Lemma valid_Z_valid_nat_model m c : + valid_nat_model m c <-> valid_Z_model m c. + Proof. + split; intros hv v. + - intros vpos. + specialize (hv (to_nat_val v)). + rewrite -(interp_cstrs_to_nat v (to_nat_val v)). + rewrite /to_nat_val. intros l. + specialize (vpos l). lia. + rewrite -(interp_cstr_to_nat v (to_nat_val v)). + rewrite /to_nat_val. intros l. + specialize (vpos l). lia. + exact hv. + - rewrite (interp_cstrs_to_nat (to_Z_val v)) //. + rewrite (interp_cstr_to_nat (to_Z_val v)) //. + move: (hv (to_Z_val v)) => /fwd //. + intros l; rewrite /to_Z_val. lia. + Qed. + + Definition defined_valuation_of V (v : Level.t -> option nat) := + forall l, LevelSet.In l V -> exists x, v l = Some x. + + Theorem check_completeness {m : univ_model} {c} : + declared_univ_cstr_levels (levels m) c -> check m c <-> m ⊩Z c. Proof. - rewrite LoopCheck.check_Z_complete_positive /valid_Z_model. + intros hwf. + rewrite check_constraintS. + now eapply ndecl_nin_levels in hwf. + rewrite /valid_clauses_Z /valid_Z_model. setoid_rewrite interp_cstrs_clauses_sem; setoid_rewrite interp_cstr_clauses_sem. rewrite /valid_clauses. reflexivity. Qed. + Theorem check_nat_completeness {m : univ_model} {c} : + declared_univ_cstr_levels (levels m) c -> + check m c <-> m ⊩𝐍 c. + Proof. + intros hwf. + rewrite check_completeness //. + now rewrite valid_Z_valid_nat_model. + Qed. + Lemma interp_univ_cstrs_of_m m : interp_univ_cstrs (model_opt_val m) (constraints m). Proof. @@ -1833,10 +1903,10 @@ End ZUnivConstraint. Infix "⊩" := valid_model (at level 70, no associativity). - Theorem check_any_completeness {m c} : - check m c <-> m ⊩ c. + Theorem check_any_completeness {m : univ_model} {c} : + check_entails (model m) (to_constraint c) <-> m ⊩ c. Proof. - rewrite LoopCheck.check_complete /LoopCheck.valid_entailments /valid_model. + rewrite LoopCheck.check_entails_complete /LoopCheck.valid_entailments /valid_model. setoid_rewrite interp_cstrs_clauses_sem. split. - intros hv S s v hp. @@ -1892,11 +1962,8 @@ End ZUnivConstraint. apply constraint_levels_declared. Qed. - Definition to_nat_val (v : Level.t -> option Z) := - fun l => Z.to_nat (option_get 0%Z (v l)). - - Theorem check_valid_nat {m c} : - check m c -> (forall (v : Level.t -> nat), wf_valuation (levels m ∪ univ_constraint_levels c) v -> interp_cstrs v (constraints m) -> interp_nat_cstr v c). + Theorem check_valid_nat {m : univ_model} {c} : + check_entails (model m) (to_constraint c) -> (forall (v : Level.t -> nat), wf_valuation (levels m ∪ univ_constraint_levels c) v -> interp_cstrs v (constraints m) -> interp_nat_cstr v c). Proof. rewrite check_any_completeness. intros hv v wfv hp. diff --git a/template-rocq/theories/Junk.v b/template-rocq/theories/Junk.v index f82a7d583..2eb899e03 100644 --- a/template-rocq/theories/Junk.v +++ b/template-rocq/theories/Junk.v @@ -2088,3 +2088,21 @@ Proof. - move/check_invalid_entails: ch. intros ne. now right. - move/check_gen_entails: ch. now left. Qed. + +Definition valid_total_models cls cl := + forall m : Model.model, is_total_model m cls -> + defined_model_of (clause_levels cl) m -> valid_clause m cl. + +Lemma valid_total_models_Z_models cls cl : valid_clause_Z cls cl <-> valid_total_models cls cl. +Proof. + split. + - intros H m istot encl. + move: (H (Z_valuation_of_model m)) => /fwd. + destruct istot. move/is_modelP: H1 => H1. + move=> cl' /[dup] /H0 en /H1. + now eapply valid_clause_model. + intros cs. + rewrite -def_clause_sem_valid //. + - intros vm v vpos csem. red in vm. todo "admit". +Qed. + From fa0eefbc159a4a8582a770f6966a6b43018633ef Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sun, 2 Nov 2025 09:47:13 +0100 Subject: [PATCH 115/164] Before generalize wf_valuation --- .../theories/LoopChecking/UnivLoopChecking.v | 1 - common/theories/uGraph.v | 189 +++++++++++++++--- 2 files changed, 165 insertions(+), 25 deletions(-) diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 4fb9580b1..d317cbb5e 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -1810,7 +1810,6 @@ End ZUnivConstraint. Context (v : Level.t -> Z). Context (v' : Level.t -> nat). Context (hv : forall l, v l = Z.of_nat (v' l)). -Print interp_z_cstr. Lemma interp_nes_equiv u : interp_nes v (to_atoms u) = Z.of_nat (Universe.interp_nes v' u). Proof. diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index 2334b0156..d9ab51c20 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -209,48 +209,189 @@ Section CheckLeq. forall c, declared_univ_cstr_levels uctx.1 c -> check c <-> valid0_cstr uctx.2 c. - Lemma contra_prop_bool (P : Prop) (b : bool) : - (~~ b -> ~ P) -> (P -> b). + Import C (clauses_sem). + + Lemma declared_incl c : + declared_univ_cstr_levels uctx.1 c -> + declared_univ_cstr_levels (levels m) c. Proof. - destruct b => //. - intros f p. elim f. reflexivity. - exact p. + destruct c as [[l d] r]. + move=> [hl hr]; cbn; split. + - setoid_rewrite hl. + rewrite (proj1 HG). lsets. + - setoid_rewrite hr. + rewrite (proj1 HG); lsets. Qed. - Definition to_opt_val (v : Level.t -> Z) : Level.t -> option Z := - fun l => Some (v l). + Lemma interp_cstrs_union (v : Level.t -> nat) cstrs cstrs' : + interp_cstrs v (UnivConstraintSet.union cstrs cstrs') <-> + interp_cstrs v cstrs /\ interp_cstrs v cstrs'. + Proof. + Admitted. - Lemma posv v : LoopCheck.Impl.I.Model.Model.positive_opt_valuation (to_opt_val (valuation_to_Z v)). + Lemma interp_nes_val (v : valuation) (u : Universe.t) : + Universe.interp_nes (val v) u = Universes.val v u. Proof. - red. intros l. unfold valuation_to_Z, to_opt_val. intros k [=]. lia. + move: u. refine (Universe.interp_nes_elim (val v) (fun u i => i = val v u) _ _ _). + - intros [l k]; rewrite val_singleton //= /val; cbn in *. + - move=>[l k] u k' ih hnin. + cbn. rewrite val_add //=. cbn. subst k'. cbn. + reflexivity. Qed. - Lemma interp_univ_cstr_to_opt_val v c : - interp_univ_cstr (to_opt_val v) c <-> interp_univ_cstr v c. + Lemma satisfies0_interp_cstr (v : valuation) c : + satisfies0 v c <-> interp_nat_cstr (val v) c. Proof. - destruct c as [[l []] r]; cbn -[SemiLattice.Semilattice.eq]. - Admitted. + destruct c as [[l []] r]; cbn -[SemiLattice.Semilattice.le]. + split. + - intros sat. depelim sat. + rewrite !interp_nes_val. cbn. lia. + - rewrite !interp_nes_val. cbn. constructor. lia. + - split. + * intros sat. depelim sat. + rewrite !interp_nes_val. cbn. lia. + * rewrite !interp_nes_val. cbn. constructor. lia. + Qed. - Lemma interp_univ_cstrs_to_opt_val v c : - interp_univ_cstrs (to_opt_val v) c <-> interp_univ_cstrs v c. + + Lemma satisfies0_interp_cstr_inv V (v : Level.t -> nat) c : + wf_valuation V v -> + LevelSet.Subset (univ_constraint_levels c) V -> + satisfies0 (to_valuation v) c <-> interp_nat_cstr v c. Proof. - Admitted. + intros hwf hs. + destruct c as [[l []] r]; cbn -[SemiLattice.Semilattice.le]. + - split. + * intros sat. depelim sat. + rewrite -!(@UnivLoopChecking.interp_nes_val V) in H => //. + 1-2:cbn in hs; lsets. + cbn. lia. + * intros hle. constructor. + rewrite -!(@UnivLoopChecking.interp_nes_val V) //. + 1-2:cbn in hs; lsets. + cbn in hle. lia. + - split. + * intros sat. depelim sat. + rewrite -!(@UnivLoopChecking.interp_nes_val V) in H => //. + 1-2:cbn in hs; lsets. + * intros hle. constructor. + rewrite -!(@UnivLoopChecking.interp_nes_val V) //. + 1-2:cbn in hs; lsets. + Qed. - Import C (clauses_sem). + Lemma satisfies_interp_cstr (v : valuation) c : + satisfies v c <-> interp_cstrs (val v) c. + Proof. + now split; move=> hf cs /hf /satisfies0_interp_cstr. + Qed. - Lemma clauses_sem_to_opt_val v c : - clauses_sem (to_opt_val v) c <-> clauses_sem v c. + Lemma satisfies_interp_cstr_inv V (v : Level.t -> nat) c : + wf_valuation V v -> + LevelSet.Subset (univ_constraints_levels c) V -> + satisfies (to_valuation v) c <-> interp_cstrs v c. Proof. - Admitted. + intros wf hs; split; move=> hf cs /[dup] hin /hf; eapply satisfies0_interp_cstr_inv; tea. + intros h hin'. apply (hs h). + rewrite univ_constraints_levels_spec. exists cs. split => //. + move=> l hin'; apply hs, univ_constraints_levels_spec. + now exists cs; split => //. + Qed. + + Definition shift_valuation (v : Level.t -> nat) : Level.t -> nat := + fun l => v l - v Level.lzero. + + Lemma wf_shift_valuation v : + interp_cstrs v (init_constraints_of_levels uctx.1) -> + wf_valuation uctx.1 (shift_valuation v). + Proof. + intros hi l hin. unfold LS.Level.zero. + change (l == Level.lzero) with (eqb l Level.lzero). + have he : shift_valuation v Level.lzero = 0. + rewrite /shift_valuation //. lia. + destruct (eqb_spec l Level.lzero). + - now subst l. + - destruct LS.Level.is_global eqn:isg. + unfold shift_valuation. + specialize (hi (U1, Le, Universe.singleton (l,0))). + forward hi. + eapply init_constraints_of_levels_spec; tea. + rewrite /init_constraint_of_level. destruct l => //. + destruct l as [|g|i]=> //. + cbn -[Pos.to_nat] in hi. + destruct (v (Level.level g)) eqn:hv => //. noconf hi. lia. + lia. + Qed. + Lemma interp_nes_shift V (v : Level.t -> nat) (u : Universe.t) : + interp_cstrs v (init_constraints_of_levels uctx.1) -> + wf_valuation V (shift_valuation v) -> + LevelSet.Subset (Universe.levels u) V -> + Universe.interp_nes v u - v Level.lzero = Universe.interp_nes (shift_valuation v) u. + Proof. + move: u. refine (Universe.interp_nes_elim v (fun u i => _ -> _ -> _ -> i - v Level.lzero = Universe.interp_nes (shift_valuation v) u) _ _ _). + - intros [l k] whi wf hsub. rewrite /Universe.interp_expr //= + Universe.interp_nes_singleton /val; cbn in *. + + specialize (wf l). forward wf. admit. + rewrite /shift_valuation in wf |- *. + move: wf. unfold LS.Level.zero. + change (l == Level.lzero) with (eqb l Level.lzero). + destruct (eqb_spec l Level.lzero) => //=. subst. lia. + destruct l; cbn. congruence. lia. + cbn. intros. + - move=>[l k] u k' ih hnin. + cbn. rewrite val_add //=. cbn. subst k'. cbn. + reflexivity. + Qed. *) + Lemma interp_cstr_shift V v c : + wf_valuation V (shift_valuation v) -> + declared_univ_cstr_levels V c -> + interp_nat_cstr v c -> interp_nat_cstr (shift_valuation v) c. + Proof. + intros hfw hdecl. + destruct c as [[l d] r]; cbn. + destruct d. + intros hi. *) + Lemma checkb_spec : check_spec checkb. Proof. intros c decl. rewrite /checkb. - split. - - rewrite check_completeness. - intros mc. intros v sat. - apply clauses_sem_satisfies0_equiv. + rewrite check_nat_completeness. + now apply declared_incl. + split; intros hv. + - intros v sat. + specialize (hv (val v)). + destruct HG. + rewrite H0 in hv. + forward hv. + { apply interp_cstrs_union. + split; [apply satisfies_interp_cstr, satisfies_init|now apply satisfies_interp_cstr]. } + now apply satisfies0_interp_cstr. + - intros v. + rewrite (proj2 HG) interp_cstrs_union. + intros [ii iu]. + specialize (hv (to_valuation (shift_valuation v))). + rewrite (satisfies_interp_cstr_inv uctx.1) in hv. + apply wf_shift_valuation. exact ii. admit. + forward hv. + + + + red. + Print init_constraint_of_level. + + red in hv. About to_val. + rewrite inte + rewrite interp_ + rewrite -satisfies_interp_cstr. + apply clauses_sem_satisfies_equiv in sat. + + have hi := interp_cstr_clauses_sem. + red in sat. + apply satisfies_clauses_sem_to_Z in sat. + rewrite interp_univ_cstr_to_opt_val. + rewrite interp_univ_cstrs_nat. red in mc. setoid_rewrite interp_cstrs_clauses_sem in mc. specialize (mc (to_opt_val (valuation_to_Z v))). From 9ea96c60f65acf5e2b1da5bb738932dc4106ce2c Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sun, 2 Nov 2025 18:29:12 +0100 Subject: [PATCH 116/164] Cleanup UGraph, no "GC set" anymore --- common/theories/uGraph.v | 1563 ++++++-------------------------------- 1 file changed, 212 insertions(+), 1351 deletions(-) diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index d9ab51c20..5007c14fa 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -1,5 +1,5 @@ (* Distributed under the terms of the MIT license. *) -From Stdlib Require Import ssreflect ssrbool OrderedTypeAlt MSetAVL MSetFacts MSetProperties MSetDecide Morphisms. +From Stdlib Require Import ssreflect ssrbool ssrfun OrderedTypeAlt MSetAVL MSetFacts MSetProperties MSetDecide Morphisms. From MetaRocq.Utils Require Import utils. From MetaRocq.Common Require Import config UnivConstraintType Universes UnivLoopChecking. From Equations.Prop Require Import DepElim. @@ -11,7 +11,7 @@ Definition universe_model := UnivLoopChecking.univ_model. Definition init_model : universe_model := UnivLoopChecking.init_model. Definition uctx_invariants (uctx : ContextSet.t) - := UnivConstraintSet.For_all (declared_univ_cstr_levels uctx.1) uctx.2. + := UnivLoopChecking.declared_univ_cstrs_levels uctx.1 uctx.2. Definition global_uctx_invariants (uctx : ContextSet.t) := ~ LevelSet.In Level.lzero uctx.1 /\ uctx_invariants uctx. @@ -26,7 +26,11 @@ push_uctx g uctx with UnivLoopChecking.declare_levels g uctx.1 := Instance declared_univ_cstrs_levels_proper : Proper (LevelSet.Equal ==> UnivConstraintSet.Equal ==> iff) declared_univ_cstrs_levels. -Proof. Admitted. +Proof. + move=> ?? e ?? e'. + rewrite /declared_univ_cstrs_levels. + rewrite e'. rewrite /UnivConstraintSet.For_all /declared_univ_cstr_levels. +Admitted. Definition push_uctx_precond g uctx := let allcstrs := UnivConstraintSet.union uctx.2 (UnivConstraintSet.union (init_constraints_of_levels uctx.1) (constraints g)) in @@ -68,6 +72,14 @@ Proof. now rewrite Heq. Qed. +End Push. + +Import UnivLoopChecking. + +Definition is_model_of_uctx m uctx := + levels m =_lset LevelSet.union uctx.1 (LevelSet.singleton Universes.Level.lzero) /\ + constraints m =_ucset UnivConstraintSet.union uctx.2 (init_constraints_of_levels uctx.1). + (** ** Check of consistency ** *) Equations is_consistent (uctx : ContextSet.t) : bool := @@ -124,6 +136,9 @@ Section CheckLeqProcedure. Definition check_constraint_gen (c : UnivConstraint.t) := ~~ check_univs || check_cstr c. + Definition check_constraints_gen (c : UnivConstraintSet.t) := + ~~ check_univs || UnivConstraintSet.for_all check_cstr c. + Definition eqb_univ_instance_gen (u1 u2 : Instance.t) : bool := forallb2 check_eqb_universe_gen u1 u2. @@ -227,7 +242,10 @@ Section CheckLeq. interp_cstrs v (UnivConstraintSet.union cstrs cstrs') <-> interp_cstrs v cstrs /\ interp_cstrs v cstrs'. Proof. - Admitted. + rewrite /interp_cstrs /UnivConstraintSet.For_all. + setoid_rewrite UnivConstraintSet.union_spec. + firstorder. + Qed. Lemma interp_nes_val (v : valuation) (u : Universe.t) : Universe.interp_nes (val v) u = Universes.val v u. @@ -253,7 +271,6 @@ Section CheckLeq. * rewrite !interp_nes_val. cbn. constructor. lia. Qed. - Lemma satisfies0_interp_cstr_inv V (v : Level.t -> nat) c : wf_valuation V v -> LevelSet.Subset (univ_constraint_levels c) V -> @@ -297,61 +314,143 @@ Section CheckLeq. now exists cs; split => //. Qed. - Definition shift_valuation (v : Level.t -> nat) : Level.t -> nat := - fun l => v l - v Level.lzero. + Definition wf_zero_valuation V v := + forall l, LevelSet.In l V -> + let zero := LS.Level.zero in + if l == zero then True + else if LS.Level.is_global l then v l > v zero + else v l >= v zero. - Lemma wf_shift_valuation v : + Lemma wf_valuation_zero V v : + wf_valuation V v -> + v Level.lzero = 0 -> + wf_zero_valuation V v. + Proof. + rewrite /wf_valuation /wf_zero_valuation. + move=> hl l hz /hl. destruct eqb => //. + now rewrite l. + Qed. + + Lemma wf_zero_valuation_init v : interp_cstrs v (init_constraints_of_levels uctx.1) -> - wf_valuation uctx.1 (shift_valuation v). + wf_zero_valuation uctx.1 v. Proof. intros hi l hin. unfold LS.Level.zero. change (l == Level.lzero) with (eqb l Level.lzero). - have he : shift_valuation v Level.lzero = 0. - rewrite /shift_valuation //. lia. - destruct (eqb_spec l Level.lzero). - - now subst l. - - destruct LS.Level.is_global eqn:isg. - unfold shift_valuation. - specialize (hi (U1, Le, Universe.singleton (l,0))). + destruct (eqb_spec l Level.lzero) => //. + destruct LS.Level.is_global eqn:isg. + - specialize (hi (U1, Le, Universe.singleton (l,0))). forward hi. - eapply init_constraints_of_levels_spec; tea. + eapply init_constraints_of_levels_spec. tea. rewrite /init_constraint_of_level. destruct l => //. destruct l as [|g|i]=> //. cbn -[Pos.to_nat] in hi. destruct (v (Level.level g)) eqn:hv => //. noconf hi. lia. - lia. + - specialize (hi (U0, Le, Universe.singleton (l,0))). + forward hi. + eapply init_constraints_of_levels_spec. tea. + rewrite /init_constraint_of_level. destruct l => //. + destruct l as [|g|i]=> //. + cbn -[Pos.to_nat] in hi. lia. Qed. - Lemma interp_nes_shift V (v : Level.t -> nat) (u : Universe.t) : - interp_cstrs v (init_constraints_of_levels uctx.1) -> - wf_valuation V (shift_valuation v) -> + + Definition shift_valuation (v : Level.t -> nat) : Level.t -> nat := + fun l => v l - v Level.lzero. + + Lemma wf_shift_valuation V v : + wf_zero_valuation V v -> + wf_valuation V (shift_valuation v). + Proof. + move=> wfv l /wfv. cbn. unfold LS.Level.zero. + change (l == Level.lzero) with (eqb l Level.lzero). + have he : shift_valuation v Level.lzero = 0. + rewrite /shift_valuation //. lia. + destruct (eqb_spec l Level.lzero). + - now subst l. + - destruct LS.Level.is_global eqn:isg; unfold shift_valuation; lia. + Qed. + + Lemma wf_valuation_neq V v : + wf_zero_valuation V v -> + forall l, LevelSet.In l V -> v l >= v LS.Level.zero. + Proof. + intros wfv l hin. + move: (wfv l hin). + unfold LS.Level.zero in *. + change (l == Level.lzero) with (eqb l Level.lzero). + destruct (eqb_spec l Level.lzero) => //=. subst. lia. + destruct l; cbn; try congruence; lia. + Qed. + + Lemma interp_nes_shift {V} {v : Level.t -> nat} {u : Universe.t} : + wf_zero_valuation V v -> LevelSet.Subset (Universe.levels u) V -> - Universe.interp_nes v u - v Level.lzero = Universe.interp_nes (shift_valuation v) u. + Universe.interp_nes (shift_valuation v) u = + Universe.interp_nes v u - v Level.lzero /\ Universe.interp_nes v u >= v Level.lzero. Proof. - move: u. refine (Universe.interp_nes_elim v (fun u i => _ -> _ -> _ -> i - v Level.lzero = Universe.interp_nes (shift_valuation v) u) _ _ _). - - intros [l k] whi wf hsub. rewrite /Universe.interp_expr //= + move: u. refine (Universe.interp_nes_elim v (fun u i => _ -> _ -> + Universe.interp_nes (shift_valuation v) u = i - v Level.lzero /\ i >= v Level.lzero) _ _ _). + - intros [l k] wf hsub. rewrite /Universe.interp_expr //= Universe.interp_nes_singleton /val; cbn in *. - - specialize (wf l). forward wf. admit. + specialize (wf l). forward wf. + { apply hsub. unfold flip; cbn. lsets. } rewrite /shift_valuation in wf |- *. move: wf. unfold LS.Level.zero. change (l == Level.lzero) with (eqb l Level.lzero). destruct (eqb_spec l Level.lzero) => //=. subst. lia. destruct l; cbn. congruence. lia. - cbn. intros. - - move=>[l k] u k' ih hnin. - cbn. rewrite val_add //=. cbn. subst k'. cbn. - reflexivity. - Qed. *) - Lemma interp_cstr_shift V v c : - wf_valuation V (shift_valuation v) -> + cbn. intros. lia. + - move=>[l k] u k' ih hnin wfv hsub. + specialize (ih wfv). cbn. erewrite Universe.interp_nes_add. + forward ih. setoid_rewrite <- hsub. + rewrite Universe.levels_add. lsets. + destruct ih as [ih ih']. rewrite ih. + move: (wf_valuation_neq _ _ wfv l) => /fwd. + apply hsub. rewrite Universe.levels_add //=. lsets. + rewrite /Universe.interp_expr //= /shift_valuation //=. + unfold LS.Level.zero; split; [lia|]. lia. + Qed. + + Lemma interp_cstr_shift {V v c} : + wf_zero_valuation V v -> declared_univ_cstr_levels V c -> - interp_nat_cstr v c -> interp_nat_cstr (shift_valuation v) c. + interp_nat_cstr v c <-> interp_nat_cstr (shift_valuation v) c. Proof. intros hfw hdecl. destruct c as [[l d] r]; cbn. - destruct d. - intros hi. *) + move: (interp_nes_shift (u := l) hfw) => /fwd. apply hdecl. + move=> [hl hle]. + move: (interp_nes_shift (u := r) hfw) => /fwd. apply hdecl. + move=> [hr hre]. + destruct d; rewrite hl hr; split; lia. + Qed. + + Lemma declared_univ_cstr_levels_incl V c cls : + declared_univ_cstrs_levels V cls -> + UnivConstraintSet.In c cls -> + declared_univ_cstr_levels V c. + Proof. + now move=> hdecl /hdecl. + Qed. + Lemma interp_cstrs_shift V v c : + wf_zero_valuation V v -> + declared_univ_cstrs_levels V c -> + interp_cstrs v c <-> interp_cstrs (shift_valuation v) c. + Proof. + intros hfw hdecl. + split; move=> hv cl /[dup] hin /hv; rewrite (interp_cstr_shift hfw); tea => //. + all:now eapply declared_univ_cstr_levels_incl. + Qed. + + Lemma uctx_subset : + LevelSet.Subset (univ_constraints_levels uctx.2) uctx.1. + Proof. + red in Huctx. destruct Huctx. red in H0. intros l hin. red in H0. + apply univ_constraints_levels_spec in hin as [cl [hin hincl]]. + apply H0 in hin. + apply declared_univ_cstr_levels_spec in hin. now apply hin. + Qed. Lemma checkb_spec : check_spec checkb. Proof. @@ -373,66 +472,18 @@ Section CheckLeq. intros [ii iu]. specialize (hv (to_valuation (shift_valuation v))). rewrite (satisfies_interp_cstr_inv uctx.1) in hv. - apply wf_shift_valuation. exact ii. admit. + { apply wf_shift_valuation. apply wf_zero_valuation_init. exact ii. } + apply uctx_subset. forward hv. - - - - red. - Print init_constraint_of_level. - - red in hv. About to_val. - rewrite inte - rewrite interp_ - rewrite -satisfies_interp_cstr. - apply clauses_sem_satisfies_equiv in sat. - - have hi := interp_cstr_clauses_sem. - red in sat. - apply satisfies_clauses_sem_to_Z in sat. - rewrite interp_univ_cstr_to_opt_val. - rewrite interp_univ_cstrs_nat. - red in mc. - setoid_rewrite interp_cstrs_clauses_sem in mc. - specialize (mc (to_opt_val (valuation_to_Z v))). - eapply interp_cstr_clauses_sem. - forward mc. apply posv. - rewrite -interp_univ_cstr_to_opt_val. apply mc. - rewrite clauses_sem_to_opt_val. - apply satisfies_clauses_sem_to_Z. - destruct HG as [hlev hcstrs]. - rewrite hcstrs. eapply satisfies_union. split => //. - eapply satisfies_init. - - rewrite check_completeness. - intros hv. red in hv. - destruct HG as [hlev hcstrs]. - intros v vpos cs. - Print valuation. - red. - rewrite valid_Z_pos_nat_model => v. - rewrite hcstrs. - erewrite <-interp_univ_cstrs_nat. - Search wf_valuation. - rewrite interp_cstrs_union. - specialize (hv (valuation_of_opt_nat v)). - intros interp. - rewrite -interp_univ_cstrs_nat in interp. - - - setoid_rewrite <- clauses_sem_satisfies_equiv in hv. - red. intros v vcs. - rewrite interp_cstr_clauses_sem. - Search interp_univ_cstrs. - setoid_rewrite interp_cstrs_clauses_sem in hcls. - rewrite interp_cstr_clauses_sem. *) - - - - - Search LoopCheck.Impl.CorrectModel.clauses_sem. - specialize (HG c). - - + rewrite -interp_cstrs_shift. apply wf_zero_valuation_init. apply ii. + apply Huctx. exact iu. + rewrite satisfies0_interp_cstr_inv in hv. + apply wf_shift_valuation. + apply wf_zero_valuation_init => //. + now apply declared_univ_cstr_levels_spec. + erewrite interp_cstr_shift => //. + apply wf_zero_valuation_init => //. exact decl. + Qed. Lemma fold_right_xpred0 {A} (l : list A) : fold_right (fun _ => xpred0) false l = false. Proof using Type. induction l; simpl; auto. Qed. @@ -453,6 +504,8 @@ Section CheckLeq. - cbn. apply check_correct. Qed. + Definition check_leqb_universe_spec := check_leqb_universe_spec_gen _ checkb_spec. + Lemma check_eqb_universe_spec_gen check (check_correct : check_spec check) (l l' : Universe.t) @@ -466,1223 +519,82 @@ Section CheckLeq. - cbn. apply check_correct. Qed. - Definition check_leqb_universe_spec := check_leqb_universe_spec_gen _ check_spec. - - Definition check_eqb_universe := (check_eqb_universe_gen leqb_level_n). - - Lemma check_eqb_universe_spec_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - (l1 l2 : Universe.t) - (Hu1 : gc_levels_declared l1) - (Hu2 : gc_levels_declared l2) - : check_eqb_universe_gen leqb_level_n_gen l1 l2 <-> gc_eq_universe uctx.2 l1 l2. - Proof using HC HG Huctx. - unfold check_eqb_universe_gen, gc_eq_universe. - destruct check_univs; [|split; trivial]. - split; cbn. - - move/orP => [ | /andP [Hle Hge]]. - + rewrite univ_expr_eqb_true_iff. - now intros <- v Hv. - + eapply leqb_universe_n_spec0_gen in Hle, Hge; eauto. - unfold_univ_rel0. specialize (Hle v Hv); specialize (Hge v Hv). - simpl in *. lia. - - intros H. toProp; right. - toProp; eapply leqb_universe_n_spec_gen; tas; intros v Hv; specialize (H v Hv). - rewrite H. cbn; lia. - rewrite H. cbn; lia. - Qed. - - Definition check_eqb_universe_spec := check_eqb_universe_spec_gen _ leqb_level_n_spec. + Definition check_eqb_universe_spec := check_eqb_universe_spec_gen _ checkb_spec. Lemma fold_left_false {A} l : fold_left (B:=A) (fun _ : bool => xpred0) l false = false. Proof using Type. induction l; simpl; eauto. Qed. - Definition check_gc_constraint := (check_gc_constraint_gen leqb_level_n). - - Definition check_gc_constraints := (check_gc_constraints_gen leqb_level_n). - - Definition check_constraints := (check_constraints_gen leqb_level_n). - - - Definition gc_levels_declared' (vset : VSet.t) gc := - match gc with - | GoodConstraint.gc_le l _ l' => VSet.In (VariableLevel.to_noprop l) vset /\ - VSet.In (VariableLevel.to_noprop l') vset - | GoodConstraint.gc_lt_set_level _ n | GoodConstraint.gc_le_level_set n _ => - VSet.In (Level.level n) vset - | GoodConstraint.gc_le_set_var _ n | GoodConstraint.gc_le_var_set n _ => VSet.In (Level.lvar n) vset - end. - - Definition gcs_levels_declared (vset : VSet.t) gcs := - GoodUnivConstraintSet.For_all (gc_levels_declared' vset) gcs. - - - Lemma check_gc_constraint_spec_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - gc - (Hu1 : gc_levels_declared' uctx.1 gc) - : check_gc_constraint_gen leqb_level_n_gen gc - -> if check_univs then forall v, gc_satisfies v uctx.2 -> gc_satisfies0 v gc else True. - Proof using Huctx. - unfold check_gc_constraint_gen. - destruct check_univs; [cbn|trivial]. - destruct gc as [l z l'|k l|k n|l k|n k]. - - intros HH v Hv; eapply leqb_correct in HH; eauto. - specialize (HH v Hv). cbn in *. toProp. - pose proof (val_level_of_variable_level v l). - pose proof (val_level_of_variable_level v l'). - destruct l, l'; cbn in *; lia. - all: now inversion Hu1. - - intros HH v Hv; eapply leqb_correct in HH; eauto. - specialize (HH v Hv). cbn -[Z.of_nat] in HH. unfold gc_satisfies0. toProp. - cbn in *. lia. - now inversion Huctx. - - intros HH v Hv; apply leqb_correct in HH. - specialize (HH v Hv). cbn in HH. unfold gc_satisfies0. toProp. - lia. now inversion Huctx. now inversion Hu1. - - intros HH v Hv; apply leqb_correct in HH. - specialize (HH v Hv). cbn in HH. unfold gc_satisfies0. toProp. - lia. now inversion Hu1. now inversion Huctx. - - intros HH v Hv; apply leqb_correct in HH. - specialize (HH v Hv). cbn in HH. unfold gc_satisfies0. toProp. - lia. now inversion Hu1. now inversion Huctx. - Qed. - - Definition check_gc_constraint_spec := check_gc_constraint_spec_gen _ leqb_level_n_spec. - - Lemma check_gc_constraints_spec_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) - ctrs (Hu1 : gcs_levels_declared uctx.1 ctrs) - : check_gc_constraints_gen leqb_level_n_gen ctrs - -> if check_univs then forall v, gc_satisfies v uctx.2 -> gc_satisfies v ctrs else True. - Proof using Huctx. - rewrite /gcs_levels_declared in Hu1. pose proof check_gc_constraint_spec_gen as XX. - unfold check_gc_constraints_gen. destruct check_univs; [cbn|trivial]. - intros HH v Hv. - apply GoodUnivConstraintSet.for_all_spec. now intros x y []. - apply GoodUnivConstraintSet.for_all_spec in HH. 2: now intros x y []. - intros gc Hgc. specialize (HH gc Hgc). - eapply XX; try eassumption. now apply Hu1. - Qed. - - Definition check_gc_constraints_spec := check_gc_constraints_spec_gen _ leqb_level_n_spec. + Definition check_constraints := (check_constraints_gen checkb). + Definition eqb_univ_instance := (eqb_univ_instance_gen checkb). - Definition eqb_univ_instance := (eqb_univ_instance_gen leqb_level_n). + Definition leqb_sort := (leqb_sort_gen checkb). - Definition leqb_sort := (leqb_sort_gen leqb_level_n). + Definition check_leqb_sort := (check_leqb_sort_gen checkb). - Definition check_leqb_sort := (check_leqb_sort_gen leqb_level_n). + Definition check_eqb_sort := (check_eqb_sort_gen checkb). - Definition check_eqb_sort := (check_eqb_sort_gen leqb_level_n). - - Lemma check_eqb_sort_refl_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) u : - check_eqb_sort_gen leqb_level_n_gen u u. + Lemma check_eqb_sort_refl_gen check + (leqb_correct : check_spec check) u : + check_eqb_sort_gen check u u. Proof using Type. unfold check_eqb_sort_gen; toProp; left. apply eqb_refl. Qed. - Definition check_eqb_sort_refl := check_eqb_sort_refl_gen _ leqb_level_n_spec. - - Definition gc_leq_sort φ := - leq_sort_n_ (fun n u u' => if check_univs then gc_leq0_universe_n n φ u u' else True) 0. + Definition check_eqb_sort_refl := check_eqb_sort_refl_gen _ checkb_spec. - Definition gc_eq_sort φ := - eq_sort_ (fun u u' => if check_univs then gc_eq0_universe φ u u' else True). + (* Let levels_declared_sort (s : Sort.t) := + Sort.on_sort gc_levels_declared True s. *) - Let levels_declared_sort (s : Sort.t) := - Sort.on_sort gc_levels_declared True s. + Lemma levels_declared_uctx u : levels_declared u -> LevelSet.Subset (Universe.levels u) uctx.1. + Proof. + move=> hu l. hnf in hu. + rewrite Universe.levels_spec. + move=> -[k /hu hin]. apply hin. + Qed. - Lemma check_eqb_sort_spec_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen leqb_level_n_gen) + Lemma check_eqb_sort_spec_gen check + (leqb_correct : check_spec check) (u1 u2 : Sort.t) (Hu1 : levels_declared_sort u1) (Hu2 : levels_declared_sort u2) - : check_eqb_sort_gen leqb_level_n_gen u1 u2 <-> gc_eq_sort uctx.2 u1 u2. + : check_eqb_sort_gen check u1 u2 <-> eq_sort uctx.2 u1 u2. Proof. - unfold check_eqb_sort_gen, gc_eq_sort. + unfold check_eqb_sort_gen, eq_sort. destruct u1, u2; cbnr; split; intuition auto. - now destruct prop_sub_type. - - eapply check_eqb_universe_spec_gen; eauto; tas. - unfold check_eqb_sort_gen, check_eqb_universe_gen in *; cbn in *. - unfold check_leqb_universe_gen in *. - destruct check_univs; cbnr. - unfold eqb at 1, Sort.reflect_eq_sort, Sort.eqb in H. cbn in H. - move/orP : H => /= [-> //|] /andP[] /orP[-> //|] H1 /orP[e | H2]. - 1: apply NonEmptySetFacts.univ_expr_eqb_true_iff in e as ->. - 1: toProp; left; now apply NonEmptySetFacts.univ_expr_eqb_true_iff. - toProp; right; now toProp. - - toProp; right. - eapply check_eqb_universe_spec_gen in H; eauto; tas. - unfold check_eqb_universe_gen in *; cbn in *. - unfold check_leqb_universe_gen in *. - destruct check_univs; [cbn in * | trivial]. - move/orP : H => [H | /andP [H1 H2]]. - + apply NonEmptySetFacts.univ_expr_eqb_true_iff in H as ->. - toProp; toProp; left; now apply NonEmptySetFacts.univ_expr_eqb_true_iff. - + toProp; toProp; right; assumption. - Defined. - - Definition check_eqb_sort_spec := check_eqb_sort_spec_gen _ leqb_level_n_spec. - -End CheckLeq. - -(* This section: specif in term of raw uctx *) -Section CheckLeq2. - Context {cf:checker_flags}. - - Definition is_graph_of_uctx G uctx - := on_Some (fun uctx => Equal_graph (make_graph uctx) G) (gc_of_uctx uctx). - - Context (G : universes_graph) - uctx (Huctx: global_uctx_invariants uctx) (HC : consistent uctx.2) - (HG : is_graph_of_uctx G uctx). - - Definition uctx' : VSet.t × GoodUnivConstraintSet.t. - unfold is_graph_of_uctx, gc_of_uctx in HG. - destruct (gc_of_constraints uctx.2) as [ctrs|]. - exact (uctx.1, ctrs). - contradiction HG. - Defined. - - #[clearbody] Let Huctx' : global_gc_uctx_invariants uctx'. - unfold uctx'; cbn. - eapply gc_of_uctx_invariants; tea. - unfold is_graph_of_uctx, gc_of_uctx in *. cbn. - destruct (gc_of_constraints uctx.2) as [ctrs|]. - reflexivity. contradiction HG. - Defined. - - #[clearbody] - Let HC' : gc_consistent uctx'.2. - unfold uctx'; cbn. clear Huctx'. - apply gc_consistent_iff in HC. - unfold is_graph_of_uctx, gc_of_uctx in *. - destruct (gc_of_constraints uctx.2) as [ctrs|]. - exact HC. contradiction HG. - Defined. - - #[clearbody] - Let HG' : Equal_graph G (make_graph uctx'). - unfold uctx' in *; cbn. clear Huctx'. - unfold is_graph_of_uctx, gc_of_uctx in *. - destruct (gc_of_constraints uctx.2) as [ctrs|]. - symmetry; exact HG. contradiction HG. - Defined. - - Let level_declared (l : Level.t) := LevelSet.In l uctx.1. - - Let expr_declared (e : LevelExpr.t) - := on_Some_or_None (fun l : Level.t => level_declared l) - (LevelExpr.get_noprop e). - - Let levels_declared (u : Universe.t) := - LevelExprSet.For_all expr_declared u. - - Lemma level_gc_declared_declared l - : level_declared l -> gc_level_declared uctx' l. - Proof using HG. - clear. unfold uctx'. - unfold is_graph_of_uctx, gc_of_uctx in HG. - destruct (gc_of_constraints uctx.2); [|contradiction HG]. - cbn; clear HG. unfold level_declared, gc_level_declared; cbn. - destruct l; cbn; trivial; intro. - Qed. - - Lemma expr_gc_declared_declared e - : expr_declared e -> gc_expr_declared uctx' e. - Proof using HG level_declared. - destruct e as [l b]; cbn; trivial. - intro; now apply (level_gc_declared_declared l) in H. - Qed. - - Lemma levels_gc_declared_declared (u : Universe.t) - : levels_declared u -> gc_levels_declared uctx' u. - Proof using HG expr_declared. - unfold levels_declared, gc_levels_declared. - intros HH e He; specialize (HH e He). - now apply expr_gc_declared_declared. - Qed. - - Lemma leqb_univ_expr_n_spec_gen' leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) - lt e1 u - (He1 : expr_declared e1) - (Hu : levels_declared u) - : leqb_expr_univ_n_gen leqb_level_n_gen ⎩ lt ⎭ e1 u - <-> leq0_universe_n ⎩ lt ⎭ uctx.2 (Universe.make e1) u. - Proof using HG' Huctx'. - etransitivity. - eapply (leqb_expr_univ_n_spec_gen G uctx' Huctx' HC' HG'); eauto; tas. - - apply expr_gc_declared_declared; tas. - - apply levels_gc_declared_declared; tas. - - symmetry. etransitivity. apply gc_leq0_universe_n_iff. - unfold uctx'; cbn; clear -HG. - unfold is_graph_of_uctx, gc_of_uctx in *. - destruct (gc_of_constraints uctx.2) as [ctrs|]. - reflexivity. contradiction HG. - Qed. - - Definition leqb_univ_expr_n_spec' := - leqb_univ_expr_n_spec_gen' _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - - Lemma check_leqb_universe_spec_gen' leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) - u1 u2 - : levels_declared u1 -> - levels_declared u2 -> - check_leqb_universe_gen leqb_level_n_gen u1 u2 -> leq_universe uctx.2 u1 u2. - Proof using HG' Huctx'. - unfold check_leqb_universe_gen; intros Hu1 Hu2 H. - unfold_univ_rel. - cbn in H; toProp H; destruct H as [e | ]. - { apply NonEmptySetFacts.univ_expr_eqb_true_iff in e. destruct e; lia. } - eapply leqb_universe_n_spec0_gen in H; eauto. - eapply gc_leq0_universe_iff; tea. - unfold uctx' in *. - unfold is_graph_of_uctx, gc_of_uctx in HG. - destruct (gc_of_constraints uctx.2). cbn in *. exact H. - exact I. - Unshelve. all: try eapply levels_gc_declared_declared; eauto. - Qed. - - Definition check_leqb_universe_spec' := - check_leqb_universe_spec_gen' _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - - Lemma check_leqb_universe_complete_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u1 u2 : - levels_declared u1 -> - levels_declared u2 -> - leq_universe uctx.2 u1 u2 -> - check_leqb_universe_gen leqb_level_n_gen u1 u2. - Proof using HG' Huctx'. - intros decl1 decl2. - apply levels_gc_declared_declared in decl1. - apply levels_gc_declared_declared in decl2. - rewrite gc_leq_universe_iff. - unfold is_graph_of_uctx, gc_of_uctx in HG. - unfold uctx' in *. - destruct gc_of_constraints; [cbn in *|contradiction HG]. - intros eq. - apply <- check_leqb_universe_spec_gen; eauto. - exact eq. - Qed. - - Definition check_leqb_universe_complete := - check_leqb_universe_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - - Lemma check_eqb_universe_spec_gen' leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) - u1 u2 - : levels_declared u1 -> - levels_declared u2 -> - check_eqb_universe_gen leqb_level_n_gen u1 u2 -> eq_universe uctx.2 u1 u2. - Proof using HG' Huctx'. - unfold check_eqb_universe_gen; intros Hu1 Hu2 H. - unfold_univ_rel. - cbn in H; toProp H; destruct H as [e | ]. - { apply NonEmptySetFacts.univ_expr_eqb_true_iff in e. destruct e; lia. } - apply andb_prop in H. destruct H as [H1 H2]. - unshelve eapply leqb_universe_n_spec0_gen in H1; eauto. - unshelve eapply leqb_universe_n_spec0_gen in H2; eauto. - unfold uctx' in *. - unfold is_graph_of_uctx, gc_of_uctx in HG. - apply <- eq0_leq0_universe; tea. - split; eapply gc_leq0_universe_iff; - (destruct (gc_of_constraints uctx.2); [cbn in *|contradiction HG]); tas. - all: now eapply levels_gc_declared_declared. - Qed. - - Definition check_eqb_universe_spec' := - check_eqb_universe_spec_gen' _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - - Lemma check_eqb_universe_complete_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u1 u2 : - levels_declared u1 -> - levels_declared u2 -> - eq_universe uctx.2 u1 u2 -> - check_eqb_universe_gen leqb_level_n_gen u1 u2. - Proof using HG' Huctx'. - intros decl1 decl2. - apply levels_gc_declared_declared in decl1. - apply levels_gc_declared_declared in decl2. - rewrite gc_eq_universe_iff. - unfold is_graph_of_uctx, gc_of_uctx in HG. - unfold uctx' in *. - destruct gc_of_constraints; [cbn in *|contradiction HG]. - intros eq. - apply <- check_eqb_universe_spec_gen; eauto. - exact eq. - Qed. - - Definition check_eqb_universe_complete := - check_eqb_universe_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - - Definition leq0_level_n z l l' := - leq0_universe_n z uctx.2 (Universe.make' l) (Universe.make' l'). - - Definition valid_gc_constraint (gc : GoodConstraint.t) := - match gc with - | GoodConstraint.gc_le l z l' => leq0_level_n z l l' - | GoodConstraint.gc_lt_set_level k l => leq0_level_n (Z.of_nat (S k)) lzero (Level.level l) - | GoodConstraint.gc_le_set_var k n => leq0_level_n (Z.of_nat k) lzero (Level.lvar n) - | GoodConstraint.gc_le_level_set l k => leq0_level_n (- Z.of_nat k)%Z (Level.level l) lzero - | GoodConstraint.gc_le_var_set n k => leq0_level_n (- Z.of_nat k)%Z (Level.lvar n) lzero - end. - - Definition valid_gc_constraints (gcs : GoodUnivConstraintSet.t) := - GoodUnivConstraintSet.For_all valid_gc_constraint gcs. - - Lemma leq0_level_n_complete_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) z l l' : - level_declared l -> - level_declared l' -> - leq0_level_n z l l' -> - leqb_level_n_gen z l l'. - Proof using HG' Huctx'. - intros decll decll'. - unfold leq0_level_n. - intros le; eapply gc_leq0_universe_n_iff in le. - unfold is_graph_of_uctx, gc_of_uctx in HG. - unfold uctx' in *. - destruct gc_of_constraints; [cbn in *|contradiction HG]. - now eapply leqb_correct. - Qed. - - Definition leq0_level_n_complete := - leq0_level_n_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - - Lemma check_gc_constraint_complete_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) cstr : - gc_levels_declared' uctx.1 cstr -> - valid_gc_constraint cstr -> - check_gc_constraint_gen leqb_level_n_gen cstr. - Proof using HG' Huctx'. - rewrite /check_gc_constraint_gen. - destruct check_univs eqn:cu => //=. - destruct cstr; cbn; intros hin; - eapply leq0_level_n_complete_gen; intuition auto. - all:apply Huctx. - Qed. - - Definition check_gc_constraint_complete := - check_gc_constraint_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - - Lemma check_gc_constraints_complete_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) cstrs : - gcs_levels_declared uctx.1 cstrs -> - valid_gc_constraints cstrs -> - check_gc_constraints_gen leqb_level_n_gen cstrs. - Proof using HG' Huctx'. - rewrite /gcs_levels_declared /valid_gc_constraints /check_gc_constraints. - intros hdecl hval. - eapply GoodConstraintSetFact.for_all_iff. typeclasses eauto. - intros cstr hcstr. specialize (hdecl cstr hcstr). - specialize (hval cstr hcstr). eapply check_gc_constraint_complete_gen => //. - Qed. - - Definition check_gc_constraints_complete := - check_gc_constraints_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - - Definition valid_gc_constraints_ext gc := - forall v, satisfies v uctx.2 -> gc_satisfies v gc. - - Lemma valid_gc_constraints_aux gc : - valid_gc_constraints_ext gc -> - valid_gc_constraints gc. - Proof using Type. - intros Hv v inv. - unfold gc_satisfies in Hv. - destruct v; cbn in *; red; - intros v Hv'; specialize (Hv _ Hv'); - eapply GoodConstraintSetFact.for_all_iff in Hv; try typeclasses eauto; - specialize (Hv _ inv); cbn in Hv; cbn; - rewrite ?val_level_of_variable_level //. - - now eapply Z.leb_le in Hv. - eapply Nat.leb_le in Hv. lia. - apply Nat.leb_le in Hv. lia. - apply Nat.leb_le in Hv. lia. - apply Nat.leb_le in Hv. lia. - Qed. - - Lemma valid_valid_gc cstrs gc : - check_univs -> - valid_constraints uctx.2 cstrs -> - gc_of_constraints cstrs = Some gc -> - valid_gc_constraints gc. - Proof using Type. - intros cu Hgc vgc. apply valid_gc_constraints_aux. - intros v Hv. - pose proof (gc_of_constraints_spec v cstrs). - rewrite vgc /= in H. apply H. - rewrite /valid_constraints cu in Hgc. apply Hgc. apply Hv. - Qed. - - Lemma gc_of_constraints_declared cstrs levels gc : - global_uctx_invariants (levels, cstrs) -> - gc_of_constraints cstrs = Some gc -> - gcs_levels_declared levels gc. - Proof using Type. - intros Hlev hc. - pose proof (gc_of_uctx_invariants (levels, cstrs) (levels, gc)). - cbn in H. rewrite hc in H. specialize (H eq_refl). now apply H. - Qed. - - Lemma check_constraints_spec_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) ctrs - : global_uctx_invariants (uctx.1, ctrs) -> - check_constraints_gen leqb_level_n_gen ctrs -> valid_constraints uctx.2 ctrs. - Proof using HG' Huctx'. - unfold check_constraints_gen, valid_constraints. - case_eq (gc_of_constraints ctrs); [|try discriminate]. - intros ctrs' Hctrs' Hdeclared HH. - epose proof check_gc_constraints_spec_gen. - destruct check_univs => //=. - intros v Hv. - apply gc_of_constraints_spec. - apply gc_of_constraints_spec in Hv. - rewrite Hctrs'; cbn. eapply H; eauto; - clear -HG Hv Hdeclared Hctrs'; - unfold is_graph_of_uctx, gc_of_uctx in HG; - unfold uctx' in *; destruct (gc_of_constraints uctx.2) => //; cbn in *. - eapply gc_of_constraints_declared; eauto. - Qed. - - Definition check_constraints_spec := - check_constraints_spec_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - - (* Completeness holds only for well-formed constraints sets *) - Lemma check_constraints_complete_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) ctrs : - check_univs -> - global_uctx_invariants (uctx.1, ctrs) -> - valid_constraints uctx.2 ctrs -> - check_constraints_gen leqb_level_n_gen ctrs. - Proof using HG' Huctx'. - intros cu gu vc. - unfold check_constraints_gen. - case_eq (gc_of_constraints ctrs); [|try discriminate]. - 2:{ destruct HC as [v Hv]. - pose proof (gc_of_constraints_spec v ctrs). - intros. - rewrite /valid_constraints cu in vc. - specialize (vc v Hv). - rewrite H0 in H. intuition. } - intros cstr gc. - eapply check_gc_constraints_complete_gen; eauto. - { eapply gc_of_constraints_declared. 2:tea. cbn. red in gu. unfold is_graph_of_uctx, gc_of_uctx in HG. - unfold uctx' in *. - destruct (gc_of_constraints uctx.2) => //; cbn in uctx', HG. } - eapply valid_valid_gc; tea. - Qed. - - Definition check_constraints_complete := - check_constraints_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - - Let levels_declared_sort (s : Sort.t) - := Sort.on_sort levels_declared True s. - - Lemma levels_univ_gc_declared_declared (s : Sort.t) - : levels_declared_sort s -> gc_levels_declared_sort uctx' s. - Proof using HG levels_declared. - destruct s; cbnr. - apply levels_gc_declared_declared. - Qed. - - Lemma check_leqb_sort_spec_gen' leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) s1 s2 - : levels_declared_sort s1 -> - levels_declared_sort s2 -> - check_leqb_sort_gen leqb_level_n_gen s1 s2 -> leq_sort uctx.2 s1 s2. - Proof using HG' Huctx'. - intros Hu1 Hu2. move => /orP [H | H]. - - apply eqb_true_iff in H as ->. - reflexivity. - - destruct s1, s2; cbn in *; trivial; try discriminate H. - now eapply check_leqb_universe_spec_gen'. - Qed. - - Definition check_leqb_sort_spec' := - check_leqb_sort_spec_gen' _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - - Lemma check_leqb_sort_complete_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) s1 s2 : - levels_declared_sort s1 -> - levels_declared_sort s2 -> - leq_sort uctx.2 s1 s2 -> - check_leqb_sort_gen leqb_level_n_gen s1 s2. - Proof using HG' Huctx'. - move : s1 s2 => [| | u1] [| | u2] //. cbn. - intros decl1 decl2 Hle. - unfold check_leqb_sort_gen. - toProp; right. - apply check_leqb_universe_complete_gen => //. - Qed. - - Definition check_leqb_sort_complete := - check_leqb_sort_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - - Lemma check_eqb_sort_spec_gen' leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) s1 s2 - : levels_declared_sort s1 -> - levels_declared_sort s2 -> - check_eqb_sort_gen leqb_level_n_gen s1 s2 -> eq_sort uctx.2 s1 s2. - Proof using HG' Huctx'. - move : s1 s2 => [| | u1] [| | u2] //; intros Hu1 Hu2. - { move/andP => [H HH] //. } - move/orP => [H | H]. - - apply eqb_true_iff in H as ->. + - toProp. destruct H. + apply (@elimP _ _ (eqb_spec _ _)) in H. noconf H. reflexivity. - - eapply check_eqb_universe_spec_gen'; eauto. - cbn in H. unfold check_eqb_universe_gen in *. - move/andP: H => [/orP [/orP [-> | ->] | ->] /orP [/orP [He | HH] | ->]] //. - all: try now rewrite orb_true_r. - now rewrite He. - apply NonEmptySetFacts.univ_expr_eqb_true_iff in HH as ->. - toProp; left; toProp; right; now apply NonEmptySetFacts.univ_expr_eqb_true_iff. - Qed. - - Definition check_eqb_sort_spec' := - check_eqb_sort_spec_gen' _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - - Lemma check_eqb_sort_complete_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u1 u2 : - levels_declared_sort u1 -> - levels_declared_sort u2 -> - eq_sort uctx.2 u1 u2 -> - check_eqb_sort_gen leqb_level_n_gen u1 u2. - Proof using HG' Huctx'. - move : u1 u2 => [| | u1] [| | u2] //. cbn. - intros decl1 decl2 Hle. - eapply check_eqb_universe_complete_gen in Hle => //; eauto. - unfold check_eqb_sort_gen, leqb_sort_gen, check_leqb_universe_gen; cbn. - unfold check_eqb_universe_gen in Hle. - move/orP: Hle => [/orP [-> | e] | /andP [H1 H2]] //=. - now rewrite orb_true_r. - apply eqb_eq in e as ->; rewrite eqb_refl //. - toProp; right; toProp; toProp; right; assumption. - Qed. - - Definition check_eqb_sort_complete := - check_eqb_sort_complete_gen _ (leqb_level_n_spec _ _ Huctx' HC' HG'). - -End CheckLeq2. - -Section AddLevelsCstrs. - - Definition add_uctx (uctx : VSet.t × GoodUnivConstraintSet.t) - (G : universes_graph) : universes_graph - := let levels := VSet.union uctx.1 G.1.1 in - let edges := add_level_edges uctx.1 G.1.2 in - let edges := add_cstrs uctx.2 edges in - (levels, edges, G.2). - - Definition uctx_of_udecl u : ContextSet.t := - (levels_of_udecl u, constraints_of_udecl u). - - Lemma gcs_elements_union s s' : GoodUnivConstraintSet.Empty s' -> - GoodUnivConstraintSet.Equal (GoodUnivConstraintSet.union s s') s. - Proof. gcsets. Qed. - - Lemma add_level_edges_spec e x g : - EdgeSet.In e (add_level_edges x g) <-> - (exists c, option_edge_of_level c = Some e /\ VSet.In c x) \/ EdgeSet.In e g. - Proof. - rewrite /add_level_edges VSet.fold_spec. - setoid_rewrite (VSetFact.elements_iff x). setoid_rewrite InA_In_eq. - induction (VSet.elements x) in g |- *; simpl. - intuition auto. now destruct H0 as [c [_ F]]. - rewrite {}IHl. - split. - * intros [[c [eq inl]]|?]; firstorder auto. - destruct a as [|s|n]; simpl in *; auto. - rewrite -> EdgeSet.add_spec in H. intuition auto. - subst e. left; exists (Level.level s); intuition auto. - rewrite -> EdgeSet.add_spec in H. intuition auto. - subst e. left; eexists; intuition eauto. reflexivity. - * intros [[[|s|n] [[= <-] [->|inl]]]|?]; simpl; auto; - rewrite -> ?EdgeSet.add_spec; simpl; intuition auto. - left. exists (Level.level s); auto. - left. exists (Level.lvar n); auto. - destruct a; simpl; rewrite -> ?EdgeSet.add_spec; simpl; intuition auto. - Qed. - - Lemma add_cstrs_union g ctrs1 ctrs2 : - EdgeSet.Equal (add_cstrs (GoodUnivConstraintSet.union ctrs1 ctrs2) g) (add_cstrs ctrs1 (add_cstrs ctrs2 g)). - Proof. - intros e. - rewrite !add_cstrs_spec. - setoid_rewrite GoodUnivConstraintSet.union_spec. - firstorder eauto. - Qed. - - Lemma add_level_edges_union g l1 l2 : - EdgeSet.Equal (add_level_edges (VSet.union l1 l2) g) - (add_level_edges l1 (add_level_edges l2 g)). - Proof. - intros e. - rewrite !add_level_edges_spec. - setoid_rewrite VSet.union_spec. - firstorder eauto. - Qed. - - Lemma add_level_edges_add_cstrs_comm l c g : - EdgeSet.Equal (add_level_edges l (add_cstrs c g)) - (add_cstrs c (add_level_edges l g)). - Proof. - intros e. - rewrite !add_level_edges_spec !add_cstrs_spec add_level_edges_spec. - firstorder auto. - Qed. - - Lemma forallb_spec {A : Type} (p : A -> bool) (l : list A) : - match forallb p l with - | true => forall x : A, In x l -> p x - | false => exists x : A, In x l × p x = false - end. - Proof. - induction l; cbn. - - now intros. - - destruct (forallb p l) eqn:heq. - rewrite andb_true_r. - destruct (p a) eqn:he. - intros x []. subst; auto. now apply IHl. - exists a; auto. - rewrite andb_false_r. destruct IHl as [x [inx hx]]. - exists x. intuition auto. - Qed. - - Lemma forallb_in {A : Type} (p : A -> bool) (l l' : list A) : - (forall x : A, In x l <-> In x l') -> - forallb p l = forallb p l'. - Proof. - intros heq. - generalize (forallb_spec p l). - generalize (forallb_spec p l'). - do 2 destruct forallb; intuition auto. - destruct H0 as [x [hin hp]]. - - specialize (H x (proj1 (heq x) hin)). red in H; congruence. - - destruct H as [x [hin hp]]. - specialize (H0 x (proj2 (heq _) hin)). congruence. - Qed. - - Lemma levelset_for_all_eq f f' l l' : - (forall x, f x = f' x) -> LevelSet.Equal l l' -> - LevelSet.for_all f l = LevelSet.for_all f' l'. - Proof. - intros Hf heq. - rewrite !VSetFact.for_all_b. - setoid_replace f with f'; auto. - eapply forallb_in. - intros x. - red in heq. - specialize (heq x). - rewrite -!InA_In_eq. - now rewrite -!LevelSetFact.elements_iff. - Qed. - - Lemma Nbar_max_spec n m v : - Nbar.max n m = v -> - (Nbar.le n m /\ v = m) \/ (Nbar.le m n /\ v = n). - Proof. - destruct n, m; cbn; firstorder. - destruct (Z.max_spec_le z z0); firstorder; try lia. - left. split; auto. congruence. - right. split; auto. congruence. - Qed. - - Lemma Nbar_max_spec' n m : - Nbar.le n m -> Nbar.max m n = m. - Proof. - destruct n, m; cbn; firstorder. f_equal. lia. - Qed. - - Lemma Nbar_max_spec'' n m : - Nbar.le n m -> Nbar.max n m = m. - Proof. - destruct n, m; cbn; firstorder. f_equal. lia. - Qed. - - Lemma Nbar_max_le n m k : Nbar.le (Nbar.max n m) k -> - Nbar.le n k /\ Nbar.le m k. - Proof. - intros hl. - generalize (Nbar_max_spec n m _ eq_refl). intuition subst; try rewrite H1 in hl; auto. - - now transitivity m. - - now transitivity n. - Qed. - - Lemma fold_left_max_spec (l : list Nbar.t) acc n : - fold_left Nbar.max l acc = n -> - (n = acc /\ (forall x, In x l -> Nbar.le x n)) \/ - (In n l /\ Nbar.le acc n /\ (forall x, In x l -> Nbar.le x n)). - Proof. - induction l in acc, n |- *. - - cbn. intros ->; firstorder. - - cbn. intros H. specialize (IHl _ _ H). - destruct IHl. firstorder auto. - symmetry in H0. apply Nbar_max_spec in H0. - firstorder auto. right. firstorder auto. subst; auto. now rewrite H2. subst x n. - rewrite H2. reflexivity. - left. firstorder auto. subst x n. now rewrite H2. - destruct H0. - right. firstorder auto. - now apply Nbar_max_le in H1. - now apply Nbar_max_le in H1. - Qed. - - - Lemma fold_left_max_spec' (l : list Nbar.t) acc n : - (n = acc /\ (forall x, In x l -> Nbar.le x n)) \/ - (In n l /\ Nbar.le acc n /\ (forall x, In x l -> Nbar.le x n)) -> - fold_left Nbar.max l acc = n. - Proof. - induction l in acc, n |- *. - - cbn. intuition. - - cbn. intros H. - apply IHl. intuition auto. - subst acc. - pose proof (H1 a). left. split. symmetry. eapply Nbar_max_spec'; auto. - intuition auto. - left. split; intuition auto. subst a. - symmetry. now apply Nbar_max_spec''. - right. intuition auto. specialize (H2 a). - apply Nbar.max_lub; auto. - Qed. - - Lemma fold_left_comm_ext (l l' : list Nbar.t) : - (forall x, In x l <-> In x l') -> - fold_left Nbar.max l ≐1 fold_left Nbar.max l'. - Proof. - intros eql acc. - generalize (fold_left_max_spec l acc _ eq_refl). - generalize (fold_left_max_spec l' acc _ eq_refl). - intuition auto. - - now rewrite H H0. - - rewrite H. apply fold_left_max_spec'. left; intuition auto. - specialize (H2 x (proj1 (eql _) H3)). congruence. - - rewrite H0. symmetry. - apply fold_left_max_spec'. left; intuition auto. - specialize (H4 x (proj2 (eql _) H2)). congruence. - - apply fold_left_max_spec'. right. - intuition auto. now apply eql. now apply H3, eql. - Qed. - - Lemma fold_left_comm_ext2 f f' (l l' : list (Z × Level.t)) : f ≐1 f' -> - (forall x, In x l <-> In x l') -> - fold_left Nbar.max (map f l) ≐1 fold_left Nbar.max (map f' l'). - Proof. - intros eqf eqg. - apply fold_left_comm_ext. - intros. - rewrite !in_map_iff. firstorder eauto. - specialize (eqg x0). exists x0; intuition auto. now rewrite -eqf. - exists x0. specialize (eqg x0). rewrite eqf; intuition auto. - Qed. - - Lemma Equal_graph_edges {e e'} : Equal_graph e e' -> - forall x, In x (EdgeSet.elements e.1.2) <-> In x (EdgeSet.elements e'.1.2). - Proof. - intros [vs [es ?]]. intros x. red in vs. - now rewrite -!InA_In_eq -!EdgeSetFact.elements_iff. - Qed. - - Lemma succs_proper x e e' v: Equal_graph e e' -> - In x (succs e v) <-> In x (succs e' v). - Proof. - intros eq. unfold succs. - rewrite !in_map_iff. - setoid_rewrite filter_In. - now setoid_rewrite (Equal_graph_edges eq). - Qed. - - Lemma fold_left_comm_ext3 f f' e e' x : f ≐1 f' -> - Equal_graph e e' -> - fold_left Nbar.max (map f (succs e x)) ≐1 - fold_left Nbar.max (map f' (succs e' x)). - Proof. - intros eqf eqg. - apply fold_left_comm_ext2; auto. - intros. now apply succs_proper. - Qed. - - #[global] Instance lsp_proper : Morphisms.Proper ((=_g) ==> Logic.eq ==> Logic.eq ==> Logic.eq)%signature lsp. - Proof. - intros e e' He x ? <- y ? <-. - unfold lsp, lsp0. - pose proof (proj1 He). - change (wGraph.V e) with e.1.1. - change (wGraph.V e') with e'.1.1. - replace (LevelSet.cardinal e'.1.1) with (LevelSet.cardinal e.1.1). - 2:{ now rewrite H. } - revert H. - generalize e.1.1, e'.1.1. intros t0 t1. - induction (LevelSet.cardinal t0) in t0, t1, e, e', He, x, y |- *. cbn; auto. - cbn. intros eqt. - replace (LevelSet.mem x t0) with (LevelSet.mem x t1). - 2:{ now rewrite eqt. } - destruct LevelSet.mem; auto. - apply fold_left_comm_ext3; auto. - intros [n0 y0]. f_equal. - apply (IHn e e' He). - intros elt. rewrite !LevelSet.remove_spec. - intuition auto. now apply eqt. now apply eqt. - Qed. - - #[global] Instance is_acyclic_proper : Morphisms.Proper ((=_g) ==> Logic.eq)%signature is_acyclic. - Proof. - intros e e' eq. - unfold is_acyclic. - eapply levelset_for_all_eq; tea. cbn. - intros x. now setoid_rewrite eq. - apply eq. - Qed. - - Lemma add_uctx_make_graph levels1 levels2 ctrs1 ctrs2 : - Equal_graph (add_uctx (levels1, ctrs1) (make_graph (levels2, ctrs2))) - (make_graph (VSet.union levels1 levels2, - GoodUnivConstraintSet.union ctrs1 ctrs2)). - Proof. - rewrite /make_graph /= /add_uctx /=. - unfold Equal_graph. split => //. split => //. - now rewrite add_cstrs_union /= add_level_edges_add_cstrs_comm add_level_edges_union. - Qed. - - Lemma add_uctx_subgraph uctx G : subgraph G (add_uctx uctx G). - Proof. - constructor. - - apply: VSetProp.union_subset_2. - - move=> x hx. - apply/add_cstrs_spec; right. - apply/add_level_edges_spec; by right. - - reflexivity. - Qed. - - Lemma acyclic_no_loop_add_uctx G uctx : - wGraph.acyclic_no_loop (add_uctx uctx G) -> wGraph.acyclic_no_loop G. - Proof. - apply: wGraph.subgraph_acyclic ; apply: add_uctx_subgraph. - Qed. - - Definition gc_result_eq (x y : option GoodUnivConstraintSet.t) := - match x, y with - | Some x, Some y => GoodUnivConstraintSet.eq x y - | None, None => True - | _, _ => False - end. - - Lemma add_gc_of_constraint_spec {cf:checker_flags} gc t : - match add_gc_of_constraint gc (Some t) with - | Some t' => - exists gcs, gc_of_constraint gc = Some gcs /\ - GCS.Equal t' (GCS.union t gcs) - | None => gc_of_constraint gc = None - end. - Proof. - unfold add_gc_of_constraint. - simpl. - destruct gc_of_constraint; simpl; auto. - eexists; split; eauto. reflexivity. - Qed. - - Lemma fold_left_add_gc_None {cf:checker_flags} l : fold_left (fun a e => add_gc_of_constraint e a) l None = None. - Proof. - induction l; simpl; auto. - Qed. - - Lemma fold_left_add_gc_Some_subset {cf:checker_flags} l t t': - fold_left (fun a e => add_gc_of_constraint e a) l (Some t) = Some t' -> - GCS.Subset t t'. - Proof. - induction l in t |- *; simpl; auto. intros [= ->]. reflexivity. - pose proof (add_gc_of_constraint_spec a t). - destruct add_gc_of_constraint; simpl. - intros. specialize (IHl _ H0). - destruct H as [gcs [gca eq]]. - rewrite -> eq in IHl. gcsets. - now rewrite fold_left_add_gc_None. - Qed. - - Variant gc_of_constraints_view {cf:checker_flags} (s : UnivConstraintSet.t) : option GoodUnivConstraintSet.t -> Type := - | gc_of_constraints_ok l : - (forall gc, GoodUnivConstraintSet.In gc l <-> - (exists c gcs, gc_of_constraint c = Some gcs /\ UnivConstraintSet.In c s /\ GoodUnivConstraintSet.In gc gcs)) -> - (forall c, UnivConstraintSet.In c s -> - exists gcs, gc_of_constraint c = Some gcs /\ GoodUnivConstraintSet.Subset gcs l) -> - gc_of_constraints_view s (Some l) - | gc_of_constraints_none : - (exists c, UnivConstraintSet.In c s /\ gc_of_constraint c = None) -> - gc_of_constraints_view s None. - - Lemma gc_of_constraintsP {cf:checker_flags} s : gc_of_constraints_view s (gc_of_constraints s). - Proof. - unfold gc_of_constraints. - rewrite UnivConstraintSet.fold_spec. - destruct fold_left eqn:eq. - - constructor. - + intros. - setoid_rewrite ConstraintSetFact.elements_iff. setoid_rewrite InA_In_eq. - transitivity ((exists (c : LevelConstraint.t) (gcs : GoodUnivConstraintSet.t), - gc_of_constraint c = Some gcs /\ - In c (UnivConstraintSet.elements s) /\ GoodUnivConstraintSet.In gc gcs) \/ GCS.In gc GCS.empty). - 2:gcsets. - revert eq. - generalize (GCS.empty). - induction (UnivConstraintSet.elements s) in t0 |- *; simpl in *. - intros ? [= ->]. firstorder auto. - intros t' Ht'. - pose proof (add_gc_of_constraint_spec a t'). - destruct add_gc_of_constraint eqn:addgc. - destruct H as [gcs [gceq cseq]]. - specialize (IHl _ _ Ht'). - rewrite {}IHl. - rewrite cseq GCS.union_spec. - split. - * intros [[c [gcs' [gceq' [incl ingcgcs']]]]|[]]; auto. - left. exists c, gcs'; intuition auto. - left. - exists a, gcs; intuition auto. - * intros [[c [gcs' [gceq' [[->|incl] ingcgcs']]]]|?]; auto. - ++ rewrite gceq in gceq'. noconf gceq'. auto. - ++ left. exists c, gcs'. intuition auto. - * rewrite fold_left_add_gc_None in Ht'. discriminate. - + intros c. - setoid_rewrite ConstraintSetFact.elements_iff; setoid_rewrite InA_In_eq at 1. - revert eq. - generalize (GCS.empty). - induction (UnivConstraintSet.elements s) in t0 |- *; simpl in *. - intros ? [= ->]. firstorder auto. - intros t' Ht'. - pose proof (add_gc_of_constraint_spec a t'). - destruct add_gc_of_constraint eqn:addgc. - destruct H as [gcs [gceq cseq]]. - specialize (IHl _ _ Ht'). - intros [->|incl]. eexists; split; eauto. - intros gc gcin. - apply fold_left_add_gc_Some_subset in Ht'. - rewrite -> cseq in Ht'. gcsets. - now specialize (IHl incl). - now rewrite fold_left_add_gc_None in Ht'. - - constructor. - setoid_rewrite ConstraintSetFact.elements_iff; setoid_rewrite InA_In_eq at 1. - revert eq. - generalize GCS.empty. - induction (UnivConstraintSet.elements s); simpl in * => //. - intros t' eq. - pose proof (add_gc_of_constraint_spec a t'). - destruct add_gc_of_constraint eqn:addgc. - destruct H as [gcs [gceq cseq]]. - specialize (IHl _ eq). - destruct IHl as [c [incl gcn]]. - exists c; intuition auto. - exists a; intuition auto. - Qed. - - Lemma gc_of_constraints_union {cf:checker_flags} S S' : - gc_result_eq (gc_of_constraints (UnivConstraintSet.union S S')) - (S1 <- gc_of_constraints S ;; - S2 <- gc_of_constraints S' ;; - ret (GoodUnivConstraintSet.union S1 S2)). - Proof. - case: (gc_of_constraintsP S) => [GS HS HS0|[c [incs gcn]]]; simpl. - case: (gc_of_constraintsP S') => [GS' HS' HS'0|GS']; simpl. - case: (gc_of_constraintsP (UnivConstraintSet.union S S')) => [GSS' HSS' HSS'0|[c [inc gcn]]]. - simpl. - - intros gc. - rewrite HSS' GCS.union_spec HS HS'. - setoid_rewrite UnivConstraintSet.union_spec. - split. intros [c [gcs ?]]. intuition auto. - left; firstorder auto. - right; firstorder auto. - intros [[c [gcs ?]]|[c [gcs ?]]]; exists c, gcs; intuition auto. - - cbn. apply UnivConstraintSet.union_spec in inc. - destruct inc. - specialize (HS0 _ H). rewrite gcn in HS0. now destruct HS0. - specialize (HS'0 _ H). rewrite gcn in HS'0. now destruct HS'0. - - destruct GS' as [c [inc gcn]]. - case: (gc_of_constraintsP (UnivConstraintSet.union S S')) => [GSS' HSS' HSS'0|[c' [inc' gcn']]]. - cbn. - specialize (HSS'0 c). - rewrite -> UnivConstraintSet.union_spec in HSS'0. - specialize (HSS'0 (or_intror inc)) as [gcs [eq _]]. - now congruence. - split. - - case: (gc_of_constraintsP (UnivConstraintSet.union S S')) => [GSS' HSS' HSS'0|[c' [inc' gcn']]]. - cbn. - specialize (HSS'0 c). - rewrite -> UnivConstraintSet.union_spec in HSS'0. - specialize (HSS'0 (or_introl incs)) as [gcs [eq _]]. - now congruence. - split. - Qed. - - Lemma gc_of_uctx_union `{checker_flags} uctx1 uctx2 gc1 gc2 : - gc_of_uctx uctx1 = Some gc1 -> gc_of_uctx uctx2 = Some gc2 -> - ∑ gc, gc_of_uctx (ContextSet.union uctx1 uctx2) = Some (LevelSet.union gc1.1 gc2.1, gc ) /\ GCS.eq gc (GCS.union gc1.2 gc2.2). - Proof. - unfold gc_of_uctx. - pose proof (H' := gc_of_constraints_union uctx1.2 uctx2.2). - move=> eq1 eq2; move: eq1 eq2 H'. - case: (gc_of_constraints _) => //?. - case: (gc_of_constraints _) => //?. - case: (gc_of_constraints _) => //=? [=] <- [=] <- /=. - eexists; split; [reflexivity| eassumption]. + toProp. destruct H as [hle hle']. + apply (check_leqb_universe_spec_gen _ leqb_correct) in hle'. + apply (check_leqb_universe_spec_gen _ leqb_correct) in hle. + unfold valid_cstr, valid0_cstr in hle, hle'. + apply antisymmetry; unfold Universes.leq_universe, Universes.leq0_universe; + destruct check_univs => //. + now move=> v /hle; intros s; depelim s. + now move=> v /hle'; intros s; depelim s. + all:split; now apply levels_declared_uctx. + - toProp; right. + apply partial_order_equivalence in H as [H H']. + toProp; apply/(check_leqb_universe_spec_gen _ leqb_correct). + * split; now apply levels_declared_uctx. + * move: H; rewrite /Universes.leq_universe /Universes.leq0_universe. + unfold valid_cstr, valid0_cstr. destruct check_univs => //. + move=> hv v /hv. now constructor. + * split; now apply levels_declared_uctx. + * move: H'; rewrite /Universes.leq_universe /Universes.leq0_universe. + unfold valid_cstr, valid0_cstr. destruct check_univs => //. + move=> hv v /hv. now constructor. Qed. -End AddLevelsCstrs. - -#[global] Instance proper_add_level_edges levels : Morphisms.Proper (wGraph.EdgeSet.Equal ==> wGraph.EdgeSet.Equal)%signature (add_level_edges levels). -Proof. - intros e e' he. - rewrite /add_level_edges. - rewrite !VSet.fold_spec. - induction (VSet.elements levels) in e, e', he |- *; cbn; auto. - apply IHl. destruct variable_of_level => //. - now rewrite he. -Qed. - -#[global] Instance proper_add_uctx cstrs : Morphisms.Proper ((=_g) ==> Equal_graph)%signature (add_uctx cstrs). -Proof. - intros g g' eq. rewrite /add_uctx; cbn. - split. cbn. now rewrite (proj1 eq). - cbn. split => //. - rewrite /add_level_edges. now rewrite (proj1 (proj2 eq)). - apply eq. -Qed. - -#[global] Instance gc_of_constraints_proper {cf : checker_flags} : Proper ((=_ucset) ==> R_opt GoodUnivConstraintSet.Equal) gc_of_constraints. -Proof. - intros c c' eqc; cbn. - destruct (gc_of_constraintsP c); - destruct (gc_of_constraintsP c'); cbn. - - intros cs; rewrite i i0. firstorder eauto. - - destruct e0 as [cs [incs gcn]]. - apply eqc in incs. destruct (e cs incs) as [? []]. congruence. - - destruct e as [cs [incs gcn]]. - apply eqc in incs. destruct (e0 cs incs) as [? []]. congruence. - - exact I. -Qed. - -#[global] Instance proper_add_level_edges' : Morphisms.Proper ((=_lset) ==> wGraph.EdgeSet.Equal ==> wGraph.EdgeSet.Equal)%signature add_level_edges. -Proof. - intros l l' hl e e' <-. - intros x; rewrite !add_level_edges_spec. firstorder eauto. -Qed. - -#[global] Instance make_graph_proper : Proper ((=_gcs) ==> (=_g)) make_graph. -Proof. - intros [v c] [v' c'] [eqv eqc]; cbn. - unfold make_graph; cbn in *. - split; cbn; auto. - split; cbn; try reflexivity. - now rewrite eqc eqv. -Qed. - - -From Stdlib Require Import SetoidTactics. - -#[global] Instance is_graph_of_uctx_proper {cf : checker_flags} G : Proper ((=_cs) ==> iff) (is_graph_of_uctx G). -Proof. - intros [l c] [l' c'] [eql eqc]; cbn. - unfold is_graph_of_uctx; cbn. cbn in *. - pose proof (gc_of_constraints_proper _ _ eqc). - destruct (gc_of_constraints c); cbn in *; destruct (gc_of_constraints c'); cbn. - now setoid_replace (l, t0) with (l', t1) using relation gcs_equal. elim H. elim H. - intuition. -Qed. - - -#[global] Instance subgraph_proper : Proper ((=_g) ==> (=_g) ==> iff) subgraph. -Proof. - unshelve apply: proper_sym_impl_iff_2. - move=> g1 g1' [eqv1 [eqe1 eqs1]] g2 g2' [eqv2 [eqe2 eqs2]]. - move=> [*]; constructor. - + by rewrite <- eqv1, <- eqv2. - + by rewrite <- eqe1, <- eqe2. - + by rewrite <- eqs1, <- eqs2. -Qed. - -#[global] Instance full_subgraph_proper : Proper ((=_g) ==> (=_g) ==> iff) full_subgraph. -Proof. - unshelve apply: proper_sym_impl_iff_2. - move=> g1 g1' eq1 g2 g2' eq2. - move=> [?] lsp_dom; constructor=> *; rewrite -eq1 -eq2 //. - apply lsp_dom; rewrite /wGraph.V (proj1 eq1) //. -Qed. - -Lemma add_uctx_make_graph2 uctx1 uctx2 : - add_uctx uctx2 (make_graph uctx1) =_g make_graph (VSet.union uctx2.1 uctx1.1, GCS.union uctx2.2 uctx1.2). -Proof. destruct uctx1, uctx2; apply: add_uctx_make_graph. Qed. - -Lemma gc_of_uctx_levels `{checker_flags} udecl uctx : - gc_of_uctx udecl = Some uctx -> ContextSet.levels udecl = uctx.1. -Proof. - rewrite /gc_of_uctx. - case: (gc_of_constraints _)=> //= ? [=] <- //. -Qed. - + Definition check_eqb_sort_spec := check_eqb_sort_spec_gen _ checkb_spec. -Definition gctx_union gctx1 gctx2 := - (LS.union gctx1.1 gctx2.1, GCS.union gctx1.2 gctx2.2). - - -(* The other implication between invariants does not hold - (take for example uctx = ({}, {lzero < Level "foo"}) *) -Lemma global_uctx_graph_invariants `{cf : checker_flags} [uctx gph] : - is_graph_of_uctx gph uctx -> global_uctx_invariants uctx -> wGraph.invariants gph. -Proof. - move=> /on_SomeP [? [Huctx <-]] H0. - pose proof (gc_of_uctx_invariants _ _ Huctx H0). - apply: make_graph_invariants. -Qed. - -#[export] Existing Instance correct_labelling_proper. - -Lemma correct_labelling_of_valuation_satisfies_iff `{checker_flags} [uctx G v] : - is_graph_of_uctx G uctx -> - global_uctx_invariants uctx -> - correct_labelling G (labelling_of_valuation v) <-> satisfies v uctx.2. -Proof. - move=> /on_SomeP [gctx [eqSome <-]] inv. - rewrite -make_graph_spec gc_of_constraints_spec (gc_of_uctx_of_constraints _ _ eqSome) //. -Qed. - -Lemma is_graph_of_uctx_levels `{cf:checker_flags} G uctx : - is_graph_of_uctx G uctx -> - forall x, VSet.In x (wGraph.V G) <-> LS.In x uctx.1. -Proof. - move=> /on_SomeP [gctx [eqSome HG]] ?. - rewrite /wGraph.V -(proj1 HG) /= -(gc_of_uctx_levels _ _ eqSome) //. -Qed. - -Lemma val_valuation_of_labelling2 `{checker_flags} [uctx G l] : - is_graph_of_uctx G uctx -> - global_uctx_invariants uctx -> - correct_labelling G l -> - forall x, VSet.In x uctx.1 -> - val (valuation_of_labelling l) x = l x. -Proof. - move=> /on_SomeP [gctx [eqSome HG]] inv hl x hx. - apply: val_valuation_of_labelling. - 1: symmetry; eassumption. - 2: done. - red; rewrite -(gc_of_uctx_levels _ _ eqSome) //. -Qed. - -Lemma correct_valuation_of_labelling_satisfies `{checker_flags} [uctx G l] : - is_graph_of_uctx G uctx -> - global_uctx_invariants uctx -> - correct_labelling G l -> satisfies (valuation_of_labelling l) uctx.2. -Proof. - move=> /on_SomeP [gctx [eqSome <-]] inv. - rewrite gc_of_constraints_spec (gc_of_uctx_of_constraints _ _ eqSome) /=. - apply: make_graph_spec'; by apply: gc_of_uctx_invariants. -Qed. +End CheckLeq. +(* Lemma consistent_ext_on_full_ext0 `{cf: checker_flags} [uctx G uctx' G'] `{wGraph.invariants G, wGraph.invariants G', wGraph.acyclic_no_loop G'} : wGraph.subgraph G G' -> @@ -1732,75 +644,24 @@ Proof. move=> /[dup] ? /(global_uctx_graph_invariants HG') ? /wGraph.is_acyclic_spec ??. by apply: consistent_ext_on_full_ext0. Qed. +*) -Lemma is_graph_of_uctx_add `{cf : checker_flags} [gph uctx uctx' gctx'] : - gc_of_uctx uctx' = Some gctx' -> - is_graph_of_uctx gph uctx -> - is_graph_of_uctx (add_uctx gctx' gph) (ContextSet.union uctx' uctx). -Proof. - move=> h' /on_SomeP [gctx [h eq]]. - red. - move: (gc_of_uctx_union _ _ _ _ h' h) => [gc'' [-> /= ?]]. - have eq' : (gcs_equal (LS.union gctx'.1 gctx.1, gc'') (gctx_union gctx' gctx)) by split=> //=. - rewrite <- eq, eq'; symmetry; apply: add_uctx_make_graph2. -Qed. - -Lemma is_consistent_spec2 `{cf : checker_flags} [gph gctx] : - is_graph_of_uctx gph gctx -> is_consistent gctx <-> wGraph.is_acyclic gph. -Proof. - unfold is_consistent. by move=> /on_SomeP [? [-> <-]]. -Qed. - -From MetaRocq.Utils Require Import MRUtils. - -Lemma global_uctx_invariants_union_or lvls1 lvls2 cs - : global_uctx_invariants (lvls1, cs) \/ global_uctx_invariants (lvls2, cs) - -> global_uctx_invariants (LevelSet.union lvls1 lvls2, cs). -Proof. - cbv [global_uctx_invariants uctx_invariants UnivConstraintSet.For_all declared_univ_cstr_levels]; cbn [fst snd ContextSet.levels ContextSet.constraints]. - repeat first [ apply conj - | progress intros - | progress cbv beta iota in * - | progress destruct ? - | progress destruct_head'_and - | progress destruct_head'_or - | progress split_and - | rewrite !LevelSet.union_spec - | progress specialize_dep_under_binders_by eapply pair - | solve [ eauto ] ]. -Qed. - -Lemma global_gc_uctx_invariants_union_or lvls1 lvls2 cs - : global_gc_uctx_invariants (lvls1, cs) \/ global_gc_uctx_invariants (lvls2, cs) - -> global_gc_uctx_invariants (VSet.union lvls1 lvls2, cs). -Proof. - cbv [global_gc_uctx_invariants uctx_invariants GoodUnivConstraintSet.For_all declared_univ_cstr_levels]; cbn [fst snd ContextSet.levels ContextSet.constraints]. - repeat first [ apply conj - | progress intros - | progress cbv beta iota in * - | progress subst - | progress destruct ? - | progress destruct_head'_and - | progress destruct_head'_or - | progress split_and - | rewrite !VSet.union_spec - | progress specialize_dep_under_binders_by eassumption - | solve [ eauto ] ]. -Qed. +Lemma init_constraints_of_levels_union ls ls' : + UnivConstraintSet.Equal (init_constraints_of_levels (LevelSet.union ls ls')) + (UnivConstraintSet.union (init_constraints_of_levels ls) (init_constraints_of_levels ls')). +Proof. Admitted. -Lemma gc_levels_declared_union_or lvls1 lvls2 cstr u - : gc_levels_declared (lvls1, cstr) u \/ gc_levels_declared (lvls2, cstr) u - -> gc_levels_declared (VSet.union lvls1 lvls2, cstr) u. +Lemma is_graph_of_uctx_add `{cf : checker_flags} [m uctx uctx' m'] : + push_uctx m uctx' = Some m' -> + is_model_of_uctx m uctx -> + is_model_of_uctx m' (ContextSet.union uctx' uctx). Proof. - cbv [gc_levels_declared LevelExprSet.For_all gc_expr_declared on_Some_or_None LevelExpr.get_noprop]; cbn [fst]. - repeat first [ apply conj - | progress intros - | progress cbv beta iota in * - | progress destruct ? - | progress destruct_head'_and - | progress destruct_head'_or - | progress split_and - | rewrite !VSet.union_spec - | progress specialize_dep_under_binders_by eassumption - | solve [ eauto ] ]. + move=> he; have := push_uctx_spec m uctx'. rewrite he. + move=> [hlev hcstrs]. unfold is_model_of_uctx. + move=> [hl hr]. rewrite hlev hl. + rewrite LevelSetProp.union_assoc. split. lsets. + rewrite hcstrs hr. + rewrite init_constraints_of_levels_union /ContextSet.levels. + rewrite UnivConstraintSetProp.union_assoc /ContextSet.constraints. + ucsets. Qed. From eb70a240b7c7cec0854204ae470cfb19525462b7 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 3 Nov 2025 21:52:07 +0100 Subject: [PATCH 117/164] Adapted universes decidability proofs --- common/_RocqProject.in | 4 +- common/theories/LoopChecking/Deciders.v | 2 +- common/theories/LoopChecking/Interfaces.v | 1 + .../theories/LoopChecking/UnivLoopChecking.v | 8 +- common/theories/Universes.v | 72 +- common/theories/UniversesDec.v | 944 ++++-------------- common/theories/uGraph.v | 256 ++++- 7 files changed, 455 insertions(+), 832 deletions(-) diff --git a/common/_RocqProject.in b/common/_RocqProject.in index 0dfacbcc1..760aa500a 100644 --- a/common/_RocqProject.in +++ b/common/_RocqProject.in @@ -2,7 +2,6 @@ theories/Primitive.v theories/UnivConstraintType.v -# theories/uGraph.v theories/config.v theories/Kernames.v theories/Universes.v @@ -25,4 +24,5 @@ theories/LoopChecking/Model.v theories/LoopChecking/Models.v theories/LoopChecking/PartialLoopChecking.v theories/LoopChecking/Deciders.v -theories/LoopChecking/UnivLoopChecking.v \ No newline at end of file +theories/LoopChecking/UnivLoopChecking.v +theories/uGraph.v diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 555668d03..e4c4e2bf8 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -3307,7 +3307,7 @@ Proof. clear H Heqcall. intros b [= <-]. apply check_clause_wf_spec. Qed. -Print reflect. + Inductive reflect_opt (PN PS : Prop) : option bool -> Prop := | ReflectNone : PN -> reflect_opt PN PS None | ReflectSomeT : PS -> reflect_opt PN PS (Some true) diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 8b42f36da..29d283feb 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -98,6 +98,7 @@ Bind Scope levels_scope with LevelSet.t. Ltac lsets := LevelSetDecide.fsetdec. Notation "(=_lset)" := LevelSet.Equal (at level 0) : levels_scope. Infix "=_lset" := LevelSet.Equal (at level 70) : levels_scope. +Notation "(⊂_lset)" := LevelSet.Subset (at level 0) : levels_scope. Infix "⊂_lset" := LevelSet.Subset (at level 70) : levels_scope. Infix "∪" := LevelSet.union (at level 60) : levels_scope. Infix "=m" := LevelMap.Equal (at level 50) : levels_scope. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index d317cbb5e..872f33d6e 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -112,7 +112,7 @@ End LevelExprZSet. Module LevelExprZSetFacts := WFactsOn LevelExprZ LevelExprZSet. Module LevelExprZSetProp := MSetProperties.OrdProperties LevelExprZSet. -Module LS <: LevelSets. +Module LS (* <: LevelSets *). Module Level := MoreLevel. Module LevelSet := LevelSet. Module LevelExpr := LevelExprZ. @@ -1023,7 +1023,11 @@ End ZUnivConstraint. Definition declared_univ_cstrs_levels levels cstrs := UnivConstraintSet.For_all (declared_univ_cstr_levels levels) cstrs. Lemma satisfies_singleton v x : satisfies v (UnivConstraintSet.singleton x) <-> satisfies0 v x. - Proof. Admitted. + Proof. + split. + - move=>/(_ x) => /fwd //. ucsets. + - move=> sat cl. now rewrite UnivConstraintSet.singleton_spec => ->. + Qed. Lemma enforce_constraints_aux_spec m cstrs : match enforce_constraints_aux m cstrs with diff --git a/common/theories/Universes.v b/common/theories/Universes.v index f094d9a39..b16e02a5b 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -1364,41 +1364,94 @@ Qed. *) (** **** Lemmas about eq and leq **** *) + Global Instance eq0_universe_refl φ : Reflexive (eq0_universe φ). + Proof using Type. + intros u v. reflexivity. + Qed. + Global Instance eq_universe_refl φ : Reflexive (eq_universe φ). Proof using Type. intros u; unfold_univ_rel. Qed. + Global Instance leq0_universe_refl φ : Reflexive (leq0_universe φ). + Proof using Type. + intros u v; reflexivity. + Qed. + Global Instance leq_universe_refl φ : Reflexive (leq_universe φ). Proof using Type. intros u; unfold_univ_rel. Qed. + Global Instance eq0_universe_sym φ : Symmetric (eq0_universe φ). + Proof using Type. + intros u u' H; unfold_univ_rel0. + lia. + Qed. + Global Instance eq_universe_sym φ : Symmetric (eq_universe φ). Proof using Type. intros u u' H; unfold_univ_rel. lia. Qed. + Global Instance eq0_universe_trans φ : Transitive (eq0_universe φ). + Proof using Type. + intros u u' u'' H1 H2; unfold_univ_rel0. + lia. + Qed. + Global Instance eq_universe_trans φ : Transitive (eq_universe φ). Proof using Type. intros u u' u'' H1 H2; unfold_univ_rel. lia. Qed. + Global Instance leq0_universe_trans φ : Transitive (leq0_universe φ). + Proof using Type. + intros u u' u'' H1 H2; unfold_univ_rel0. + lia. + Qed. + Global Instance leq_universe_trans φ : Transitive (leq_universe φ). Proof using Type. intros u u' u'' H1 H2; unfold_univ_rel. lia. Qed. - Lemma eq_universe_leq_universe φ u u' : - eq_universe φ u u' <-> leq_universe φ u u' /\ leq_universe φ u' u. + Global Instance leq0_universe_preorder ϕ : PreOrder (leq0_universe ϕ) := {}. + + Global Instance eq0_universe_equivalence ϕ : Equivalence (eq0_universe ϕ) := {}. + + Lemma eq0_universe_leq0_universe φ u u' : + eq0_universe φ u u' <-> leq0_universe φ u u' /\ leq0_universe φ u' u. Proof using Type. - unfold_univ_rel => //. split. - intros H. split; unfold_univ_rel0; lia. - - intros [H1 H2]. unfold_univ_rel0; lia. + - intros [H1 H2]; unfold_univ_rel0; lia. + Qed. + + Global Instance leq0_universe_partial_order ϕ : PartialOrder (eq0_universe ϕ) (leq0_universe ϕ). + Proof. + intros x; cbn. apply eq0_universe_leq0_universe. + Qed. + + Global Instance leq_universe_preorder ϕ : PreOrder (leq_universe ϕ) := {}. + + Global Instance eq_universe_equivalence ϕ : Equivalence (eq_universe ϕ) := {}. + + Lemma eq_universe_leq_universe φ u u' : + eq_universe φ u u' <-> leq_universe φ u u' /\ leq_universe φ u' u. + Proof using Type. + unfold eq_universe, leq_universe. + destruct check_univs => //. + apply eq0_universe_leq0_universe. + Qed. + + Global Instance leq_universe_partial_order ϕ : PartialOrder (eq_universe ϕ) (leq_universe ϕ). + Proof. + intros x; cbn. apply eq_universe_leq_universe. Qed. Lemma leq_universe_sup_l φ u1 u2 : leq_universe φ u1 (Universe.sup u1 u2). @@ -1419,10 +1472,6 @@ Qed. *) intros u u'. apply eq_universe_leq_universe. Qed. - Global Instance eq_universe_equivalence φ : Equivalence (eq_universe φ) := Build_Equivalence _ _ _ _. - - Global Instance leq_universe_preorder φ : PreOrder (leq_universe φ) := Build_PreOrder _ _ _. - Global Instance lt_universe_irrefl {c: check_univs} φ (H: consistent φ) : Irreflexive (lt_universe φ). Proof using Type. intro u. unfold complement. @@ -1451,13 +1500,6 @@ Qed. *) Global Instance leq_universe_antisym φ : Antisymmetric _ (eq_universe φ) (leq_universe φ). Proof using Type. intros t u tu ut. now apply eq_universe_leq_universe. Qed. - Global Instance leq_universe_partial_order φ - : PartialOrder (eq_universe φ) (leq_universe φ). - Proof. - intros x y; split; apply eq_universe_leq_universe. - Defined. - - Global Instance compare_universe_subrel φ pb : subrelation (eq_universe φ) (compare_universe φ pb). Proof using Type. destruct pb; tc. diff --git a/common/theories/UniversesDec.v b/common/theories/UniversesDec.v index 798783b92..7859f1871 100644 --- a/common/theories/UniversesDec.v +++ b/common/theories/UniversesDec.v @@ -1,55 +1,37 @@ -From Stdlib Require Import PArith NArith ZArith Lia. +From Stdlib Require Import PArith NArith ZArith Lia ssreflect ssrbool ssrfun Morphisms. +From Equations Require Import Equations. From MetaRocq.Utils Require Import MRList MROption MRUtils. From MetaRocq.Common Require Import uGraph. From MetaRocq.Common Require Import Universes. (* Import wGraph. *) +Import UnivLoopChecking.UnivLoopChecking. + +Definition levels_of_cs (cs : UnivConstraintSet.t) : LevelSet.t := + LevelSet.remove Level.lzero (univ_constraints_levels cs). + +Lemma levelset_add_remove {l s} : LevelSet.add l (LevelSet.remove l s) =_lset LevelSet.add l s. +Proof. + intros l'. split. lsets. + destruct (Classes.eq_dec l l'). subst. + - move/LevelSet.add_spec => -[heq|hin] //; lsets. + - move/LevelSet.add_spec => -[heq|hin] //; lsets. +Qed. + +Lemma levelset_subset_add {ls ls' l} : LevelSet.Subset ls ls' -> LevelSet.Subset ls (LevelSet.add l ls'). +Proof. + intros l' hin. lsets. +Qed. -Definition levels_of_cs (cstr : UnivConstraintSet.t) : LevelSet.t - := UnivConstraintSet.fold (fun '(l1, _, l2) acc => LevelSet.add l1 (LevelSet.add l2 acc)) cstr (LevelSet.singleton Level.lzero). Lemma levels_of_cs_spec cstr (lvls := levels_of_cs cstr) : uGraph.global_uctx_invariants (lvls, cstr). Proof. subst lvls; cbv [levels_of_cs]. - cbv [uGraph.global_uctx_invariants uGraph.uctx_invariants UnivConstraintSet.For_all declared_univ_cstr_levels]; cbn [fst snd ContextSet.levels ContextSet.constraints]. - repeat first [ apply conj - | progress intros - | progress destruct ? - | match goal with - | [ |- ?x \/ ?y ] - => first [ lazymatch x with context[LevelSet.In ?l (LevelSet.singleton ?l)] => idtac end; - left - | lazymatch y with context[LevelSet.In ?l (LevelSet.singleton ?l)] => idtac end; - right ] - | [ H : UnivConstraintSet.In ?l ?c |- ?x \/ ?y ] - => first [ lazymatch x with context[LevelSet.In _ (UnivConstraintSet.fold _ c _)] => idtac end; - left - | lazymatch y with context[LevelSet.In _ (UnivConstraintSet.fold _ c _)] => idtac end; - right ] - end - | rewrite !LevelSet.union_spec - | progress rewrite <- ?UnivConstraintSet.elements_spec1, ?InA_In_eq in * - | rewrite ConstraintSetProp.fold_spec_right ]. - all: lazymatch goal with - | [ |- LevelSet.In Level.lzero (List.fold_right ?f ?init ?ls) ] - => first [ LevelSetDecide.fsetdec - | cut (LevelSet.In Level.lzero init); - [ generalize init; induction ls; intros; cbn in * - | LevelSetDecide.fsetdec ] ] - | [ H : List.In ?v ?ls |- LevelSet.In ?v' (List.fold_right ?f ?init (List.rev ?ls)) ] - => rewrite List.in_rev in H; - let ls' := fresh "ls" in - set (ls' := List.rev ls); - change (List.In v ls') in H; - change (LevelSet.In v' (List.fold_right f init ls')); - generalize init; induction ls'; cbn in * - end. - all: repeat first [ exfalso; assumption - | progress destruct_head'_or - | progress subst - | progress intros - | progress destruct ? - | rewrite !LevelSetFact.add_iff - | solve [ auto ] ]. + red. cbn. split. + - move=> /LevelSet.remove_spec => -[] //. + - move=> cl; cbn => hin. + apply declared_univ_cstr_levels_spec. + rewrite levelset_add_remove; apply levelset_subset_add. + move=> ls hin'. apply univ_constraints_levels_spec. exists cl. split => //. Qed. Definition consistent_dec ctrs : {@consistent ctrs} + {~@consistent ctrs}. @@ -58,736 +40,148 @@ Proof. destruct uGraph.is_consistent; [ left; apply H | right; intro H'; apply H in H' ]; auto. Defined. + + +(* Lemma global_uctx_invariants_subset {ls ls' cs} : + LevelSet.Subset ls ls' -> + global_uctx_invariants (ls', cs) -> + global_uctx_invariants (ls, cs). +Proof. + intros hs [hnz hu]; red in hu; cbn in hu; + red; cbn. split => //. now rewrite hs. + red; cbn. rewrite hs. +Qed. *) + + Definition levels_of_cs2 (cs1 cs2 : UnivConstraintSet.t) : LevelSet.t := LevelSet.union (levels_of_cs cs1) (levels_of_cs cs2). Lemma levels_of_cs2_spec cs1 cs2 (lvls := levels_of_cs2 cs1 cs2) : uGraph.global_uctx_invariants (lvls, cs1) /\ uGraph.global_uctx_invariants (lvls, cs2). Proof. - split; apply global_uctx_invariants_union_or; constructor; apply levels_of_cs_spec. + have [hnz hs] := levels_of_cs_spec cs1. + have [hnz' hs'] := levels_of_cs_spec cs2. + split. + - split. move=> /LevelSet.union_spec -[] hz; contradiction. + red; cbn. rewrite /lvls /levels_of_cs2 levelset_add_union. + eapply declared_univ_cstrs_levels_subset. 3:{ apply hs. } lsets. ucsets. + - split. move=> /LevelSet.union_spec -[] hz; contradiction. + red; cbn. rewrite /lvls /levels_of_cs2 levelset_add_union. + eapply declared_univ_cstrs_levels_subset. 3:{ apply hs'. } lsets. ucsets. Qed. Definition levels_of_cscs (cs : ContextSet.t) (cstr : UnivConstraintSet.t) : LevelSet.t := LevelSet.union (ContextSet.levels cs) (levels_of_cs2 cstr (ContextSet.constraints cs)). Lemma levels_of_cscs_spec cs cstr (lvls := levels_of_cscs cs cstr) - : uGraph.global_uctx_invariants (lvls, ContextSet.constraints cs) + : ~ LevelSet.In Level.lzero (ContextSet.levels cs) -> + uGraph.global_uctx_invariants (lvls, ContextSet.constraints cs) /\ uGraph.global_uctx_invariants (lvls, cstr). Proof. - generalize (levels_of_cs2_spec cstr (ContextSet.constraints cs)). - split; apply global_uctx_invariants_union_or; constructor; apply levels_of_cs2_spec. -Qed. - -Definition levels_of_universe (u : Universe.t) : VSet.t - := LevelExprSet.fold - (fun gc acc => match LevelExpr.get_noprop gc with - | Some l => VSet.add l acc - | None => acc - end) - u - VSet.empty. -Lemma levels_of_universe_spec u cstr (lvls := levels_of_universe u) - : gc_levels_declared (lvls, cstr) u. -Proof. - subst lvls; cbv [levels_of_universe gc_levels_declared gc_expr_declared on_Some_or_None LevelExpr.get_noprop]; cbn [fst snd]. - cbv [LevelExprSet.For_all]; cbn [fst snd]. - repeat first [ apply conj - | progress intros - | progress destruct ? - | exact I - | progress rewrite <- ?LevelExprSet.elements_spec1, ?InA_In_eq in * - | rewrite LevelExprSetProp.fold_spec_right ]. - all: lazymatch goal with - | [ H : List.In ?v ?ls |- VSet.In ?v' (List.fold_right ?f ?init (List.rev ?ls)) ] - => rewrite List.in_rev in H; - let ls' := fresh "ls" in - set (ls' := List.rev ls); - change (List.In v ls') in H; - change (VSet.In v' (List.fold_right f init ls')); - generalize init; induction ls'; cbn in * - end. - all: repeat first [ exfalso; assumption - | progress destruct_head'_or - | progress subst - | progress intros - | progress destruct ? - | rewrite !VSetFact.add_iff - | solve [ auto ] ]. -Qed. - -(** Gives an equivalent pair of [((lvls, cs), cstr)] such that -- [global_uctx_invariants (lvls, cs)] -- all levels used in cs are in lvls -- and constraints mentioning levels not in the original [lvls] are refreshed - *) -Definition uniquify_level_level (shared_levels : LevelSet.t) (shared_prefix : Byte.byte) (prefix : Byte.byte) (x : string) : string - := (String.String - (if LevelSet.mem (Level.level x) shared_levels - then shared_prefix - else prefix) - x). -Definition ununiquify_level_level (x : string) : string - := match x with - | String.EmptyString => String.EmptyString - | String.String _ x => x - end. -Definition uniquify_level_var (shared_levels : LevelSet.t) (total_sets : nat) (offset : nat) (x : nat) : nat - := x * S total_sets + (if LevelSet.mem (Level.lvar x) shared_levels - then O - else S offset). -Definition ununiquify_level_var (total_sets : nat) (x : nat) : nat - := Z.to_nat (Z.of_nat x / Z.of_nat (S total_sets)). -Definition uniquify_level (shared_levels : LevelSet.t) (shared_prefix : Byte.byte) (total_sets : nat) (prefix : Byte.byte) (offset : nat) (lvl : Level.t) : Level.t - := match lvl with - | Level.lzero => Level.lzero - | Level.level x => Level.level (uniquify_level_level shared_levels shared_prefix prefix x) - | Level.lvar x => Level.lvar (uniquify_level_var shared_levels total_sets offset x) - end. -Definition ununiquify_level (total_sets : nat) (lvl : Level.t) : Level.t - := match lvl with - | Level.lzero => Level.lzero - | Level.level x => Level.level (ununiquify_level_level x) - | Level.lvar x => Level.lvar (ununiquify_level_var total_sets x) - end. -Definition uniquify_constraint (shared_levels : LevelSet.t) (shared_prefix : Byte.byte) (total_sets : nat) (prefix : Byte.byte) (offset : nat) (c : UnivConstraintSet.elt) : UnivConstraintSet.elt - := let '((l1, c), l2) := c in - let u := uniquify_level shared_levels shared_prefix total_sets prefix offset in - ((u l1, c), u l2). -Definition ununiquify_constraint (total_sets : nat) (c : UnivConstraintSet.elt) : UnivConstraintSet.elt - := let '((l1, c), l2) := c in - let u := ununiquify_level total_sets in - ((u l1, c), u l2). -Definition uniquify_valuation (shared_levels : LevelSet.t) (shared_prefix : Byte.byte) (total_sets : nat) (prefix : Byte.byte) (offset : nat) (v : valuation) : valuation - := {| valuation_mono s - := v.(valuation_mono) (uniquify_level_level shared_levels shared_prefix prefix s) - ; valuation_poly n - := v.(valuation_poly) (uniquify_level_var shared_levels total_sets offset n) - |}. -Definition ununiquify_valuation (total_sets : nat) (v : valuation) : valuation - := {| valuation_mono s - := v.(valuation_mono) (ununiquify_level_level s) - ; valuation_poly n - := v.(valuation_poly) (ununiquify_level_var total_sets n) - |}. -Definition uniquify_level_for lvls (side:bool) lvl - := uniquify_level lvls "b"%byte 2 (if side then "l" else "r")%byte (if side then 0 else 1) lvl. -Definition uniquify_constraint_for lvls (side:bool) c - := uniquify_constraint lvls "b"%byte 2 (if side then "l" else "r")%byte (if side then 0 else 1) c. -Definition uniquify_valuation_for lvls (side:bool) v - := uniquify_valuation lvls "b"%byte 2 (if side then "l" else "r")%byte (if side then 0 else 1) v. -Definition declare_and_uniquify_levels : ContextSet.t * UnivConstraintSet.t -> ContextSet.t * UnivConstraintSet.t - := fun '(cs, cstr) - => let '(lvls, cs) := (ContextSet.levels cs, ContextSet.constraints cs) in - let '(cs_all_lvls, cstr_all_lvls) := (levels_of_cs cs, levels_of_cs cstr) in - ((LevelSet.fold - (fun l => LevelSet.add (uniquify_level_for lvls true l)) - cs_all_lvls - (LevelSet.fold - (fun l => LevelSet.add (uniquify_level_for lvls true l)) - lvls - (LevelSet.singleton Level.lzero)), - UnivConstraintSet.fold - (fun c => UnivConstraintSet.add (uniquify_constraint_for lvls true c)) - cs - UnivConstraintSet.empty), - UnivConstraintSet.fold - (fun c => UnivConstraintSet.add (uniquify_constraint_for lvls false c)) - cstr - UnivConstraintSet.empty). - -Definition declare_and_uniquify_and_combine_levels : ContextSet.t * UnivConstraintSet.t -> ContextSet.t * UnivConstraintSet.t - := fun '(cs, cstr) - => let cscstr := declare_and_uniquify_levels (cs, cstr) in - let '(cs, cstr) := (cscstr.1, cscstr.2) in - (cs, UnivConstraintSet.union cstr (ContextSet.constraints cs)). - -Definition combine_valuations (shared_prefix prefixl prefixr : Byte.byte) (total_sets : nat := 2) (vd vl vr : valuation) : valuation - := let __ := reflectEq_Z in - {| valuation_mono s - := match s with - | ""%bs => vd.(valuation_mono) s - | String.String p _ - => if p == shared_prefix - then vd.(valuation_mono) s - else if p == prefixl - then vl.(valuation_mono) s - else if p == prefixr - then vr.(valuation_mono) s - else vd.(valuation_mono) s - end - ; valuation_poly n - := let r := (Z.of_nat n mod 3)%Z in - if r == 0%Z - then vd.(valuation_poly) n - else if r == 1%Z - then vl.(valuation_poly) n - else if r == 2%Z - then vr.(valuation_poly) n - else vd.(valuation_poly) n - |}. - -Lemma ConstraintSet_In_fold_add c cs1 cs2 f - : UnivConstraintSet.In c (UnivConstraintSet.fold (fun c => UnivConstraintSet.add (f c)) cs1 cs2) - <-> (UnivConstraintSet.Exists (fun c' => c = f c') cs1 \/ UnivConstraintSet.In c cs2). -Proof. - cbv [UnivConstraintSet.Exists]; rewrite ConstraintSetProp.fold_spec_right. - setoid_rewrite (ConstraintSetFact.elements_iff cs1). - setoid_rewrite InA_In_eq. - setoid_rewrite (@List.in_rev _ (UnivConstraintSet.elements cs1)). - induction (List.rev (UnivConstraintSet.elements cs1)) as [|x xs IH]; cbn [List.In List.fold_right]; - [ now firstorder idtac | ]. - rewrite UnivConstraintSet.add_spec. - repeat first [ progress destruct_head'_ex - | progress destruct_head'_and - | progress destruct_head'_or - | progress subst - | progress intuition eauto ]. -Qed. - -Lemma LevelSet_In_fold_add c cs1 cs2 f - : LevelSet.In c (LevelSet.fold (fun c => LevelSet.add (f c)) cs1 cs2) - <-> (LevelSet.Exists (fun c' => c = f c') cs1 \/ LevelSet.In c cs2). -Proof. - cbv [LevelSet.Exists]; rewrite LevelSetProp.fold_spec_right. - setoid_rewrite (LevelSetFact.elements_iff cs1). - setoid_rewrite InA_In_eq. - setoid_rewrite (@List.in_rev _ (LevelSet.elements cs1)). - induction (List.rev (LevelSet.elements cs1)) as [|x xs IH]; cbn [List.In List.fold_right]; - [ now firstorder idtac | ]. - rewrite LevelSet.add_spec. - repeat first [ progress destruct_head'_ex - | progress destruct_head'_and - | progress destruct_head'_or - | progress subst - | progress intuition eauto ]. -Qed. - -Lemma ununiquify_level_var__uniquify_level_var lvls n offset v (Hn : offset < n) - : ununiquify_level_var n (uniquify_level_var lvls n offset v) = v. -Proof. - cbv [uniquify_level_var ununiquify_level_var]. - destruct ?; f_equal. - all: Z.to_euclidean_division_equations; nia. -Qed. - -Lemma ununiquify_level_level__uniquify_level_level lvls sp p v - : ununiquify_level_level (uniquify_level_level lvls sp p v) = v. -Proof. reflexivity. Qed. - -Lemma ununiquify_level__uniquify_level lvls n offset sp p v (Hn : offset < n) - : ununiquify_level n (uniquify_level lvls sp n p offset v) = v. -Proof. - destruct v; try reflexivity. - cbv [ununiquify_level uniquify_level]. - f_equal; now apply ununiquify_level_var__uniquify_level_var. -Qed. - -Lemma ConstraintSet_In__declare_and_uniquify_and_combine_levels_1__0 cs cstr c - : UnivConstraintSet.In c (ContextSet.constraints cs) - -> UnivConstraintSet.In (uniquify_constraint_for (ContextSet.levels cs) true c) (ContextSet.constraints (declare_and_uniquify_and_combine_levels (cs, cstr)).1). -Proof. - cbv [declare_and_uniquify_levels declare_and_uniquify_and_combine_levels uniquify_constraint_for uniquify_constraint]. - repeat first [ progress subst - | progress cbn [ContextSet.constraints fst snd] - | progress cbv [UnivConstraintSet.Exists] - | destruct ? - | rewrite ConstraintSet_In_fold_add - | solve [ eauto ] ]. -Qed. - -Lemma ConstraintSet_In__declare_and_uniquify_and_combine_levels_1__1 cs cstr c - : UnivConstraintSet.In c (ContextSet.constraints (declare_and_uniquify_and_combine_levels (cs, cstr)).1) - -> UnivConstraintSet.In (ununiquify_constraint 2 c) (ContextSet.constraints cs). -Proof. - cbv [declare_and_uniquify_levels declare_and_uniquify_and_combine_levels ununiquify_constraint uniquify_constraint_for uniquify_constraint]. - repeat first [ progress subst - | progress cbn [ContextSet.constraints fst snd] - | progress cbv [UnivConstraintSet.Exists] - | destruct ? - | rewrite ConstraintSet_In_fold_add - | rewrite ConstraintSetFact.empty_iff - | progress intros - | progress destruct_head'_and - | progress destruct_head'_or - | progress destruct_head'_ex - | progress destruct_head'_False - | rewrite ununiquify_level__uniquify_level by lia - | match goal with - | [ H : (_, _) = (_, _) |- _ ] => inv H - end - | solve [ eauto ] ]. -Qed. - -Lemma ConstraintSet_In__declare_and_uniquify_and_combine_levels_2__0 cs cstr c - : UnivConstraintSet.In c cstr - -> UnivConstraintSet.In (uniquify_constraint_for (ContextSet.levels cs) false c) (declare_and_uniquify_and_combine_levels (cs, cstr)).2. -Proof. - cbv [declare_and_uniquify_levels declare_and_uniquify_and_combine_levels uniquify_constraint_for uniquify_constraint]. - repeat first [ progress subst - | progress cbn [ContextSet.constraints fst snd] - | progress cbv [UnivConstraintSet.Exists] - | destruct ? - | rewrite ConstraintSet_In_fold_add - | rewrite UnivConstraintSet.union_spec - | solve [ eauto ] ]. -Qed. - -Lemma ConstraintSet_In__declare_and_uniquify_levels_2__1 cs cstr c - : UnivConstraintSet.In c (declare_and_uniquify_levels (cs, cstr)).2 - -> UnivConstraintSet.In (ununiquify_constraint 2 c) cstr. -Proof. - cbv [declare_and_uniquify_levels ununiquify_constraint uniquify_constraint_for uniquify_constraint]. - repeat first [ progress subst - | progress cbn [ContextSet.constraints fst snd] - | progress cbv [UnivConstraintSet.Exists] - | destruct ? - | rewrite ConstraintSet_In_fold_add - | rewrite ConstraintSetFact.empty_iff - | progress intros - | progress destruct_head'_and - | progress destruct_head'_or - | progress destruct_head'_ex - | progress destruct_head'_False - | rewrite ununiquify_level__uniquify_level by lia - | match goal with - | [ H : (_, _) = (_, _) |- _ ] => inv H - end - | solve [ eauto ] ]. -Qed. - -Lemma LevelSet_In_declare_and_uniquify_and_combine_levels_1_1 cs cstr side x - : LevelSet.In x (ContextSet.levels cs) - -> LevelSet.In (uniquify_level_for (ContextSet.levels cs) side x) - (ContextSet.levels (declare_and_uniquify_and_combine_levels (cs, cstr)).1). -Proof. - cbv [declare_and_uniquify_and_combine_levels declare_and_uniquify_levels ContextSet.levels]; cbn [fst snd]. - rewrite !LevelSet_In_fold_add. - intro Hx. - repeat lazymatch goal with - | [ |- ?x \/ ?y ] - => first [ lazymatch x with - | context[LevelSet.Exists _ cs.1] => left - end - | lazymatch y with - | context[LevelSet.Exists _ cs.1] => right - end ] - end. - cbv [LevelSet.Exists uniquify_level_var uniquify_level_level uniquify_level_for uniquify_level]. - exists x; split; trivial. - destruct x; try reflexivity. - all: now rewrite LevelSetFact.mem_1 by assumption. -Qed. - -Lemma satisfies_declare_and_uniquify_and_combine_levels_1_0 {cs cstr v} - : satisfies v (ContextSet.constraints (declare_and_uniquify_and_combine_levels (cs, cstr)).1) - -> satisfies (uniquify_valuation_for (ContextSet.levels cs) true v) (ContextSet.constraints cs). -Proof. - cbv [satisfies UnivConstraintSet.For_all uniquify_valuation_for]. - intros H x Hi; specialize (H _ ltac:(eapply ConstraintSet_In__declare_and_uniquify_and_combine_levels_1__0, Hi)). - destruct x as [[l []] r]; cbn in *; - inversion H; clear H; subst; constructor. - all: destruct l, r; assumption. -Qed. - -Lemma satisfies_declare_and_uniquify_and_combine_levels_1_1 {cs cstr v} - : satisfies v (ContextSet.constraints cs) - -> satisfies (ununiquify_valuation 2 v) (ContextSet.constraints (declare_and_uniquify_and_combine_levels (cs, cstr)).1). -Proof. - cbv [satisfies UnivConstraintSet.For_all ununiquify_valuation]. - intros H x Hi; specialize (H _ ltac:(eapply ConstraintSet_In__declare_and_uniquify_and_combine_levels_1__1, Hi)). - destruct x as [[l []] r]; cbn in *; - inversion H; clear H; subst; constructor. - all: destruct l, r; assumption. -Qed. - -Lemma satisfies_declare_and_uniquify_and_combine_levels_2_0 {cs cstr v} - : satisfies v (declare_and_uniquify_and_combine_levels (cs, cstr)).2 - -> satisfies (uniquify_valuation_for (ContextSet.levels cs) false v) cstr. -Proof. - cbv [satisfies UnivConstraintSet.For_all uniquify_valuation_for]. - intros H x Hi; specialize (H _ ltac:(eapply ConstraintSet_In__declare_and_uniquify_and_combine_levels_2__0, Hi)). - destruct x as [[l []] r]; cbn in *; - inversion H; clear H; subst; constructor. - all: destruct l, r; assumption. -Qed. - -Lemma satisfies_declare_and_uniquify_levels_2_1 {cs cstr v} - : satisfies v cstr - -> satisfies (ununiquify_valuation 2 v) (declare_and_uniquify_levels (cs, cstr)).2. -Proof. - cbv [satisfies UnivConstraintSet.For_all uniquify_valuation_for]. - intros H x Hi; specialize (H _ ltac:(eapply ConstraintSet_In__declare_and_uniquify_levels_2__1, Hi)). - destruct x as [[l []] r]; cbn in *; - inversion H; clear H; subst; constructor. - all: destruct l, r; try assumption. -Qed. - -Lemma satisfies_combine_valuations {cs cstr v v'} - (cscstr := declare_and_uniquify_levels (cs, cstr)) - (cscstr' := declare_and_uniquify_and_combine_levels (cs, cstr)) - (cs' := cscstr'.1) (cstr' := cscstr.2) (cstr'' := cscstr'.2) - (Hv : satisfies v (ContextSet.constraints cs')) - (Hv' : satisfies v' cstr') - (Hagree - : LevelSet.For_all (fun l => val v (uniquify_level_for (ContextSet.levels cs) true l) = val v' (uniquify_level_for (ContextSet.levels cs) false l)) (ContextSet.levels cs)) - (vc := combine_valuations "b"%byte "l"%byte "r"%byte v v v') - : satisfies vc cstr'' - /\ LevelSet.For_all (fun l => val v l = val vc l) (ContextSet.levels cs'). -Proof. - repeat match goal with H := _ |- _ => subst H end. - cbv [satisfies UnivConstraintSet.For_all LevelSet.For_all combine_valuations val Level.Evaluable ContextSet.constraints ContextSet.levels declare_and_uniquify_and_combine_levels declare_and_uniquify_levels] in *; - cbn [fst snd valuation_poly valuation_mono] in *. - revert Hv Hv' Hagree. - progress repeat setoid_rewrite UnivConstraintSet.union_spec. - progress repeat setoid_rewrite LevelSet_In_fold_add. - progress repeat setoid_rewrite ConstraintSet_In_fold_add. - progress repeat setoid_rewrite ConstraintSetFact.empty_iff. - progress repeat setoid_rewrite LevelSet.singleton_spec. - cbv [LevelSet.Exists UnivConstraintSet.Exists uniquify_constraint_for uniquify_constraint uniquify_level_for uniquify_level]. - intros. + intros csnz. + destruct (levels_of_cs2_spec cstr (ContextSet.constraints cs)) as [[hnz h] [hnz' h']]. split. - 2: intro x; specialize (Hagree (ununiquify_level 2 x)). - 2: cbv [ununiquify_level ununiquify_level_level ununiquify_level_var] in *. - all: repeat first [ progress intros - | progress subst - | progress rdest - | progress destruct_head'_False - | progress destruct_head'_or - | progress destruct_head'_ex - | progress specialize_by_assumption - | progress cbv beta iota in * - | reflexivity - | match goal with - | [ H : forall x, _ \/ _ -> _ |- _ ] - => pose proof (fun x H' => H x (or_introl H')); - pose proof (fun x H' => H x (or_intror H')); - clear H - | [ H : _ \/ _ -> _ |- _ ] - => pose proof (fun H' => H (or_introl H')); - pose proof (fun H' => H (or_intror H')); - clear H - | [ H : forall x, ex _ -> _ |- _ ] - => specialize (fun x x' H' => H x (ex_intro _ x' H')) - | [ H : ex _ -> _ |- _ ] - => specialize (fun x' H' => H (ex_intro _ x' H')) - | [ H : forall x x', _ /\ x = @?f x' -> _ |- _ ] - => specialize (fun x' H' => H _ x' (conj H' eq_refl)) - | [ H : forall x, _ /\ _ = _ -> _ |- _ ] - => specialize (fun H' => H _ (conj H' eq_refl)) - | [ H : forall x, x = _ -> _ |- _ ] - => specialize (H _ eq_refl) - | [ H : forall x, False -> _ |- _ ] => clear H - end ]. - all: repeat first [ progress cbv [uniquify_level_level uniquify_level_var] in * - | congruence - | lia - | progress subst - | match goal with - | [ H : Level.lvar _ = Level.lvar _ |- _ ] => inversion H; clear H - | [ H : Level.level _ = Level.level _ |- _ ] => inversion H; clear H - | [ H : (@eqb ?T ?R ?x ?y) = true |- _ ] - => destruct (@eqb_spec T R x y) - | [ H : (@eqb ?T ?R ?x ?y) = false |- _ ] - => destruct (@eqb_spec T R x y) - end - | progress destruct ? ]. - all: repeat first [ progress rewrite ?Nat2Z.inj_add, ?Nat2Z.inj_mul in * - | progress change (Z.of_nat 3) with 3%Z in * - | progress change (?n mod 3)%Z with n in * - | match goal with - | [ H : context[((?x * ?y + ?z) mod ?y)%Z] |- _ ] - => rewrite (Z.add_comm (x * y) z) in * - end - | progress rewrite ?Z_mod_plus_full in * - | lia ]. - all: repeat match goal with - | [ H : LevelSet.In _ _ |- _ ] - => progress specialize_all_ways_under_binders_by exact H - | [ H : UnivConstraintSet.In _ _ |- _ ] - => progress specialize_all_ways_under_binders_by exact H - end. - all: repeat first [ progress subst - | assumption - | progress cbv [val Level.Evaluable] in * - | progress cbn [fst snd valuation_mono valuation_poly] in * - | progress destruct_head_hnf' prod - | match goal with - | [ H : satisfies0 _ _ |- _ ] => inversion H; clear H; constructor - end ]. - all: repeat first [ progress cbv [uniquify_level_level uniquify_level_var] in * - | rewrite eqb_refl - | assumption - | match goal with - | [ H : ?x = true, H' : context[match ?x with _ => _ end] |- _ ] - => rewrite H in H' - | [ H : ?x = false, H' : context[match ?x with _ => _ end] |- _ ] - => rewrite H in H' - | [ |- context[LevelSet.mem ?l ?x] ] - => let H := fresh in - pose proof (@LevelSetFact.mem_2 x l) as H; - destruct (LevelSet.mem l x) eqn:?; - try (specialize (H eq_refl); - specialize_all_ways_under_binders_by exact H) - | [ H : LevelSet.mem ?x ?l = true |- _ ] - => unique pose proof (@LevelSetFact.mem_2 _ _ H); - let H' := match goal with H' : LevelSet.In x l |- _ => H' end in - specialize_all_ways_under_binders_by exact H' - end ]. - all: repeat first [ progress cbv beta iota in * - | rewrite !Nat2Z.inj_add, !Nat2Z.inj_mul - | progress change (Z.of_nat 3) with 3%Z - | rewrite Z.add_comm, Z_mod_plus_full - | rewrite eqb_refl - | assumption - | lia - | match goal with - | [ |- context[(?x == ?y)] ] - => change (x == y) with false - end ]. + - split. subst lvls. rewrite /levels_of_cscs. cbn. + move/LevelSet.union_spec. intuition. + red. rewrite levelset_add_union. apply global_uctx_invariants_union_or. + right. apply levels_of_cs2_spec. + - split. subst lvls. rewrite /levels_of_cscs. cbn. + move/LevelSet.union_spec. intuition. + red. rewrite levelset_add_union. apply global_uctx_invariants_union_or. + right. apply levels_of_cs2_spec. Qed. -Lemma consistent_extension_on_iff_declare_and_uniquify_and_combine_levels cs cstr - : @consistent_extension_on cs cstr - <-> @consistent_extension_on (declare_and_uniquify_and_combine_levels (cs, cstr)).1 (declare_and_uniquify_and_combine_levels (cs, cstr)).2. -Proof. - cbv [consistent_extension_on]. - split; intros H v Hs. - { specialize (H _ (satisfies_declare_and_uniquify_and_combine_levels_1_0 Hs)). - destruct H as [v' [H0 H1]]. - apply (@satisfies_declare_and_uniquify_levels_2_1 cs cstr) in H0. - eexists; eapply satisfies_combine_valuations; try eassumption. - revert H1. - cbv [LevelSet.For_all ununiquify_valuation uniquify_valuation_for uniquify_valuation val Level.Evaluable uniquify_level_for uniquify_level]. - cbn [valuation_mono valuation_poly]. - intros H1 x Hx; specialize (H1 x Hx); revert H1. - destruct x; try lia. - all: first [ rewrite ununiquify_level_level__uniquify_level_level - | rewrite ununiquify_level_var__uniquify_level_var by lia ]. - all: trivial. } - { specialize (H _ (satisfies_declare_and_uniquify_and_combine_levels_1_1 Hs)). - destruct H as [v' [H0 H1]]. - eexists; split; - [ eapply satisfies_declare_and_uniquify_and_combine_levels_2_0; eassumption | ]. - cbv [LevelSet.For_all] in *. - intros l Hl; specialize (fun side => H1 _ ltac:(unshelve eapply LevelSet_In_declare_and_uniquify_and_combine_levels_1_1, Hl; exact side)). - pose proof (H1 true) as H1t. - pose proof (H1 false) as H1f. - clear H1. - cbv [val Level.Evaluable ununiquify_valuation uniquify_level_for uniquify_level uniquify_valuation_for uniquify_valuation] in *. - destruct l; trivial. - cbn [valuation_poly valuation_mono] in *. - rewrite ?ununiquify_level_var__uniquify_level_var in * by lia. - congruence. } -Qed. - -Lemma global_uctx_invariants__declare_and_uniquify_and_combine_levels cs cstr - : global_uctx_invariants (declare_and_uniquify_and_combine_levels (cs, cstr)).1. -Proof. - pose proof (levels_of_cs_spec (ContextSet.constraints cs)). - pose proof (levels_of_cs_spec cstr). - cbv [declare_and_uniquify_levels]; cbn [fst snd]. - cbv [uGraph.global_uctx_invariants uGraph.uctx_invariants UnivConstraintSet.For_all declared_univ_cstr_levels] in *; cbn [fst snd ContextSet.levels ContextSet.constraints] in *. - repeat first [ progress subst - | progress cbv [LevelSet.Exists UnivConstraintSet.Exists uniquify_constraint_for uniquify_constraint uniquify_level_for] in * - | rewrite !LevelSet_In_fold_add - | rewrite !ConstraintSet_In_fold_add - | rewrite !LevelSet.singleton_spec - | rewrite ConstraintSetFact.empty_iff - | setoid_rewrite LevelSet_In_fold_add - | setoid_rewrite ConstraintSet_In_fold_add - | setoid_rewrite LevelSet.singleton_spec - | setoid_rewrite ConstraintSetFact.empty_iff - | match goal with - | [ H : (_, _) = (_, _) |- _ ] => inv H - | [ H : forall x : UnivConstraintSet.elt, _ |- _ ] - => specialize (fun a b c => H ((a, b), c)) - end - | solve [ eauto ] - | progress rdest - | progress destruct_head'_ex - | progress split_and - | progress intros - | progress destruct ? - | progress destruct_head'_or ]. -Qed. - -Lemma consistent_extension_on_iff_subgraph_helper cs cstr G G' - (cscstr := declare_and_uniquify_and_combine_levels (cs, cstr)) - (cs' := cscstr.1) (cstr' := cscstr.2) - (cf := config.default_checker_flags) (lvls := levels_of_cscs cs' cstr') - (HG : gc_of_uctx cs' = Some G) - (HG' : gc_of_uctx (lvls, cstr') = Some G') - : subgraph (make_graph G) (make_graph G'). -Proof. - repeat first [ progress cbv [gc_of_uctx monad_utils.bind monad_utils.ret monad_utils.option_monad] in * - | progress cbn [fst snd] in * - | progress subst - | progress destruct ? - | match goal with - | [ H : Some ?x = Some ?y |- _ ] => assert (x = y) by congruence; clear H - end - | congruence ]. - repeat match goal with H := _ |- _ => subst H end. - split; try reflexivity; - cbv [levels_of_cscs ContextSet.levels uGraph.wGraph.E make_graph uGraph.wGraph.V]; - cbn [fst snd] in *; - try solve [ clear; LevelSetDecide.fsetdec ]; - []. - all: lazymatch goal with - | [ |- EdgeSet.Subset _ _ ] => idtac - end. - intro; - rewrite !add_cstrs_spec, !add_level_edges_spec, !EdgeSetFact.empty_iff; - repeat setoid_rewrite VSet.union_spec. - all: repeat first [ intro - | progress destruct_head'_or - | progress destruct_head'_ex - | progress destruct_head'_and - | progress subst - | exfalso; assumption - | progress rewrite ?@gc_of_constraint_iff in * by eassumption - | progress cbv [UnivConstraintSet.Exists on_Some] in * - | progress destruct ? - | solve [ eauto 6 ] ]. - all: [ > ]. - left; eexists; split; [ reflexivity | ]. - all: repeat first [ intro - | progress destruct_head'_or - | progress destruct_head'_ex - | progress destruct_head'_and - | progress subst - | exfalso; assumption - | progress rewrite ?@gc_of_constraint_iff in * by eassumption - | progress cbv [UnivConstraintSet.Exists on_Some] in * - | progress destruct ? - | solve [ eauto 6 ] ]. - eexists; split; - [ | match goal with H : _ |- _ => rewrite H; eassumption end ]. - cbv [declare_and_uniquify_and_combine_levels ContextSet.constraints] in *; cbn [fst snd] in *. - ConstraintSetDecide.fsetdec. -Qed. - -Lemma consistent_extension_on_iff cs cstr - (cscstr := declare_and_uniquify_and_combine_levels (cs, cstr)) - (cs' := cscstr.1) (cstr' := cscstr.2) - (cf := config.default_checker_flags) (lvls := levels_of_cscs cs' cstr') - : @consistent_extension_on cs cstr - <-> is_true - match uGraph.is_consistent cs', uGraph.is_consistent (lvls, cstr'), - uGraph.gc_of_uctx cs', uGraph.gc_of_uctx (lvls, cstr') with - | false, _, _, _ - | _, _, None, _ - => true - | _, true, Some G, Some G' - => uGraph.wGraph.IsFullSubgraph.is_full_extension (uGraph.make_graph G) (uGraph.make_graph G') - | _, _, _, _ => false - end. -Proof. - rewrite consistent_extension_on_iff_declare_and_uniquify_and_combine_levels. - destruct (levels_of_cscs_spec cs' cstr'). - subst cscstr cs' cstr'. - cbv zeta; repeat destruct ?; subst. - let H := fresh in pose proof (fun uctx uctx' G => @uGraph.consistent_ext_on_full_ext _ uctx G (lvls, uctx')) as H; cbn [fst snd] in H; erewrite H; clear H. - 1: reflexivity. - all: cbn [fst snd ContextSet.constraints] in *. - all: repeat - repeat - first [ match goal with - | [ H : _ = Some _ |- _ ] => rewrite H - | [ H : _ = None |- _ ] => rewrite H - | [ |- _ <-> is_true false ] - => cbv [is_true]; split; [ let H := fresh in intro H; contradict H | congruence ] - | [ |- _ <-> is_true true ] - => split; [ reflexivity | intros _ ] - end - | progress cbv [uGraph.is_graph_of_uctx monad_utils.bind monad_utils.ret monad_utils.option_monad] in * - | progress cbn [MROption.on_Some fst snd] in * - | rewrite <- uGraph.is_consistent_spec2 - | progress subst - | assert_fails (idtac; lazymatch goal with |- ?G => has_evar G end); - first [ reflexivity | assumption ] - | match goal with - | [ H : ?T, H' : ~?T |- _ ] => exfalso; apply H', H - | [ H : context[match ?x with _ => _ end] |- _ ] => destruct x eqn:? - | [ H : uGraph.gc_of_uctx _ = None |- _ ] => cbv [uGraph.gc_of_uctx] in * - | [ H : Some _ = Some _ |- _ ] => inversion H; clear H - | [ H : Some _ = None |- _ ] => inversion H - | [ H : None = Some _ |- _ ] => inversion H - | [ H : ?T <-> False |- _ ] => destruct H as [H _]; try change (~T) in H - | [ H : ~consistent ?cs |- consistent_extension_on (_, ?cs) _ ] - => intros ? ?; exfalso; apply H; eexists; eassumption - | [ H : ~consistent (snd ?cs) |- consistent_extension_on ?cs _ ] - => intros ? ?; exfalso; apply H; eexists; eassumption - | [ H : @uGraph.is_consistent ?cf ?uctx = false |- _ ] - => assert (~consistent (snd uctx)); - [ rewrite <- (@uGraph.is_consistent_spec cf uctx), H; clear H; auto - | clear H ] - | [ H : @uGraph.gc_of_constraints ?cf ?ctrs = None |- _ ] - => let H' := fresh in - pose proof (@uGraph.gc_consistent_iff cf ctrs) as H'; - rewrite H in H'; - clear H - | [ H : @uGraph.is_consistent ?cf ?uctx = true |- _ ] - => assert_fails (idtac; match goal with - | [ H' : consistent ?v |- _ ] => unify v (snd uctx) - end); - assert (consistent (snd uctx)); - [ rewrite <- (@uGraph.is_consistent_spec cf uctx), H; clear H; auto - | ] - end ]. - all: try now apply global_uctx_invariants__declare_and_uniquify_and_combine_levels. - all: try now eapply @consistent_extension_on_iff_subgraph_helper. - all: try solve [ repeat first [ progress cbv [consistent consistent_extension_on not] in * - | progress intros - | progress destruct_head'_ex - | progress destruct_head'_and - | progress specialize_under_binders_by eassumption - | solve [ eauto ] ] ]. -Qed. +Definition levels_of_universe (u : Universe.t) : LevelSet.t := Universe.levels u. -Definition consistent_extension_on_dec cs cstr : {@consistent_extension_on cs cstr} + {~@consistent_extension_on cs cstr}. -Proof. - pose proof (@consistent_extension_on_iff cs cstr) as H; cbv beta zeta in *. - let b := lazymatch type of H with context[is_true ?b] => b end in - destruct b; [ left; apply H; reflexivity | right; intro H'; apply H in H'; auto ]. -Defined. - -Definition leq0_universe_n_dec n ϕ u u' : {@leq0_universe_n (uGraph.Z_of_bool n) ϕ u u'} + {~@leq0_universe_n (uGraph.Z_of_bool n) ϕ u u'}. -Proof. - pose proof (@uGraph.gc_leq0_universe_n_iff config.default_checker_flags (uGraph.Z_of_bool n) ϕ u u') as H. - pose proof (@uGraph.gc_consistent_iff config.default_checker_flags ϕ). - cbv [on_Some on_Some_or_None] in *. - destruct gc_of_constraints eqn:?. - all: try solve [ left; cbv [consistent] in *; hnf; intros; exfalso; intuition eauto ]. - pose proof (fun G cstr => @uGraph.leqb_universe_n_spec G (LevelSet.union (levels_of_cs ϕ) (LevelSet.union (levels_of_universe u) (levels_of_universe u')), cstr)). - pose proof (fun x y => @gc_of_constraints_of_uctx config.default_checker_flags (x, y)) as H'. - pose proof (@is_consistent_spec config.default_checker_flags (levels_of_cs ϕ, ϕ)). - specialize_under_binders_by eapply gc_levels_declared_union_or. - specialize_under_binders_by eapply global_gc_uctx_invariants_union_or. - specialize_under_binders_by (constructor; eapply gc_of_uctx_invariants). - cbn [fst snd] in *. - specialize_under_binders_by eapply H'. - specialize_under_binders_by eassumption. - specialize_under_binders_by eapply levels_of_cs_spec. - specialize_under_binders_by reflexivity. - destruct is_consistent; - [ | left; now cbv [leq0_universe_n consistent] in *; intros; exfalso; intuition eauto ]. - specialize_by intuition eauto. - let H := match goal with H : forall (b : bool), _ |- _ => H end in - specialize (H n u u'). - specialize_under_binders_by (constructor; eapply gc_levels_declared_union_or; constructor; eapply levels_of_universe_spec). - match goal with H : is_true ?b <-> ?x, H' : ?y <-> ?x |- {?y} + {_} => destruct b eqn:?; [ left | right ] end. - all: intuition. -Defined. - -Definition leq_universe_n_dec cf n ϕ u u' : {@leq_universe_n cf (uGraph.Z_of_bool n) ϕ u u'} + {~@leq_universe_n cf (uGraph.Z_of_bool n) ϕ u u'}. -Proof. - cbv [leq_universe_n]; destruct (@leq0_universe_n_dec n ϕ u u'); destruct ?; auto. +Lemma levels_of_universe_spec u cstr (lvls := levels_of_universe u) + : levels_declared (lvls, cstr) u. +Proof. + subst lvls; cbv [levels_of_universe]; cbn [fst snd]. + red. intros le hin. red. cbn. apply LevelSet.add_spec. right. + apply Universe.levels_spec. now exists le.2; destruct le. +Qed. + +(* Lemma invalid_cstr cs c : ~ valid0_cstrs cs c <-> ~ (forall v, exists v, *) + +Definition consistent_extension_on_dec (cf := config.default_checker_flags) cs cstr : {@consistent_extension_on cs cstr} + {~@consistent_extension_on cs cstr}. +Proof. + unfold consistent_extension_on. + have hp := push_uctx_spec init_model cs. + cbn in hp. + destruct (push_uctx init_model cs). + - destruct hp as [ul uc]. destruct (check_constraints u cstr) eqn:hc. + unfold check_constraints, check_constraints_gen in hc. cbn in hc. + left. + intros v hsat. + apply UnivConstraintSet.for_all_spec in hc. + exists v. split. move=> c /hc. + have hs := checkb_spec u cs. + forward hs. red. admit. forward hs. red. admit. + red in hs. specialize (hs c). forward hs. admit. rewrite [_ = true]hs. + now move/(_ v hsat). + intros hl. reflexivity. tc. + right. + intros hv. + have [c [hin hc']] : exists c, UnivConstraintSet.In c cstr /\ @check_constraint_gen config.default_checker_flags (checkb u) c = false. + admit. + unfold check_constraint_gen in hc'. cbn in hc'. + have hs := checkb_spec u cs. + forward hs. red. admit. forward hs. red. admit. + red in hs. + specialize (hs c). forward hs. admit. rewrite hc' in hs. + destruct hs => //. forward H0 => //. + intros v' hs. specialize (hv v' hs). + destruct hv as [v'0 [hsat heq]]. + admit. + - admit. +Admitted. + +Import Clauses.FLS. +Import UnivConstraintType.ConstraintType. + +Lemma declared_univ_cstrs_levels_spec cstrs : declared_univ_cstrs_levels (univ_constraints_levels cstrs) cstrs. +Proof. + intros cl hin. apply declared_univ_cstr_levels_spec. + intros l; rewrite univ_constraints_levels_spec. exists cl; split => //. +Qed. + +Definition leq0_universe_dec (cf := config.default_checker_flags) ϕ u u' : {@leq0_universe ϕ u u'} + {~@leq0_universe ϕ u u'}. +Proof. + set (levels := Universe.levels u ∪ Universe.levels u' ∪ (univ_constraints_levels ϕ)). + set (uctx := (LevelSet.remove Level.lzero levels, ϕ)). + have hc : global_uctx_invariants uctx. + { red. split. + * intros hin. + now apply LevelSet.remove_spec in hin. + * red. cbn. subst levels. + eapply (declared_univ_cstrs_levels_subset (univ_constraints_levels ϕ)). + lsets. reflexivity. apply declared_univ_cstrs_levels_spec. } + destruct (push_uctx init_model uctx) eqn:eqp. + have := check_leqb_universe_spec u0 uctx hc => /fwd. + { now apply push_uctx_init_model_sat. } + move/(_ cf u u') => /fwd. + { cbn. rewrite levelset_add_remove /levels. split; lsets. } + move=> -[]. destruct (check_leqb_universe_gen). + * left. red. specialize (a eq_refl). red in a. cbn in a. red in a. + move=> v vsat; move: (a v vsat). intros sat. now depelim sat. + * move=> _ hv; right => leq. forward hv => //. + cbn. red. red in leq. + move=> v /leq. now constructor. + * apply push_uctx_init_model_unsat in eqp => //. + left. intros v hv. elim eqp. + exists v. eapply satisfies_union. split. + 2:{ apply satisfies_init. } + exact hv. +Qed. + +Definition leq_universe_dec cf ϕ u u' : {@leq_universe cf ϕ u u'} + {~@leq_universe cf ϕ u u'}. +Proof. + cbv [leq_universe]; destruct (@leq0_universe_dec ϕ u u'); destruct ?; auto. Defined. Definition eq0_universe_dec ϕ u u' : {@eq0_universe ϕ u u'} + {~@eq0_universe ϕ u u'}. Proof. - pose proof (@eq0_leq0_universe ϕ u u') as H. - destruct (@leq0_universe_n_dec false ϕ u u'), (@leq0_universe_n_dec false ϕ u' u); constructor; destruct H; split_and; now auto. + pose proof (eq0_universe_leq0_universe ϕ u u') as H. + destruct (@leq0_universe_dec ϕ u u'), (@leq0_universe_dec ϕ u' u); constructor; destruct H; split_and; now auto. Defined. Definition eq_universe_dec {cf ϕ} u u' : {@eq_universe cf ϕ u u'} + {~@eq_universe cf ϕ u u'}. @@ -807,23 +201,35 @@ Definition eq_sort_dec {cf ϕ} s s' : {@eq_sort cf ϕ s s'} + {~@eq_sort cf ϕ s Definition valid_constraints_dec cf ϕ cstrs : {@valid_constraints cf ϕ cstrs} + {~@valid_constraints cf ϕ cstrs}. Proof. - pose proof (fun G a b c => uGraph.check_constraints_spec (uGraph.make_graph G) (levels_of_cs2 ϕ cstrs, ϕ) a b c cstrs) as H1. - pose proof (fun G a b c => uGraph.check_constraints_complete (uGraph.make_graph G) (levels_of_cs2 ϕ cstrs, ϕ) a b c cstrs) as H2. - pose proof (levels_of_cs2_spec ϕ cstrs). - cbn [fst snd] in *. - destruct (consistent_dec ϕ); [ | now left; cbv [valid_constraints valid_constraints0 consistent not] in *; destruct ?; intros; eauto; exfalso; eauto ]. - destruct_head'_and. - specialize_under_binders_by assumption. - cbv [uGraph.is_graph_of_uctx MROption.on_Some] in *. - cbv [valid_constraints] in *; repeat destruct ?; auto. - { specialize_under_binders_by reflexivity. - destruct uGraph.check_constraints_gen; specialize_by reflexivity; auto. } - { rewrite uGraph.gc_consistent_iff in *. - cbv [uGraph.gc_of_uctx monad_utils.bind monad_utils.ret monad_utils.option_monad MROption.on_Some] in *; cbn [fst snd] in *. - destruct ?. - all: try congruence. - all: exfalso; assumption. } -Defined. + set (levels := (univ_constraints_levels ϕ) ∪ (univ_constraints_levels cstrs)). + set (uctx := (LevelSet.remove Level.lzero levels, ϕ)). + have hc : global_uctx_invariants uctx. + { red. split. + * intros hin. + now apply LevelSet.remove_spec in hin. + * red. cbn. subst levels. + eapply (declared_univ_cstrs_levels_subset (univ_constraints_levels ϕ)). + lsets. reflexivity. + intros cl hin. apply declared_univ_cstr_levels_spec. + intros l; rewrite univ_constraints_levels_spec. exists cl; split => //. } + destruct (push_uctx init_model uctx) eqn:eqp. + - have := check_constraints_spec u uctx hc => /fwd. + { now apply push_uctx_init_model_sat. } + move/(_ cf cstrs) => /fwd. + { cbn. red. cbn. split. lsets. red. cbn. rewrite levelset_add_remove /levels. + rewrite levelset_add_union. eapply (declared_univ_cstrs_levels_subset (univ_constraints_levels cstrs)). lsets. + reflexivity. apply declared_univ_cstrs_levels_spec. } + move=> -[]. destruct (check_constraints_gen). + * left. red. specialize (a eq_refl). red in a. cbn in a. + destruct config.check_univs => //. + * move=> _ hv; right => leq. forward hv => //. + - apply push_uctx_init_model_unsat in eqp => //. + left. red. destruct config.check_univs => //. + intros v sat. elim eqp. + exists v. eapply satisfies_union. split. + 2:{ apply satisfies_init. } + exact sat. +Qed. Definition valid_constraints0_dec ϕ ctrs : {@valid_constraints0 ϕ ctrs} + {~@valid_constraints0 ϕ ctrs} := @valid_constraints_dec config.default_checker_flags ϕ ctrs. diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index 5007c14fa..81d6f3f65 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -7,30 +7,32 @@ From Equations Require Import Equations. Import ConstraintType. Set Equations Transparent. +Import UnivLoopChecking. + Definition universe_model := UnivLoopChecking.univ_model. Definition init_model : universe_model := UnivLoopChecking.init_model. Definition uctx_invariants (uctx : ContextSet.t) - := UnivLoopChecking.declared_univ_cstrs_levels uctx.1 uctx.2. + := UnivLoopChecking.declared_univ_cstrs_levels (LevelSet.add Level.lzero uctx.1) uctx.2. Definition global_uctx_invariants (uctx : ContextSet.t) := ~ LevelSet.In Level.lzero uctx.1 /\ uctx_invariants uctx. -Section Push. - Import UnivLoopChecking. - -Equations push_uctx (g : universe_model) (uctx : ContextSet.t) : option universe_model := -push_uctx g uctx with UnivLoopChecking.declare_levels g uctx.1 := - | Some g' => enforce_constraints g' uctx.2 - | None => None. - Instance declared_univ_cstrs_levels_proper : Proper (LevelSet.Equal ==> UnivConstraintSet.Equal ==> iff) declared_univ_cstrs_levels. Proof. move=> ?? e ?? e'. rewrite /declared_univ_cstrs_levels. rewrite e'. rewrite /UnivConstraintSet.For_all /declared_univ_cstr_levels. -Admitted. + split; move=> ha [[l d] r] /ha. now rewrite -e. now rewrite e. +Qed. + +Section Push. + +Equations push_uctx (g : universe_model) (uctx : ContextSet.t) : option universe_model := +push_uctx g uctx with UnivLoopChecking.declare_levels g uctx.1 := + | Some g' => enforce_constraints g' uctx.2 + | None => None. Definition push_uctx_precond g uctx := let allcstrs := UnivConstraintSet.union uctx.2 (UnivConstraintSet.union (init_constraints_of_levels uctx.1) (constraints g)) in @@ -76,10 +78,6 @@ End Push. Import UnivLoopChecking. -Definition is_model_of_uctx m uctx := - levels m =_lset LevelSet.union uctx.1 (LevelSet.singleton Universes.Level.lzero) /\ - constraints m =_ucset UnivConstraintSet.union uctx.2 (init_constraints_of_levels uctx.1). - (** ** Check of consistency ** *) Equations is_consistent (uctx : ContextSet.t) : bool := @@ -110,7 +108,7 @@ Proof. { elim h. red in ho. move=> c /ho. rewrite declared_univ_cstr_levels_spec. intros cdecl. rewrite declared_univ_cstr_levels_spec. - lsets. } + now rewrite (init_model_levels) -LevelSetProp.add_union_singleton /LS.Level.zero. } { elim h. destruct hc as [v hv]. exists v. eapply satisfies_union. split => //. eapply satisfies_union; split => //. @@ -155,9 +153,9 @@ Section CheckLeqProcedure. End CheckLeqProcedure. -Definition model_of_uctx (m : universe_model) uctx := - LevelSet.Equal (levels m) (LevelSet.add Level.lzero uctx.1) /\ - UnivConstraintSet.Equal (constraints m) (UnivConstraintSet.union (init_constraints_of_levels uctx.1) uctx.2). +Definition model_of_uctx m uctx := + levels m =_lset LevelSet.union uctx.1 (LevelSet.singleton Universes.Level.lzero) /\ + constraints m =_ucset UnivConstraintSet.union uctx.2 (init_constraints_of_levels uctx.1). Definition leq0_universe ctrs (u u' : Universe.t) := forall v, satisfies v ctrs -> val v u <= val v u'. @@ -183,31 +181,28 @@ Definition valid0_cstrs φ (c : UnivConstraintSet.t) := Definition valid_cstrs {cf : checker_flags} φ (c : UnivConstraintSet.t) := if check_univs then valid0_cstrs φ c else True. +Lemma levelset_add_union l ls ls' : LevelSet.add l (LevelSet.union ls ls') =_lset LevelSet.union (LevelSet.add l ls) (LevelSet.add l ls'). +Proof. + lsets. +Qed. + (* This section: specif in term of gc_uctx *) Section CheckLeq. - Context {cf:checker_flags}. - Context (m : universe_model) uctx (Huctx: global_uctx_invariants uctx) (HG : model_of_uctx m uctx). - Definition on_inl {A B : Type} (P : A -> Prop) (x : A + B) := - match x with - | inl x0 => P x0 - | inr _ => True - end. - Definition level_declared l := LevelSet.In l uctx.1. Lemma level_declared_model (l : Level.t) : level_declared l -> LevelSet.In l (levels m). Proof using HG. - intros Hl;subst. apply HG. clear cf. + intros Hl;subst. apply HG. red in Hl; lsets. Qed. Definition expr_declared (e : LevelExpr.t) - := LevelSet.In e.1 uctx.1. + := LevelSet.In e.1 (LevelSet.add Level.lzero uctx.1). Definition levels_declared (u : Universe.t) := LevelExprSet.For_all expr_declared u. @@ -221,13 +216,13 @@ Section CheckLeq. Definition checkb := check m. Definition check_spec (check: UnivConstraint.t -> bool) := - forall c, declared_univ_cstr_levels uctx.1 c -> + forall c, declared_univ_cstr_levels (LevelSet.add Level.lzero uctx.1) c -> check c <-> valid0_cstr uctx.2 c. Import C (clauses_sem). Lemma declared_incl c : - declared_univ_cstr_levels uctx.1 c -> + declared_univ_cstr_levels (LevelSet.add Level.lzero uctx.1) c -> declared_univ_cstr_levels (levels m) c. Proof. destruct c as [[l d] r]. @@ -333,9 +328,11 @@ Section CheckLeq. Lemma wf_zero_valuation_init v : interp_cstrs v (init_constraints_of_levels uctx.1) -> - wf_zero_valuation uctx.1 v. + wf_zero_valuation (LevelSet.add Level.lzero uctx.1) v. Proof. intros hi l hin. unfold LS.Level.zero. + apply LevelSet.add_spec in hin as [->|hin]. + { rewrite eqb_refl //. } change (l == Level.lzero) with (eqb l Level.lzero). destruct (eqb_spec l Level.lzero) => //. destruct LS.Level.is_global eqn:isg. @@ -444,7 +441,7 @@ Section CheckLeq. Qed. Lemma uctx_subset : - LevelSet.Subset (univ_constraints_levels uctx.2) uctx.1. + LevelSet.Subset (univ_constraints_levels uctx.2) (LevelSet.add Level.lzero uctx.1). Proof. red in Huctx. destruct Huctx. red in H0. intros l hin. red in H0. apply univ_constraints_levels_spec in hin as [cl [hin hincl]]. @@ -465,13 +462,13 @@ Section CheckLeq. rewrite H0 in hv. forward hv. { apply interp_cstrs_union. - split; [apply satisfies_interp_cstr, satisfies_init|now apply satisfies_interp_cstr]. } + split; revgoals; [apply satisfies_interp_cstr, satisfies_init|now apply satisfies_interp_cstr]. } now apply satisfies0_interp_cstr. - intros v. rewrite (proj2 HG) interp_cstrs_union. - intros [ii iu]. + intros [iu ii]. specialize (hv (to_valuation (shift_valuation v))). - rewrite (satisfies_interp_cstr_inv uctx.1) in hv. + rewrite (satisfies_interp_cstr_inv (LevelSet.add Level.lzero uctx.1)) in hv. { apply wf_shift_valuation. apply wf_zero_valuation_init. exact ii. } apply uctx_subset. forward hv. @@ -488,13 +485,16 @@ Section CheckLeq. Lemma fold_right_xpred0 {A} (l : list A) : fold_right (fun _ => xpred0) false l = false. Proof using Type. induction l; simpl; auto. Qed. + Section CheckerFlags. + Context {cf : checker_flags}. + Definition check_leqb_universe := (check_leqb_universe_gen checkb). Definition check_eqb_universe := (check_eqb_universe_gen checkb). Lemma check_leqb_universe_spec_gen check (check_correct : check_spec check) (l l' : Universe.t) - (Hu1 : declared_univ_cstr_levels uctx.1 (l, Le, l')) + (Hu1 : declared_univ_cstr_levels (LevelSet.add Level.lzero uctx.1) (l, Le, l')) : check_leqb_universe_gen check l l' <-> valid_cstr uctx.2 (l, Le, l'). Proof using HG Huctx. specialize (check_correct _ Hu1). @@ -509,7 +509,7 @@ Section CheckLeq. Lemma check_eqb_universe_spec_gen check (check_correct : check_spec check) (l l' : Universe.t) - (Hu1 : declared_univ_cstr_levels uctx.1 (l, Eq, l')) + (Hu1 : declared_univ_cstr_levels (LevelSet.add Level.lzero uctx.1) (l, Eq, l')) : check_eqb_universe_gen check l l' <-> valid_cstr uctx.2 (l, Eq, l'). Proof using HG Huctx. specialize (check_correct _ Hu1). @@ -548,7 +548,7 @@ Section CheckLeq. (* Let levels_declared_sort (s : Sort.t) := Sort.on_sort gc_levels_declared True s. *) - Lemma levels_declared_uctx u : levels_declared u -> LevelSet.Subset (Universe.levels u) uctx.1. + Lemma levels_declared_uctx u : levels_declared u -> LevelSet.Subset (Universe.levels u) (LevelSet.add Level.lzero uctx.1). Proof. move=> hu l. hnf in hu. rewrite Universe.levels_spec. @@ -592,6 +592,27 @@ Section CheckLeq. Definition check_eqb_sort_spec := check_eqb_sort_spec_gen _ checkb_spec. + Lemma check_constraints_spec_gen checkb + (checkb_correct : check_spec checkb) ctrs + : global_uctx_invariants (uctx.1, ctrs) -> + check_constraints_gen checkb ctrs <-> valid_constraints uctx.2 ctrs. + Proof using Type. + unfold check_constraints_gen, valid_constraints. + destruct check_univs => //=. + intros inv. rewrite [is_true _]UnivConstraintSet.for_all_spec. + split. + - move=> ha c sat cstr /[dup] hin /ha. + move: (checkb_correct cstr) => /fwd. + { now apply inv. } + now move=> [hl hr] /hl /(_ c sat). + - move=> ha cstr /[dup] hin /ha. + move: (checkb_correct cstr) => /fwd. + { now apply inv. } + move=> [hl hr]; apply hr. + Qed. + + Definition check_constraints_spec := check_constraints_spec_gen _ checkb_spec. + End CheckerFlags. End CheckLeq. (* @@ -649,15 +670,23 @@ Qed. Lemma init_constraints_of_levels_union ls ls' : UnivConstraintSet.Equal (init_constraints_of_levels (LevelSet.union ls ls')) (UnivConstraintSet.union (init_constraints_of_levels ls) (init_constraints_of_levels ls')). -Proof. Admitted. +Proof. + intros c. + split. + - move/init_constraints_of_levels_spec_inv => -[] l. + rewrite LevelSet.union_spec UnivConstraintSet.union_spec. + move=> [[hin|hin] /init_constraints_of_levels_spec]; firstorder. + - rewrite UnivConstraintSet.union_spec => -[] /init_constraints_of_levels_spec_inv -[] l [] hin he; + eapply (init_constraints_of_levels_spec _ l); tea; lsets. +Qed. -Lemma is_graph_of_uctx_add `{cf : checker_flags} [m uctx uctx' m'] : +Lemma push_uctx_model `{cf : checker_flags} [m uctx uctx' m'] : push_uctx m uctx' = Some m' -> - is_model_of_uctx m uctx -> - is_model_of_uctx m' (ContextSet.union uctx' uctx). + model_of_uctx m uctx -> + model_of_uctx m' (ContextSet.union uctx' uctx). Proof. move=> he; have := push_uctx_spec m uctx'. rewrite he. - move=> [hlev hcstrs]. unfold is_model_of_uctx. + move=> [hlev hcstrs]. unfold model_of_uctx. move=> [hl hr]. rewrite hlev hl. rewrite LevelSetProp.union_assoc. split. lsets. rewrite hcstrs hr. @@ -665,3 +694,144 @@ Proof. rewrite UnivConstraintSetProp.union_assoc /ContextSet.constraints. ucsets. Qed. + +Lemma is_model_init : model_of_uctx init_model (LevelSet.singleton Level.lzero, UnivConstraintSet.empty). +Proof. + red; cbn. split; unfold LS.Level.zero. + - intros l. lsets. + - ucsets. +Qed. + +Lemma init_constraints_of_levels_None ls : + (forall l, LevelSet.In l ls -> init_constraint_of_level l = None) <-> UnivConstraintSet.Empty (init_constraints_of_levels ls). +Proof. + unfold init_constraints_of_levels. + apply (LevelSetProp.fold_rec). + - intros. split => //. + intros hl e hin. ucsets. + intros _. lsets. + - intros. split => //. + * move=>/[dup] hin' /(_ x) => /fwd. apply H1. now left. + intros ->. rewrite -H2. + intros. apply hin'. apply H1; now right. + * destruct init_constraint_of_level eqn:hi => //. + intros he. specialize (he p). elim he; ucsets. + move=> ha l /H1 -[]. now intros; subst. + rewrite -H2 in ha. apply ha. +Qed. + +Lemma init_constraints_of_levels_singleton_zero : init_constraints_of_levels (LevelSet.singleton Level.lzero) =_ucset UnivConstraintSet.empty. +Proof. + have hi := init_constraints_of_levels_None (LevelSet.singleton Level.lzero). + destruct hi. + forward H. intros l; rewrite LevelSet.singleton_spec. intros -> => //. + ucsets. +Qed. + +Lemma push_uctx_init_model_sat `{cf : checker_flags} [m uctx] : + push_uctx init_model uctx = Some m -> model_of_uctx m uctx. +Proof. + move/push_uctx_model/(_ is_model_init). + rewrite /model_of_uctx. cbn -[init_constraints_of_levels]. + intros [hl hc]. + split. rewrite hl. lsets. + rewrite hc. cbn -[init_constraints_of_levels]. + rewrite /ContextSet.constraints init_constraints_of_levels_union /ContextSet.levels. + rewrite init_constraints_of_levels_singleton_zero. ucsets. +Qed. + +Lemma push_uctx_init_model_unsat `{cf : checker_flags} [uctx] : + global_uctx_invariants uctx -> + push_uctx init_model uctx = None <-> + let allcstrs := (UnivConstraintSet.union uctx.2 (init_constraints_of_levels uctx.1)) in + (~ exists v, satisfies v allcstrs). +Proof. + move=> inv. + set cstrs := UnivConstraintSet.union _ _. + cbn; destruct push_uctx eqn:hp. + - destruct (push_uctx_init_model_sat hp) as [hl hc]. split => //. + elim. exists (to_valuation (model_val u)). + destruct inv as [nz hd]. red in hd. + subst cstrs. rewrite -hc. + eapply model_satisfies. + - split => //. intros _ [v sat]. + have := push_uctx_spec init_model uctx. + cbn. rewrite hp. + intros [[l [hin hsing]]|[ndecl|nsat]]. + * eapply LevelSet.singleton_spec in hsing. subst l. + destruct inv => //. + * destruct inv. red in H0. + rewrite LevelSetProp.add_union_singleton in H0. contradiction. + * apply nsat. exists v. + rewrite -UnivConstraintSetProp.union_assoc. eapply satisfies_union. split => //. + intros c; ucsets. +Qed. + +Instance levelset_sub : RewriteRelation LevelSet.Subset := {}. + +Instance declared_univ_cstr_levels_subset : + Morphisms.Proper (LevelSet.Subset ==> Logic.eq ==> Basics.impl) declared_univ_cstr_levels. +Proof. + intros ?? eq ? [[l d] r] -> hd. + unfold declared_univ_cstr_levels in *. + destruct hd as [h h']. now rewrite -eq. +Qed. + +Instance declared_univ_cstrs_levels_subset : + Morphisms.Proper (LevelSet.Subset ==> UnivConstraintSet.Equal ==> Basics.impl) declared_univ_cstrs_levels. +Proof. + move=> ?? eq ?? eq' hi cl. + rewrite -eq' => /hi. + now rewrite -eq. +Qed. + +Instance levelset_in_subset' l : + Morphisms.Proper (LevelSet.Subset ==> Basics.impl) (LevelSet.In l). +Proof. + intros s s' hs hin. now apply hs. +Qed. +Instance not_impl_proper : + Morphisms.Proper (Basics.impl --> Basics.impl) not. +Proof. + intros P Q hp hnq p. firstorder. +Qed. + +Instance not_impl_proper' : + Morphisms.Proper (Basics.impl ==> Basics.flip Basics.impl) not. +Proof. + intros P Q hp hnq p. firstorder. +Qed. + +Instance union_subset_proper : + Proper (LevelSet.Subset ==> LevelSet.Subset ==> LevelSet.Subset) LevelSet.union. +Proof. + solve_proper. +Qed. + + + +(* Lemma push_uctx_correct m uctx : + global_uctx_invariants uctx -> + let allcstrs := (UnivConstraintSet.union uctx.2 (UnivConstraintSet.union (init_constraints_of_levels uctx.1) (constraints m))) in + { ~ exists v, satisfies v allcstrs } + + { exists m', push_uctx m uctx = Some m' /\ model_of_uctx m' (LevelSet.union (levels m) uctx.1, allcstrs) }. +Proof. + intros hp. have := push_uctx_spec m uctx. + set allcstrs := UnivConstraintSet.union _ _. + cbn. destruct push_uctx. + - move=> -[] hl hc. right. exists u. split => //. + red. rewrite hc. split. cbn. rewrite hl. + rewrite levelset_add_union. + *) + +Import Clauses.FLS. +Open Scope levels_scope. + +Lemma global_uctx_invariants_union_or lvls1 lvls2 cs + : declared_univ_cstrs_levels lvls1 cs \/ declared_univ_cstrs_levels lvls2 cs + -> declared_univ_cstrs_levels (LevelSet.union lvls1 lvls2) cs. +Proof. + have hl : lvls1 ⊂_lset LevelSet.union lvls1 lvls2 by lsets. + have hr : lvls2 ⊂_lset LevelSet.union lvls1 lvls2 by lsets. + intros [hd|hd]; [now rewrite -hl|now rewrite -hr]. +Qed. From 185bea7e79da5492612d29976280f0ed1d761a33 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 4 Nov 2025 01:07:53 +0100 Subject: [PATCH 118/164] Adapting to new universe instances --- common/theories/Environment.v | 2 +- common/theories/EnvironmentTyping.v | 29 +- common/theories/LoopChecking/HornClauses.v | 4 +- .../LoopChecking/InitialSemilattice.v | 1 + common/theories/Universes.v | 48 ++- examples/demo.v | 4 +- examples/typing_correctness.v | 4 +- pcuic/theories/Conversion/PCUICNamelessConv.v | 2 +- .../Conversion/PCUICUnivSubstitutionConv.v | 10 +- pcuic/theories/PCUICAlpha.v | 2 +- pcuic/theories/PCUICAst.v | 10 +- pcuic/theories/PCUICConfluence.v | 2 +- pcuic/theories/PCUICCumulativitySpec.v | 6 +- pcuic/theories/PCUICEquality.v | 8 +- pcuic/theories/PCUICNormal.v | 2 +- pcuic/theories/PCUICTyping.v | 4 +- pcuic/theories/PCUICValidity.v | 2 +- pcuic/theories/PCUICWfUniverses.v | 14 +- pcuic/theories/Syntax/PCUICDepth.v | 12 +- pcuic/theories/Syntax/PCUICInduction.v | 24 +- .../Typing/PCUICUnivSubstitutionTyp.v | 2 +- pcuic/theories/utils/PCUICPrimitive.v | 24 +- safechecker/theories/PCUICEqualityDec.v | 46 +-- safechecker/theories/PCUICSafeConversion.v | 18 +- safechecker/theories/PCUICTypeChecker.v | 8 +- template-rocq/_PluginProject.in | 11 + template-rocq/src/constr_quoter.ml | 13 +- template-rocq/src/constr_reification.ml | 3 +- template-rocq/src/g_template_rocq.ml | 360 ++++++++++++++++++ template-rocq/theories/Ast.v | 8 +- template-rocq/theories/AstUtils.v | 6 +- template-rocq/theories/Checker.v | 40 +- template-rocq/theories/Constants.v | 15 +- template-rocq/theories/Induction.v | 12 +- template-rocq/theories/Lib.v | 6 +- template-rocq/theories/Pretty.v | 2 +- template-rocq/theories/TemplateMonad/Core.v | 8 +- template-rocq/theories/TermEquality.v | 8 +- template-rocq/theories/Typing.v | 6 +- template-rocq/theories/TypingWf.v | 2 +- template-rocq/theories/WfAst.v | 6 +- test-suite/univ.v | 10 +- 42 files changed, 597 insertions(+), 207 deletions(-) create mode 100644 template-rocq/src/g_template_rocq.ml diff --git a/common/theories/Environment.v b/common/theories/Environment.v index 6622bfd1b..756b776e2 100644 --- a/common/theories/Environment.v +++ b/common/theories/Environment.v @@ -908,7 +908,7 @@ Module Environment (T : Term). [/\ cdecl.(cst_type) = tSort Sort.type0, cdecl.(cst_body) = None & cdecl.(cst_universes) = Monomorphic_ctx] | primArray => - let s := sType (Universe.make' (Level.lvar 0)) in + let s := sType (Universe.of_level (Level.lvar 0)) in [/\ cdecl.(cst_type) = tImpl (tSort s) (tSort s), cdecl.(cst_body) = None & cdecl.(cst_universes) = Polymorphic_ctx array_uctx] end. diff --git a/common/theories/EnvironmentTyping.v b/common/theories/EnvironmentTyping.v index 6ed4f360a..7a2a09962 100644 --- a/common/theories/EnvironmentTyping.v +++ b/common/theories/EnvironmentTyping.v @@ -2,7 +2,7 @@ From Stdlib Require Import ssreflect ssrbool. From Stdlib Require CMorphisms CRelationClasses. From MetaRocq.Utils Require Import utils. -From MetaRocq.Common Require Import config BasicAst Universes Environment Primitive. +From MetaRocq.Common Require Import config BasicAst UnivConstraintType Universes Environment Primitive. From Equations Require Import Equations. Module Lookup (T : Term) (E : EnvironmentSig T). @@ -261,7 +261,7 @@ Module Lookup (T : Term) (E : EnvironmentSig T). | Monomorphic_ctx => List.length u = 0 | Polymorphic_ctx c => (* levels of the instance already declared *) - forallb (fun l => LevelSet.mem l lvs) u /\ + forallb (fun l : Universe.t => LevelSet.subset (Universe.levels l) lvs) u /\ List.length u = List.length c.1 /\ valid_constraints φ (subst_instance_cstrs u c.2) end. @@ -288,7 +288,7 @@ Module Lookup (T : Term) (E : EnvironmentSig T). Definition wf_universe_dec Σ u : {wf_universe Σ u} + {~wf_universe Σ u}. Proof. - cbv [wf_universe LevelExprSet.In LevelExprSet.this LevelExprSet.t_set]. + cbv [wf_universe LevelExprSet.In LevelExprSet.this Universe.t_set]. destruct u as [[t _] _]. induction t as [|t ts [IHt|IHt]]; [ left | | right ]. { inversion 1. } @@ -1417,12 +1417,17 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT | Level.lvar k => Level.lvar (n + k) end. + Definition on_fst {A B} (f : A -> A) (x : A * B) : A * B := (f x.1, x.2). + + Definition lift_universe n u := + Universe.map (on_fst (lift_level n)) u. + Definition lift_instance n l := map (lift_level n) l. - Definition lift_constraint n (c : Level.t * ConstraintType.t * Level.t) := + Definition lift_constraint n (c : Universe.t * ConstraintType.t * Universe.t) := let '((l, r), l') := c in - ((lift_level n l, r), lift_level n l'). + ((lift_universe n l, r), lift_universe n l'). Definition lift_constraints n cstrs := UnivConstraintSet.fold (fun elt acc => UnivConstraintSet.add (lift_constraint n elt) acc) @@ -1431,14 +1436,14 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Definition level_var_instance n (inst : list name) := mapi_rec (fun i _ => Level.lvar i) inst n. - Fixpoint variance_cstrs (v : list Variance.t) (u u' : Instance.t) := + Fixpoint variance_cstrs (v : list Variance.t) (u u' : LevelInstance.t) := match v, u, u' with | _, [], [] => UnivConstraintSet.empty | v :: vs, u :: us, u' :: us' => match v with | Variance.Irrelevant => variance_cstrs vs us us' - | Variance.Covariant => UnivConstraintSet.add (u, ConstraintType.Le 0, u') (variance_cstrs vs us us') - | Variance.Invariant => UnivConstraintSet.add (u, ConstraintType.Eq, u') (variance_cstrs vs us us') + | Variance.Covariant => UnivConstraintSet.add (Universe.of_level u, ConstraintType.Le, Universe.of_level u') (variance_cstrs vs us us') + | Variance.Invariant => UnivConstraintSet.add (Universe.of_level u, ConstraintType.Eq, Universe.of_level u') (variance_cstrs vs us us') end | _, _, _ => (* Impossible due to on_variance invariant *) UnivConstraintSet.empty end. @@ -1457,7 +1462,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT let cstrs := UnivConstraintSet.union cstrs (lift_constraints #|inst| cstrs) in let cstrv := variance_cstrs v u u' in let auctx' := (inst ++ inst, UnivConstraintSet.union cstrs cstrv) in - Some (Polymorphic_ctx auctx', u, u') + Some (Polymorphic_ctx auctx', Instance.of_level_instance u, Instance.of_level_instance u') end. (** A constructor type respects the given variance [v] if each constructor @@ -1568,7 +1573,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT type substituted along with the previous arguments replaced by projections. *) let u := abstract_instance mdecl.(ind_universes) in let ind := {| inductive_mind := mind; inductive_ind := i |} in - p.(proj_type) = subst (inds mind u mdecl.(ind_bodies)) (S (ind_npars mdecl)) + p.(proj_type) = subst (inds mind (Instance.of_level_instance u) mdecl.(ind_bodies)) (S (ind_npars mdecl)) (subst (projs ind mdecl.(ind_npars) k) 0 (lift 1 k (decl_type decl))); on_proj_relevance : p.(proj_relevance) = decl.(decl_name).(binder_relevance) }. @@ -1799,14 +1804,14 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT intro H; split => //. unfold empty_ext, snd. repeat split. - unfold levels_of_udecl. intros x e. lsets. - - unfold constraints_of_udecl. intros x e. csets. + - unfold constraints_of_udecl. intros x e. ucsets. - unfold satisfiable_udecl, univs_ext_constraints, constraints_of_udecl, fst_ctx, fst => //. destruct H as ((cstrs & _ & consistent) & decls). destruct consistent; eexists. intros v e. specialize (H v e); tea. - unfold valid_on_mono_udecl, constraints_of_udecl, consistent_extension_on. intros v sat; exists v; split. - + intros x e. csets. + + intros x e. ucsets. + intros x e => //. Qed. diff --git a/common/theories/LoopChecking/HornClauses.v b/common/theories/LoopChecking/HornClauses.v index 7b3d4d8a3..125a11ba8 100644 --- a/common/theories/LoopChecking/HornClauses.v +++ b/common/theories/LoopChecking/HornClauses.v @@ -106,7 +106,7 @@ Module Clauses (LS : LevelSets). Definition t := clause. - Definition eq : t -> t -> Prop := eq. + Definition eq : t -> t -> Prop := Logic.eq. Definition eq_equiv : RelationClasses.Equivalence eq := _. @@ -178,7 +178,7 @@ Module Clauses (LS : LevelSets). Qed. Local Instance proper_fold_transpose {A} (f : Clauses.elt -> A -> A) : - transpose eq f -> + transpose Logic.eq f -> Proper (Clauses.Equal ==> eq ==> eq) (Clauses.fold f). Proof. intros hf s s' Hss' x ? <-. diff --git a/common/theories/LoopChecking/InitialSemilattice.v b/common/theories/LoopChecking/InitialSemilattice.v index 1726dfd2d..6160942b7 100644 --- a/common/theories/LoopChecking/InitialSemilattice.v +++ b/common/theories/LoopChecking/InitialSemilattice.v @@ -14,6 +14,7 @@ Module InitialSemilattice (LS : LevelSets). Existing Instance comm_monoid. Existing Instance add_inj_eq. Export LS. + Import NES.OfQ. Local Open Scope quantity. Import NES. diff --git a/common/theories/Universes.v b/common/theories/Universes.v index b16e02a5b..a0fcbc144 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -422,7 +422,7 @@ Module Universe. Definition eq_leibniz x y : eq x y -> x = y := fun e => e. End Q. - Module NES := NonEmptyLevelExprSet Level Q LevelSet LevelExpr LevelExprSet. + Module NES := NonEmptyLevelExprSet Level Level Q LevelSet LevelExpr LevelExprSet. Include NES. #[global] Instance eq_dec_univ0 : EqDec t := eq_dec. @@ -430,9 +430,13 @@ Module Universe. Definition eqb : t -> t -> bool := eqb. Definition make (e: LevelExpr.t) : t := singleton e. - Definition make' (l: Level.t) : t := singleton (LevelExpr.make l). - Lemma make'_inj l l' : make' l = make' l' -> l = l'. + Definition of_level (l: Level.t) : t := singleton (LevelExpr.make l). + + #[deprecated(since = "1.4", note="use of_level instead")] + Notation make' := of_level. + + Lemma make'_inj l l' : of_level l = of_level l' -> l = l'. Proof. destruct l, l' => //=; now inversion 1. Qed. @@ -459,7 +463,7 @@ Module Universe. Definition is_level (u : t) : bool := (LevelExprSet.cardinal u =? 1)%nat && is_levels u. - Definition zero := make' Level.lzero. + Definition zero := of_level Level.lzero. Definition succ : t -> t := map LevelExpr.succ. @@ -481,7 +485,7 @@ Module Universe. Proof. reflexivity. Qed. Lemma val_make' v l - : val v (make' l) = val v l. + : val v (of_level l) = val v l. Proof. reflexivity. Qed. Definition lt : t -> t -> Prop := LevelExprSet.lt. @@ -758,7 +762,7 @@ Qed. Lemma universe_get_is_level_correct u l : - Universe.get_is_level u = Some l -> u = Universe.make' l. + Universe.get_is_level u = Some l -> u = Universe.of_level l. Proof. intro H. unfold Universe.get_is_level in *. @@ -923,7 +927,7 @@ End LevelInstance. Module Instance. - (** A universe instance represents a vector of argument concrete_sort + (** A universe instance represents a vector of arguments to a polymorphic definition (constant, inductive or constructor). *) Definition t := list Universe.t. @@ -937,8 +941,13 @@ Module Instance. Definition eqb (i j : t) := forallb2 Universe.eqb i j. + + Definition of_level_instance : LevelInstance.t -> t := map Universe.of_level. + End Instance. +Coercion Instance.of_level_instance : LevelInstance.t >-> Instance.t. + Module UContext. Definition t := list name × (LevelInstance.t × UnivConstraintSet.t). @@ -1662,7 +1671,7 @@ Module Sort. match l with | inl PropLevel.lSProp => sSProp | inl PropLevel.lProp => sProp - | inr l => sType (Universe.make' l) + | inr l => sType (Universe.of_level l) end. (** The universe strictly above FOR TYPING (not cumulativity) *) @@ -1857,7 +1866,7 @@ Proof. Qed. Lemma get_is_level_correct s l : - Sort.get_is_level s = Some l -> s = sType (Universe.make' l). + Sort.get_is_level s = Some l -> s = sType (Universe.of_level l). Proof. intro H; destruct s => //=. f_equal; now apply universe_get_is_level_correct. @@ -2523,7 +2532,7 @@ End no_prop_leq_type. (* This level is a hack used in plugings to generate fresh levels *) Definition fresh_level : Level.t := Level.level "__metarocq_fresh_level__". (* This universe is a hack used in plugins to generate fresh universes *) -Definition fresh_universe : Universe.t := Universe.make' fresh_level. +Definition fresh_universe : Universe.t := Universe.of_level fresh_level. (** * Universe substitution @@ -2938,15 +2947,19 @@ Hint Resolve subst_instance_level_expr_closedu Definition string_of_level (l : Level.t) : string := match l with - | Level.lzero => "Set" + | Level.lzero => "0" | Level.level s => s - | Level.lvar n => "lvar" ^ string_of_nat n + | Level.lvar n => "(lvar " ^ string_of_nat n ^ ")" end. Definition string_of_level_expr (e : LevelExpr.t) : string := - let '(l, n) := e in string_of_level l ^ (if n is 0 then "" else "+" ^ string_of_nat n). + let '(l, n) := e in + match l with + | Level.lzero => string_of_nat n + | _ => string_of_level l ^ (if n is 0 then "" else "+" ^ string_of_nat n) + end. -Definition string_of_universe (e : LevelExprSet.t) : string := +Definition string_of_universe (e : Universe.t) : string := string_of_list string_of_level_expr (LevelExprSet.elements e). Definition string_of_sort (u : Sort.t) := @@ -2956,9 +2969,12 @@ Definition string_of_sort (u : Sort.t) := | Sort.sType l => "Type(" ^ string_of_universe l ^ ")" end. -Definition string_of_universe_instance u := +Definition string_of_universe_level_instance (u : LevelInstance.t) := string_of_list string_of_level u. +Definition string_of_universe_instance (u : Instance.t) := + string_of_list string_of_universe u. + Inductive universes_entry := | Monomorphic_entry (ctx : ContextSet.t) | Polymorphic_entry (ctx : UContext.t). @@ -2985,7 +3001,7 @@ Definition abstract_instance decl := Definition print_universe_instance u := match u with | [] => "" - | _ => "@{" ^ print_list string_of_level " " u ^ "}" + | _ => "@{" ^ print_list string_of_universe " " u ^ "}" end. Definition print_lset t := diff --git a/examples/demo.v b/examples/demo.v index 5a21f0220..9406fa1fd 100644 --- a/examples/demo.v +++ b/examples/demo.v @@ -379,10 +379,10 @@ Inductive T : Type := MetaRocq Quote Recursively Definition TT := T. Unset MetaRocq Strict Unquote Universe Mode. -MetaRocq Unquote Definition t := (tSort (sType (Universe.make' (Level.level "Top.20000")))). +MetaRocq Unquote Definition t := (tSort (sType (Universe.of_level (Level.level "Top.20000")))). MetaRocq Unquote Definition t' := (tSort (sType fresh_universe)). MetaRocq Unquote Definition myProp := (tSort sProp). -MetaRocq Unquote Definition mySet := (tSort (sType (Universe.make' Level.lzero))). +MetaRocq Unquote Definition mySet := (tSort (sType (Universe.of_level Level.lzero))). (** Cofixpoints *) CoInductive streamn : Set := diff --git a/examples/typing_correctness.v b/examples/typing_correctness.v index 233d084cc..4621eae64 100644 --- a/examples/typing_correctness.v +++ b/examples/typing_correctness.v @@ -145,7 +145,7 @@ Ltac fill_inh t := | [ |- inh _ ?Γ _ ] => fail "Missing local wellformedness assumption for" Γ end. -(* Lemma identity_typing (s := sType (Universe.make' univ)): inh gctx_wf_env [] (tImpl (tSort s) (tSort s)). +(* Lemma identity_typing (s := sType (Universe.of_level univ)): inh gctx_wf_env [] (tImpl (tSort s) (tSort s)). Proof. set (impl := tLambda (bNamed "s") (tSort s) (tRel 0)). assert (wfΓ : forall Σ0 : global_env_ext, @@ -156,7 +156,7 @@ Proof. Time Qed. *) -Lemma identity_typing (s := sType (Universe.make' univ)): +Lemma identity_typing (s := sType (Universe.of_level univ)): (∑ t : term, forall Σ0 : global_env_ext, Σ0 = diff --git a/pcuic/theories/Conversion/PCUICNamelessConv.v b/pcuic/theories/Conversion/PCUICNamelessConv.v index fc87b119d..62ac47893 100644 --- a/pcuic/theories/Conversion/PCUICNamelessConv.v +++ b/pcuic/theories/Conversion/PCUICNamelessConv.v @@ -136,7 +136,7 @@ Proof. - f_equal. destruct o; auto. f_equal. f_equal. cbn in X, hu, hv. rtoProp. - destruct X as (hty & hdef & harr). eapply Universe.make'_inj in e. + destruct X as (hty & hdef & harr). eapply Universe.of_level_inj in e. destruct a, a'; cbn in *. f_equal; intuition eauto. apply All2_eq. solve_all. Qed. diff --git a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v index bd64de51a..272716b91 100644 --- a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v +++ b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v @@ -122,8 +122,8 @@ Lemma subst_instance_universe_make' (l : LevelExpr.t) u : Proof. reflexivity. Qed. Lemma subst_instance_universe_make l u : - subst_instance_universe u (Universe.make' l) - = Universe.make' (subst_instance u l). + subst_instance_universe u (Universe.of_level l) + = Universe.of_level (subst_instance u l). Proof. destruct l; cbnr. rewrite nth_nth_error. destruct nth_error; cbnr. @@ -142,7 +142,7 @@ Lemma subst_equal_inst_inst Re Re' : Proof. intros hRe u. induction u; cbnr; try now constructor. intros u1 u2; unfold cmp_universe_instance; cbn; constructor. - - pose proof (hRe (Universe.make' a) u1 u2 H) as HH. + - pose proof (hRe (Universe.of_level a) u1 u2 H) as HH. now rewrite /subst_instance !subst_instance_universe_make in HH. - exact (IHu u1 u2 H). Qed. @@ -2094,14 +2094,14 @@ Section SubstIdentity. - eapply nth_error_all in X0 as (_ & X0 & _); tea. - destruct p as [? []]; cbnr. do 2 f_equal. depelim X0. specialize (hty X1); specialize (hdef X1). - unfold mapu_array_model; destruct a; cbn -[Universe.make'] in *. + unfold mapu_array_model; destruct a; cbn -[Universe.of_level] in *. f_equal; intuition eauto. * rewrite /subst_instance subst_instance_universe_make in b. now injection b as e. * solve_all. - depelim X0; cbn => //=. depelim X. simp prim_type. cbn. f_equal; intuition eauto. do 2 f_equal. - cbn -[Universe.make'] in b. + cbn -[Universe.of_level] in b. rewrite /subst_instance subst_instance_universe_make in b. now injection b as e. Qed. diff --git a/pcuic/theories/PCUICAlpha.v b/pcuic/theories/PCUICAlpha.v index 26fb12cf3..9e4ebc414 100644 --- a/pcuic/theories/PCUICAlpha.v +++ b/pcuic/theories/PCUICAlpha.v @@ -883,7 +883,7 @@ Section Alpha. eapply eq_term_upto_univ_cumulSpec. eapply eq_term_leq_term. eapply e1. * eapply eq_context_conversion in Hs; eauto. - * simp prim_type. eapply Universe.make'_inj in e. rewrite e. + * simp prim_type. eapply Universe.of_level_inj in e. rewrite e. eapply eq_term_upto_univ_cumulSpec. eapply upto_names_impl_leq_term. constructor. constructor. reflexivity. now symmetry. diff --git a/pcuic/theories/PCUICAst.v b/pcuic/theories/PCUICAst.v index e5c5385bf..96a7f8c89 100644 --- a/pcuic/theories/PCUICAst.v +++ b/pcuic/theories/PCUICAst.v @@ -426,7 +426,7 @@ Instance subst_instance_constr : UnivSubst term := | tCoFix mfix idx => let mfix' := List.map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix in tCoFix mfix' idx - | tPrim p => tPrim (mapu_prim (subst_instance_level u) (subst_instance_constr u) p) + | tPrim p => tPrim (mapu_prim (subst_instance_universe u) (subst_instance_constr u) p) end. (** Tests that the term is closed over [k] universe variables *) @@ -450,7 +450,7 @@ Fixpoint closedu (k : nat) (t : term) : bool := forallb (test_def (closedu k) (closedu k)) mfix | tCoFix mfix idx => forallb (test_def (closedu k) (closedu k)) mfix - | tPrim p => test_primu (closedu_level k) (closedu k) p + | tPrim p => test_primu (closedu_universe k) (closedu k) p | _ => true end. @@ -951,14 +951,14 @@ Proof. destruct p as [? []] => //. Qed. -Lemma mapu_array_model_proper {term term'} (l l' : Level.t -> Level.t) (f g : term -> term') a : +Lemma mapu_array_model_proper {term term'} (l l' : Universe.t -> Universe.t) (f g : term -> term') a : l ≐1 l' -> f ≐1 g -> mapu_array_model l f a = mapu_array_model l' g a. Proof. destruct a; cbn ; rewrite /mapu_array_model /=. intros; f_equal; eauto. now eapply map_ext. Qed. -Lemma mapu_array_model_proper_cond {term term'} (P : term -> Type) (l l' : Level.t -> Level.t) (f g : term -> term') a : +Lemma mapu_array_model_proper_cond {term term'} (P : term -> Type) (l l' : Universe.t -> Universe.t) (f g : term -> term') a : l ≐1 l' -> (forall x, P x -> f x = g x) -> P a.(array_type) × P a.(array_default) × All P a.(array_value) -> mapu_array_model l f a = mapu_array_model l' g a. @@ -1043,7 +1043,7 @@ Proof. eapply All_map_id, All_impl; tea. intuition eauto. apply hg; intuition auto. Qed. -Lemma test_primu_test_primu_tPrimProp {P : term -> Type} {pu put} {pu' : Level.t -> bool} {put' : term -> bool} p f g : +Lemma test_primu_test_primu_tPrimProp {P : term -> Type} {pu put} {pu' : Universe.t -> bool} {put' : term -> bool} p f g : tPrimProp P p -> test_primu pu put p -> (forall u, pu u -> pu' (f u)) -> (forall t, P t -> put t -> put' (g t)) -> diff --git a/pcuic/theories/PCUICConfluence.v b/pcuic/theories/PCUICConfluence.v index b393dde2a..b6915b002 100644 --- a/pcuic/theories/PCUICConfluence.v +++ b/pcuic/theories/PCUICConfluence.v @@ -2203,7 +2203,7 @@ Section PredRed. - depelim X1; try solve [repeat constructor]; eauto. depelim X2; cbn in H0; rtoProp. eapply red_primArray_congr; eauto. - + now eapply Universe.make'_inj in e. + + now eapply Universe.of_level_inj in e. + solve_all. Qed. diff --git a/pcuic/theories/PCUICCumulativitySpec.v b/pcuic/theories/PCUICCumulativitySpec.v index ceab06392..42837f7b4 100644 --- a/pcuic/theories/PCUICCumulativitySpec.v +++ b/pcuic/theories/PCUICCumulativitySpec.v @@ -28,7 +28,7 @@ Definition cumul_predicate_dep {cumul cumul_universe Γ p p'} Lemma cumul_predicate_undep {cumul cumul_universe Γ p p' H cumul' cumul_universe'} : @cumul_predicate cumul' cumul_universe' Γ p p' <~> - @cumul_predicate_dep cumul cumul_universe Γ p p' H (fun Γ p p' _ => cumul' Γ p p') (fun x y _ => on_rel cumul_universe' Universe.make' x y). + @cumul_predicate_dep cumul cumul_universe Γ p p' H (fun Γ p p' _ => cumul' Γ p p') (fun x y _ => on_rel cumul_universe' Universe.of_level x y). Proof. cbv [cumul_predicate cumul_predicate_dep cmp_universe_instance cmp_universe_instance_dep] in *. split; intro; repeat destruct ?; subst; rdest; try assumption. @@ -380,7 +380,7 @@ Lemma cumulSpec0_rect : (forall (Γ : context) (pb : conv_pb) (indn : case_info) (p p' : predicate term) (c c' : term) (brs brs' : list (branch term)) (Hp : cumul_predicate (fun Γ => cumulSpec0 Σ Γ Conv) (compare_universe Σ Conv) Γ p p') - (_ : cumul_predicate_dep Hp (fun Γ => P cf Σ Γ Conv) (fun l l' _ => on_rel (fun _ _ => True) Universe.make' l l')) + (_ : cumul_predicate_dep Hp (fun Γ => P cf Σ Γ Conv) (fun l l' _ => on_rel (fun _ _ => True) Universe.of_level l l')) (Hc : cumulSpec0 Σ Γ Conv c c') (_ : P cf Σ Γ Conv c c' Hc) (Hbody : cumul_branches (fun Γ => cumulSpec0 Σ Γ Conv) Γ p brs brs') (_ : All2_dep @@ -654,7 +654,7 @@ Lemma convSpec0_ind_all : (forall (Γ : context) (indn : case_info) (p p' : predicate term) (c c' : term) (brs brs' : list (branch term)) (Hp : cumul_predicate (fun Γ => cumulSpec0 Σ Γ Conv) (compare_universe Σ Conv) Γ p p') - (_ : cumul_predicate_dep Hp (fun Γ => P cf Σ Γ Conv) (fun l l' _ => on_rel (fun _ _ => True) Universe.make' l l')) + (_ : cumul_predicate_dep Hp (fun Γ => P cf Σ Γ Conv) (fun l l' _ => on_rel (fun _ _ => True) Universe.of_level l l')) (Hc : cumulSpec0 Σ Γ Conv c c') (_ : P cf Σ Γ Conv c c' Hc) (Hbody : cumul_branches (fun Γ => cumulSpec0 Σ Γ Conv) Γ p brs brs') (_ : All2_dep diff --git a/pcuic/theories/PCUICEquality.v b/pcuic/theories/PCUICEquality.v index 9d7ab1ddf..c5e22f124 100644 --- a/pcuic/theories/PCUICEquality.v +++ b/pcuic/theories/PCUICEquality.v @@ -21,7 +21,7 @@ Instance All2_fold_len {A} P (Γ Δ : list A) : HasLen (All2_fold P Γ Δ) #|Γ| Implicit Types (cf : checker_flags). Definition cmp_universe_instance (cmp_univ : Universe.t -> Universe.t -> Prop) : Instance.t -> Instance.t -> Prop := - Forall2 (on_rel cmp_univ Universe.make'). + Forall2 (on_rel cmp_univ Universe.of_level). Definition cmp_universe_instance_dep cmp_univ P' := fun {u u'} (H : cmp_universe_instance cmp_univ u u') => Forall2_dep P' H. @@ -36,8 +36,8 @@ Definition cmp_universe_instance_dep cmp_univ P' := Definition cmp_universe_variance (cmp_univ : conv_pb -> Universe.t -> Universe.t -> Prop) pb v u u' := match v with | Variance.Irrelevant => True - | Variance.Covariant => on_rel (cmp_univ pb) Universe.make' u u' - | Variance.Invariant => on_rel (cmp_univ Conv) Universe.make' u u' + | Variance.Covariant => on_rel (cmp_univ pb) Universe.of_level u u' + | Variance.Invariant => on_rel (cmp_univ Conv) Universe.of_level u u' end. Definition cmp_universe_instance_variance cmp_univ pb v u u' := @@ -84,7 +84,7 @@ Definition cmp_opt_variance cmp_univ pb v := Lemma cmp_universe_universe_variance (cmp_univ : conv_pb -> Universe.t -> Universe.t -> Prop) pb v u u' : RelationClasses.subrelation (cmp_univ Conv) (cmp_univ pb) -> - on_rel (cmp_univ Conv) Universe.make' u u' -> cmp_universe_variance cmp_univ pb v u u'. + on_rel (cmp_univ Conv) Universe.of_level u u' -> cmp_universe_variance cmp_univ pb v u u'. Proof. destruct v => //=. intros H H1; apply H, H1. diff --git a/pcuic/theories/PCUICNormal.v b/pcuic/theories/PCUICNormal.v index 31276b85e..8a37ca532 100644 --- a/pcuic/theories/PCUICNormal.v +++ b/pcuic/theories/PCUICNormal.v @@ -1049,7 +1049,7 @@ Proof. eauto. - depelim o. 1-3: reflexivity. eapply red_primArray_congr; eauto. - now eapply Universe.make'_inj in e. + now eapply Universe.of_level_inj in e. Qed. #[global] diff --git a/pcuic/theories/PCUICTyping.v b/pcuic/theories/PCUICTyping.v index db055d011..caa63e6af 100644 --- a/pcuic/theories/PCUICTyping.v +++ b/pcuic/theories/PCUICTyping.v @@ -181,8 +181,8 @@ Variant primitive_typing_hyps `{checker_flags} | prim_float_hyps f : primitive_typing_hyps typing Σ Γ (primFloat; primFloatModel f) | prim_string_hyps s : primitive_typing_hyps typing Σ Γ (primString; primStringModel s) | prim_array_hyps a - (wfl : wf_universe Σ (Universe.make' a.(array_level))) - (hty : typing Σ Γ a.(array_type) (tSort (sType (Universe.make' a.(array_level))))) + (wfl : wf_universe Σ (Universe.of_level a.(array_level))) + (hty : typing Σ Γ a.(array_type) (tSort (sType (Universe.of_level a.(array_level))))) (hdef : typing Σ Γ a.(array_default) a.(array_type)) (hvalue : All (fun x => typing Σ Γ x a.(array_type)) a.(array_value)) : primitive_typing_hyps typing Σ Γ (primArray; primArrayModel a). diff --git a/pcuic/theories/PCUICValidity.v b/pcuic/theories/PCUICValidity.v index 14af1c961..4479d7063 100644 --- a/pcuic/theories/PCUICValidity.v +++ b/pcuic/theories/PCUICValidity.v @@ -335,7 +335,7 @@ Section Validity. depelim X0; depelim X1; simp prim_type; cbn in *. 1-3:destruct H1 as [hty hbod huniv]; eapply has_sort_isType with (s := _@[[]]); change (tSort ?s@[[]]) with (tSort s)@[[]]; rewrite <- hty; refine (type_Const _ _ _ [] _ wfΓ H0 _); rewrite huniv //. - set (s := sType (Universe.make' (array_level a))). + set (s := sType (Universe.of_level (array_level a))). destruct H1 as [hty' hbod huniv]. eapply has_sort_isType with s. eapply (type_App _ _ _ _ (tSort s) (tSort s)); tea; cycle 1. diff --git a/pcuic/theories/PCUICWfUniverses.v b/pcuic/theories/PCUICWfUniverses.v index 0cc6e9130..e7f553966 100644 --- a/pcuic/theories/PCUICWfUniverses.v +++ b/pcuic/theories/PCUICWfUniverses.v @@ -306,7 +306,7 @@ Section CheckerFlags. | tLambda _ t u => on_universes fu fc t && on_universes fu fc u | tCase _ p c brs => [&& - forallb fu (map Universe.make' p.(puinst)) , + forallb fu (map Universe.of_level p.(puinst)) , forallb (on_universes fu fc) p.(pparams) , test_context (fc #|p.(puinst)|) p.(pcontext) , on_universes fu fc p.(preturn) , @@ -318,9 +318,9 @@ Section CheckerFlags. | tFix mfix _ | tCoFix mfix _ => forallb (fun d => on_universes fu fc d.(dtype) && on_universes fu fc d.(dbody)) mfix | tConst _ u | tInd _ u | tConstruct _ _ u => - forallb fu (map Universe.make' u) + forallb fu (map Universe.of_level u) | tEvar _ args => forallb (on_universes fu fc) args - | tPrim p => test_primu (fun x => fu (Universe.make' x)) (on_universes fu fc) p + | tPrim p => test_primu (fun x => fu (Universe.of_level x)) (on_universes fu fc) p | _ => true end. @@ -335,7 +335,7 @@ Section CheckerFlags. Qed. Lemma wf_universeb_instance_forall u : - forallb wf_universeb (map Universe.make' u) = wf_instanceb Σ u. + forallb wf_universeb (map Universe.of_level u) = wf_instanceb Σ u. Proof using Type. induction u => //=. rewrite IHu. @@ -460,7 +460,7 @@ Qed. induction t using term_forall_list_ind; simpl in *; auto; try to_prop; try apply /andP; intuition eauto 4. - all:cbn -[Universe.make'] in * ; to_wfu; autorewrite with map; repeat (f_equal; solve_all). + all:cbn -[Universe.of_level] in * ; to_wfu; autorewrite with map; repeat (f_equal; solve_all). - destruct Σ as [Σ univs']. simpl in *. eapply (wf_sort_subst_instance_sort (Σ, univs)); auto. @@ -544,7 +544,7 @@ Qed. intros. now eapply weaken_wf_level. Qed. - Arguments Universe.make' : simpl never. + Arguments Universe.of_level : simpl never. Lemma test_primu_test_primu_tPrimProp {P : term -> Type} {pu put} {pu' : Level.t -> bool} {put' : term -> bool} p : tPrimProp P p -> test_primu pu put p -> (forall u, pu u -> pu' u) -> @@ -961,7 +961,7 @@ Qed. now eapply wf_level_closed. Qed. - Lemma wf_universe_make Σ u : wf_universe Σ (Universe.make' u) -> wf_level Σ u. + Lemma wf_universe_make Σ u : wf_universe Σ (Universe.of_level u) -> wf_level Σ u. Proof. rewrite /wf_universe /= => hl; rewrite /wf_level. apply (hl (u, 0)). lsets. diff --git a/pcuic/theories/Syntax/PCUICDepth.v b/pcuic/theories/Syntax/PCUICDepth.v index 965ffd445..8ae953a4b 100644 --- a/pcuic/theories/Syntax/PCUICDepth.v +++ b/pcuic/theories/Syntax/PCUICDepth.v @@ -336,9 +336,9 @@ Lemma term_forall_ctx_list_ind : (forall Γ (t u : term), (forall t', depth t' < depth (tApp t u) -> P Γ t') -> P Γ t -> P Γ u -> P Γ (tApp t u)) -> - (forall Γ s (u : list Level.t), P Γ (tConst s u)) -> - (forall Γ (i : inductive) (u : list Level.t), P Γ (tInd i u)) -> - (forall Γ (i : inductive) (n : nat) (u : list Level.t), P Γ (tConstruct i n u)) -> + (forall Γ s (u : Instance.t), P Γ (tConst s u)) -> + (forall Γ (i : inductive) (u : Instance.t), P Γ (tInd i u)) -> + (forall Γ (i : inductive) (n : nat) (u : Instance.t), P Γ (tConstruct i n u)) -> (forall Γ (ci : case_info) (p : predicate term) (t : term) (brs : list (branch term)), CasePredProp P Γ p -> P Γ t -> @@ -462,9 +462,9 @@ Lemma term_ind_depth_app : (forall (t u : term), (forall t', depth t' < depth (tApp t u) -> P t') -> P t -> P u -> P (tApp t u)) -> - (forall s (u : list Level.t), P (tConst s u)) -> - (forall (i : inductive) (u : list Level.t), P (tInd i u)) -> - (forall (i : inductive) (n : nat) (u : list Level.t), P (tConstruct i n u)) -> + (forall s (u : Instance.t), P (tConst s u)) -> + (forall (i : inductive) (u : Instance.t), P (tInd i u)) -> + (forall (i : inductive) (n : nat) (u : Instance.t), P (tConstruct i n u)) -> (forall (ci : case_info) (p : predicate term) (t : term) (brs : list (branch term)), CasePredProp_depth P p -> P t -> diff --git a/pcuic/theories/Syntax/PCUICInduction.v b/pcuic/theories/Syntax/PCUICInduction.v index 364aa2155..e3a82932e 100644 --- a/pcuic/theories/Syntax/PCUICInduction.v +++ b/pcuic/theories/Syntax/PCUICInduction.v @@ -32,9 +32,9 @@ Lemma term_forall_list_ind : (forall (n : aname) (t : term), P t -> forall t0 : term, P t0 -> forall t1 : term, P t1 -> P (tLetIn n t t0 t1)) -> (forall t u : term, P t -> P u -> P (tApp t u)) -> - (forall s (u : list Level.t), P (tConst s u)) -> - (forall (i : inductive) (u : list Level.t), P (tInd i u)) -> - (forall (i : inductive) (n : nat) (u : list Level.t), P (tConstruct i n u)) -> + (forall s (u : Instance.t), P (tConst s u)) -> + (forall (i : inductive) (u : Instance.t), P (tInd i u)) -> + (forall (i : inductive) (n : nat) (u : Instance.t), P (tConstruct i n u)) -> (forall (ind : case_info) (p : predicate term), tCasePredProp P P p -> forall c : term, P c -> forall l : list (branch term), tCaseBrsProp P l -> P (tCase ind p c l)) -> @@ -255,9 +255,9 @@ Lemma term_forall_mkApps_ind : (forall (n : aname) (t : term), P t -> forall t0 : term, P t0 -> forall t1 : term, P t1 -> P (tLetIn n t t0 t1)) -> (forall t : term, forall v, ~ isApp t -> P t -> v <> [] -> All P v -> P (mkApps t v)) -> - (forall (s : kername) (u : list Level.t), P (tConst s u)) -> - (forall (i : inductive) (u : list Level.t), P (tInd i u)) -> - (forall (i : inductive) (n : nat) (u : list Level.t), P (tConstruct i n u)) -> + (forall (s : kername) (u : Instance.t), P (tConst s u)) -> + (forall (i : inductive) (u : Instance.t), P (tInd i u)) -> + (forall (i : inductive) (n : nat) (u : Instance.t), P (tConstruct i n u)) -> (forall (ind : case_info) (p : predicate term), tCasePredProp P P p -> forall c : term, P c -> forall l : list (branch term), @@ -482,9 +482,9 @@ Lemma term_forall_ctx_list_ind : (forall Γ (n : aname) (t : term), P Γ t -> forall t0 : term, P Γ t0 -> forall t1 : term, P (vdef n t t0 :: Γ) t1 -> P Γ (tLetIn n t t0 t1)) -> (forall Γ (t u : term), P Γ t -> P Γ u -> P Γ (tApp t u)) -> - (forall Γ s (u : list Level.t), P Γ (tConst s u)) -> - (forall Γ (i : inductive) (u : list Level.t), P Γ (tInd i u)) -> - (forall Γ (i : inductive) (n : nat) (u : list Level.t), P Γ (tConstruct i n u)) -> + (forall Γ s (u : Instance.t), P Γ (tConst s u)) -> + (forall Γ (i : inductive) (u : Instance.t), P Γ (tInd i u)) -> + (forall Γ (i : inductive) (n : nat) (u : Instance.t), P Γ (tConstruct i n u)) -> (forall Γ (ci : case_info) (p : predicate term) (t : term) (brs : list (branch term)), CasePredProp P Γ p -> P Γ t -> @@ -599,9 +599,9 @@ Lemma term_ind_size_app : (forall (t u : term), (forall t', size t' < size (tApp t u) -> P t') -> P t -> P u -> P (tApp t u)) -> - (forall s (u : list Level.t), P (tConst s u)) -> - (forall (i : inductive) (u : list Level.t), P (tInd i u)) -> - (forall (i : inductive) (n : nat) (u : list Level.t), P (tConstruct i n u)) -> + (forall s (u : Instance.t), P (tConst s u)) -> + (forall (i : inductive) (u : Instance.t), P (tInd i u)) -> + (forall (i : inductive) (n : nat) (u : Instance.t), P (tConstruct i n u)) -> (forall (ci : case_info) (p : PCUICAst.predicate term) (c : term) (brs : list (branch term)), tCasePredProp P P p -> P c -> tCaseBrsProp P brs -> P (tCase ci p c brs)) -> diff --git a/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v b/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v index 5065e6250..2a2debca5 100644 --- a/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v +++ b/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v @@ -398,7 +398,7 @@ Proof using Type. + now rewrite subst_instance_prim_val_tag. + destruct p as [? []]; depelim X1; constructor; eauto. * rewrite -subst_instance_universe_make. eapply wf_universe_subst_instance => //. - * cbn -[Universe.make'] in hty. + * cbn -[Universe.of_level] in hty. specialize (hty u univs). rewrite /subst_instance subst_instance_universe_make in hty. now eapply hty. * cbn. solve_all. diff --git a/pcuic/theories/utils/PCUICPrimitive.v b/pcuic/theories/utils/PCUICPrimitive.v index 8f032badf..871f0edf7 100644 --- a/pcuic/theories/utils/PCUICPrimitive.v +++ b/pcuic/theories/utils/PCUICPrimitive.v @@ -7,7 +7,7 @@ From Stdlib Require Import ssreflect. From Stdlib Require Import Uint63 SpecFloat. Record array_model {term : Type} := - { array_level : Level.t; + { array_universe : Universe.t; array_type : term; array_default : term; array_value : list term }. @@ -87,8 +87,8 @@ Instance reflect_eq_spec_float : ReflectEq SpecFloat.spec_float := EqDec_Reflect Import ReflectEq. -Definition eqb_array {term} {equ : Level.t -> Level.t -> bool} {eqt : term -> term -> bool} (x y : array_model term) : bool := - equ x.(array_level) y.(array_level) && +Definition eqb_array {term} {equ : Universe.t -> Universe.t -> bool} {eqt : term -> term -> bool} (x y : array_model term) : bool := + equ x.(array_universe) y.(array_universe) && forallb2 eqt x.(array_value) y.(array_value) && eqt x.(array_default) y.(array_default) && eqt x.(array_type) y.(array_type). @@ -119,7 +119,7 @@ Next Obligation. - intros Heq%PString.compare_eq. rewrite Heq in Hcmp. inversion Hcmp. Qed. -Equations eqb_prim_model {term} {equ : Level.t -> Level.t -> bool} {req : term -> term -> bool} {t : prim_tag} (x y : prim_model term t) : bool := +Equations eqb_prim_model {term} {equ : Universe.t -> Universe.t -> bool} {req : term -> term -> bool} {t : prim_tag} (x y : prim_model term t) : bool := | primIntModel x, primIntModel y := ReflectEq.eqb x y | primFloatModel x, primFloatModel y := ReflectEq.eqb x y | primStringModel x, primStringModel y := ReflectEq.eqb x y @@ -140,7 +140,7 @@ Qed. #[global] Instance prim_model_eqdec {term} {req : ReflectEq term} : forall p : prim_tag, EqDec (prim_model term p) := _. -Equations eqb_prim_val {term} {equ : Level.t -> Level.t -> bool} {req : term -> term -> bool} (x y : prim_val term) : bool := +Equations eqb_prim_val {term} {equ : Universe.t -> Universe.t -> bool} {req : term -> term -> bool} (x y : prim_val term) : bool := | (primInt; i), (primInt; i') := eqb_prim_model (equ := equ) (req := req) i i' | (primFloat; f), (primFloat; f') := eqb_prim_model (equ := equ) (req := req) f f' | (primString; s), (primString; s') := eqb_prim_model (equ := equ) (req := req) s s' @@ -194,7 +194,7 @@ Inductive onPrims {term} (eq_term : term -> term -> Type) Re : prim_val term -> | onPrimsFloat f : onPrims eq_term Re (primFloat; primFloatModel f) (primFloat; primFloatModel f) | onPrimsString s : onPrims eq_term Re (primString; primStringModel s) (primString; primStringModel s) | onPrimsArray a a' : - Re (Universe.make' a.(array_level)) (Universe.make' a'.(array_level)) -> + Re a.(array_universe) a'.(array_universe) -> eq_term a.(array_default) a'.(array_default) -> eq_term a.(array_type) a'.(array_type) -> All2 eq_term a.(array_value) a'.(array_value) -> @@ -215,7 +215,7 @@ Inductive onPrims_dep {term} (eq_term : term -> term -> Type) (Re : Universe.t - | onPrimsFloat_dep f : onPrims_dep eq_term Re eq_term_dep Re' (primFloat; primFloatModel f) (primFloat; primFloatModel f) (onPrimsFloat _ _ f) | onPrimsString_dep s : onPrims_dep eq_term Re eq_term_dep Re' (primString; primStringModel s) (primString; primStringModel s) (onPrimsString _ _ s) | onPrimsArray_dep a a' : - forall (hre : Re (Universe.make' a.(array_level)) (Universe.make' a'.(array_level))) + forall (hre : Re a.(array_universe) a'.(array_universe)) (eqdef : eq_term a.(array_default) a'.(array_default)) (eqty : eq_term a.(array_type) a'.(array_type)) (eqt : All2 eq_term a.(array_value) a'.(array_value)), @@ -229,14 +229,14 @@ Derive Signature for onPrims_dep. Set Equations Transparent. -Definition mapu_array_model {term term'} (fl : Level.t -> Level.t) (f : term -> term') +Definition mapu_array_model {term term'} (fl : Universe.t -> Universe.t) (f : term -> term') (ar : array_model term) : array_model term' := - {| array_level := fl ar.(array_level); + {| array_universe := fl ar.(array_universe); array_value := map f ar.(array_value); array_default := f ar.(array_default); array_type := f ar.(array_type) |}. -Equations mapu_prim {term term'} (f : Level.t -> Level.t) (g : term -> term') +Equations mapu_prim {term term'} (f : Universe.t -> Universe.t) (g : term -> term') (p : PCUICPrimitive.prim_val term) : PCUICPrimitive.prim_val term' := | _, _, (primInt; primIntModel i) => (primInt; primIntModel i) | _, _, (primFloat; primFloatModel fl) => (primFloat; primFloatModel fl) @@ -254,12 +254,12 @@ Equations test_prim {term} (p : term -> bool) (p : prim_val term) : bool := | p, (primArray; primArrayModel ar) => List.forallb p ar.(array_value) && p ar.(array_default) && p ar.(array_type). -Equations test_primu {term} (p : Level.t -> bool) (t : term -> bool) (p : prim_val term) : bool := +Equations test_primu {term} (p : Universe.t -> bool) (t : term -> bool) (p : prim_val term) : bool := | _, _, (primInt; _) => true | _, _, (primFloat; _) => true | _, _, (primString; _) => true | p, pt, (primArray; primArrayModel ar) => - p ar.(array_level) && forallb pt ar.(array_value) && + p ar.(array_universe) && forallb pt ar.(array_value) && pt ar.(array_default) && pt ar.(array_type). Lemma onPrims_map_prop {term term'} R R' Re p p' P f : @tPrimProp term P p -> diff --git a/safechecker/theories/PCUICEqualityDec.v b/safechecker/theories/PCUICEqualityDec.v index e7e171dd8..fbb6e1f0e 100644 --- a/safechecker/theories/PCUICEqualityDec.v +++ b/safechecker/theories/PCUICEqualityDec.v @@ -18,7 +18,7 @@ Set Default Goal Selector "!". Lemma consistent_instance_wf_sort `{checker_flags} Σ uctx u : consistent_instance_ext Σ uctx u -> - Forall (wf_universe Σ) (map Universe.make' u). + Forall (wf_universe Σ) (map Universe.of_level u). Proof. move => /consistent_instance_ext_wf /wf_instanceP. rewrite -wf_universeb_instance_forall. @@ -42,12 +42,12 @@ Qed. Definition compare_universe_variance (cmpu : conv_pb -> Universe.t -> Universe.t -> bool) pb v u u' := match v with | Variance.Irrelevant => true - | Variance.Covariant => cmpu pb (Universe.make' u) (Universe.make' u') - | Variance.Invariant => cmpu Conv (Universe.make' u) (Universe.make' u') + | Variance.Covariant => cmpu pb (Universe.of_level u) (Universe.of_level u') + | Variance.Invariant => cmpu Conv (Universe.of_level u) (Universe.of_level u') end. Definition compare_universe_instance equ u u' := - forallb2 (fun u u' => equ (Universe.make' u) (Universe.make' u')) u u'. + forallb2 (fun u u' => equ (Universe.of_level u) (Universe.of_level u')) u u'. Definition compare_universe_instance_variance cmpu pb v u u' := forallb3 (compare_universe_variance cmpu pb) v u u'. @@ -190,8 +190,8 @@ Qed. Lemma reflect_cmp_universe_instance (p : Universe.t -> bool) cmpu cmp_universe ui ui' : (forall u u', p u -> p u' -> reflect (cmp_universe u u') (cmpu u u')) -> - forallb p (map Universe.make' ui) -> - forallb p (map Universe.make' ui') -> + forallb p (map Universe.of_level ui) -> + forallb p (map Universe.of_level ui') -> reflect (cmp_universe_instance cmp_universe ui ui') (compare_universe_instance cmpu ui ui'). Proof. intros he hui hui'. @@ -205,8 +205,8 @@ Qed. Lemma reflect_cmp_universe_instance_variance (p : Universe.t -> bool) cmpu cmp_universe pb v ui ui' : (forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) -> (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> - forallb p (map Universe.make' ui) -> - forallb p (map Universe.make' ui') -> + forallb p (map Universe.of_level ui) -> + forallb p (map Universe.of_level ui') -> reflect (cmp_universe_instance_variance cmp_universe pb v ui ui') (compare_universe_instance_variance cmpu pb v ui ui'). Proof. intros he hle hui hui'. @@ -230,8 +230,8 @@ Qed. Lemma reflect_cmp_global_instance' lookup (p : Universe.t -> bool) cmpu cmp_universe pb gr napp ui ui' : (forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) -> (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> - forallb p (map Universe.make' ui) -> - forallb p (map Universe.make' ui') -> + forallb p (map Universe.of_level ui) -> + forallb p (map Universe.of_level ui') -> reflect (cmp_global_instance_gen lookup cmp_universe pb gr napp ui ui') (compare_global_instance lookup cmpu pb gr napp ui ui'). Proof. @@ -253,8 +253,8 @@ Lemma reflect_cmp_global_instance Σ lookup (p : Universe.t -> bool) cmpu cmp_un (forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) -> (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> (forall kn, lookup_env Σ kn = lookup kn) -> - forallb p (map Universe.make' ui) -> - forallb p (map Universe.make' ui') -> + forallb p (map Universe.of_level ui) -> + forallb p (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (compare_global_instance lookup cmpu pb gr napp ui ui'). Proof. @@ -456,8 +456,8 @@ Lemma reflect_eq_term_upto_univ Σ (p : Universe.t -> bool) (q : nat -> term -> (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> (forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort Conv s s') (cmps Conv s s')) -> (forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort pb s s') (cmps pb s s')) -> - (forall gr napp ui ui', forallb p (map Universe.make' ui) -> forallb p (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> - (forall gr napp ui ui', forallb p (map Universe.make' ui) -> forallb p (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> + (forall gr napp ui ui', forallb p (map Universe.of_level ui) -> forallb p (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> + (forall gr napp ui ui', forallb p (map Universe.of_level ui) -> forallb p (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> forall t t', on_universes p q t -> on_universes p q t' -> @@ -537,8 +537,8 @@ Lemma eqb_term_upto_univ_impl Σ (p : Universe.t -> bool) (q : nat -> term -> bo (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> (forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort Conv s s') (cmps Conv s s')) -> (forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort pb s s') (cmps pb s s')) -> - (forall gr napp ui ui', forallb p (map Universe.make' ui) -> forallb p (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> - (forall gr napp ui ui', forallb p (map Universe.make' ui) -> forallb p (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> + (forall gr napp ui ui', forallb p (map Universe.of_level ui) -> forallb p (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> + (forall gr napp ui ui', forallb p (map Universe.of_level ui) -> forallb p (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> forall t t', on_universes p q t -> on_universes p q t' -> eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance pb napp t t' -> eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t t'. @@ -624,7 +624,7 @@ Qed. Lemma cmp_universe_instance_refl_wf Σ (cmp_universe : Universe.t -> Universe.t -> Prop) l : (forall u, wf_universe Σ u -> cmp_universe u u) -> - forallb (wf_universeb Σ) (map Universe.make' l) -> + forallb (wf_universeb Σ) (map Universe.of_level l) -> cmp_universe_instance cmp_universe l l. Proof. intros rRE Hl. @@ -635,7 +635,7 @@ Qed. Lemma cmp_global_instance_refl_wf Σ (cmp_universe : conv_pb -> Universe.t -> Universe.t -> Prop) gr pb napp l : (forall u, wf_universe Σ u -> cmp_universe Conv u u) -> - forallb (wf_universeb Σ) (map Universe.make' l) -> + forallb (wf_universeb Σ) (map Universe.of_level l) -> cmp_global_instance Σ cmp_universe pb gr napp l l. Proof. intros rRE Hl. @@ -675,7 +675,7 @@ Proof. - eapply forallb_All in wt; eapply All_mix in X; try apply wt; clear wt. eapply All_All2; eauto; simpl; intuition eauto; apply andb_and in a as [? ?]; eauto. - - destruct p as [? []]; cbn -[Universe.make'] in X, wt; rtoProp; intuition eauto; constructor; eauto. + - destruct p as [? []]; cbn -[Universe.of_level] in X, wt; rtoProp; intuition eauto; constructor; eauto. + eapply hU. now move/wf_universe_reflect: H. + solve_all. eapply All_All2; eauto; simpl; intuition eauto. Defined. @@ -684,8 +684,8 @@ Lemma eqb_term_upto_univ_refl Σ (cmpu : forall _ _ _, bool) (cmps : forall _ _ (forall u, wf_universe Σ u -> cmpu Conv u u) -> (forall s, wf_sort Σ s -> cmps Conv s s) -> (forall s, wf_sort Σ s -> cmps pb s s) -> - (forall gr napp ui ui', forallb (wf_universeb Σ) (map Universe.make' ui) -> forallb (wf_universeb Σ) (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmpu Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> - (forall gr napp ui ui', forallb (wf_universeb Σ) (map Universe.make' ui) -> forallb (wf_universeb Σ) (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmpu pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> + (forall gr napp ui ui', forallb (wf_universeb Σ) (map Universe.of_level ui) -> forallb (wf_universeb Σ) (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmpu Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> + (forall gr napp ui ui', forallb (wf_universeb Σ) (map Universe.of_level ui) -> forallb (wf_universeb Σ) (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmpu pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> wf_universes Σ t -> eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance pb napp t t. Proof. @@ -726,8 +726,8 @@ Section reflectContext. (hu' : forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) (hs : forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort Conv s s') (cmps Conv s s')) (hs' : forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort pb s s') (cmps pb s s')) - (hglobal : forall gr napp ui ui', forallb p (map Universe.make' ui) -> forallb p (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) - (hglobal' : forall gr napp ui ui', forallb p (map Universe.make' ui) -> forallb p (map Universe.make' ui') -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')). + (hglobal : forall gr napp ui ui', forallb p (map Universe.of_level ui) -> forallb p (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) + (hglobal' : forall gr napp ui ui', forallb p (map Universe.of_level ui) -> forallb p (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')). Lemma reflect_eqb_decl_gen : forall d d', diff --git a/safechecker/theories/PCUICSafeConversion.v b/safechecker/theories/PCUICSafeConversion.v index 558b35f8c..a6b23f728 100644 --- a/safechecker/theories/PCUICSafeConversion.v +++ b/safechecker/theories/PCUICSafeConversion.v @@ -1351,8 +1351,8 @@ Section Conversion. Lemma eqb_universe_instance_spec : forall u v Σ (wfΣ : abstract_env_ext_rel X Σ), - forallb (wf_universeb Σ) (map Universe.make' u) -> - forallb (wf_universeb Σ) (map Universe.make' v) -> + forallb (wf_universeb Σ) (map Universe.of_level u) -> + forallb (wf_universeb Σ) (map Universe.of_level v) -> eqb_universe_instance u v -> cmp_universe_instance (eq_universe (global_ext_constraints Σ)) u v. Proof using Type. @@ -1385,8 +1385,8 @@ Qed. Lemma compare_universeb_make_complete Σ (wfΣ : abstract_env_ext_rel X Σ) pb x y : wf_level Σ x -> wf_level Σ y -> - compare_universe (global_ext_constraints Σ) pb (Universe.make' x) (Universe.make' y) -> - abstract_env_compare_universe X pb (Universe.make' x) (Universe.make' y). + compare_universe (global_ext_constraints Σ) pb (Universe.of_level x) (Universe.of_level y) -> + abstract_env_compare_universe X pb (Universe.of_level x) (Universe.of_level y). Proof using Type. intros wfx wfy r. eapply compare_universeb_complete; eauto. @@ -3040,8 +3040,8 @@ Qed. (hp : ∥ ws_cumul_pb_terms Σ (Γ,,, stack_context π) (pparams p) (pparams p') ∥) : ∥ ∑ mdecl idecl, [× declared_inductive Σ ci mdecl idecl, - forallb (wf_universeb Σ) (map Universe.make' (puinst p)), - forallb (wf_universeb Σ) (map Universe.make' (puinst p')), + forallb (wf_universeb Σ) (map Universe.of_level (puinst p)), + forallb (wf_universeb Σ) (map Universe.of_level (puinst p')), #|pparams p| = ind_npars mdecl, #|pparams p'| = ind_npars mdecl, eq_context_upto_names p.(pcontext) p'.(pcontext), @@ -3590,7 +3590,7 @@ Equations (noeqns) isconv_array_values_aux { | @exist true eqf := yes | @exist false neqf := no (DistinctPrimValues (Γ ,,, stack_context π1) p (Γ ,,, stack_context π2) p') } | (primArray; primArrayModel a) | (primArray; primArrayModel a') - with inspect (abstract_env_compare_universe X Conv (Universe.make' (array_level a)) (Universe.make' (array_level a'))) := + with inspect (abstract_env_compare_universe X Conv (Universe.of_level (array_level a)) (Universe.of_level (array_level a'))) := { | @exist false neql := no (ArrayNotConvertibleLevels (Γ ,,, stack_context π1) a (Γ ,,, stack_context π2) a') | @exist true eql with isconv_red_raw Conv (array_type a) (PrimArray_ty a.(array_level) a.(array_value) a.(array_default) :: π1) (array_type a') (PrimArray_ty a'.(array_level) a'.(array_value) a'.(array_default) :: π2) aux := { @@ -6225,8 +6225,8 @@ match declarations := [] |}, Monomorphic_ctx); referenced_impl_ext_wf := TODO "foo" - |} [] Cumul (tSort (Universe.lType (Universe.make' (Level.lzero, 0)))) - (TODO "") (tSort (Universe.lType (Universe.make' (Level.lzero, 0)))) + |} [] Cumul (tSort (Universe.lType (Universe.of_level (Level.lzero, 0)))) + (TODO "") (tSort (Universe.lType (Universe.of_level (Level.lzero, 0)))) (TODO "") with | ConvSuccess => "success" diff --git a/safechecker/theories/PCUICTypeChecker.v b/safechecker/theories/PCUICTypeChecker.v index 6a1338403..eb84e1f4d 100644 --- a/safechecker/theories/PCUICTypeChecker.v +++ b/safechecker/theories/PCUICTypeChecker.v @@ -1390,7 +1390,7 @@ Section Typecheck. check_eq_true (eqb decl.(cst_type) (tSort Sort.type0)) (Msg "primitive type for strings is registered to an axiom whose type is not the sort Set") ;; ret _ | primArray | decl := - let s := sType (Universe.make' (Level.lvar 0)) in + let s := sType (Universe.of_level (Level.lvar 0)) in check_eq_true (eqb decl.(cst_body) None) (Msg "primitive type is registered to a defined constant") ;; check_eq_true (eqb decl.(cst_universes) (Polymorphic_ctx array_uctx)) (Msg "primitive type is registered to a monomorphic constant") ;; check_eq_true (eqb decl.(cst_type) (tImpl (tSort s) (tSort s))) (Msg "primitive type for arrays is registered to an axiom whose type is not of shape Type -> Type") ;; @@ -1427,8 +1427,8 @@ Section Typecheck. | (primFloat; primFloatModel f) := ret _ | (primString; primStringModel f) := ret _ | (primArray; primArrayModel a) := - check_eq_true (abstract_env_ext_wf_universeb X (Universe.make' a.(array_level))) (Msg "primitive array level is not well-formed") ;; - check_type <- bdcheck infer Γ wfΓ a.(array_type) (tSort (sType (Universe.make' a.(array_level)))) _ ;; + check_eq_true (abstract_env_ext_wf_universeb X (Universe.of_level a.(array_level))) (Msg "primitive array level is not well-formed") ;; + check_type <- bdcheck infer Γ wfΓ a.(array_type) (tSort (sType (Universe.of_level a.(array_level)))) _ ;; check_default <- bdcheck infer Γ wfΓ a.(array_default) a.(array_type) _ ;; check_values <- make_All (fun x => bdcheck infer Γ wfΓ x a.(array_type) _) a.(array_value) ;; ret _. @@ -1453,7 +1453,7 @@ Section Typecheck. now move/@wf_universe_reflect: i. - specialize (check_type _ wfΣ) as []. specialize (check_default _ wfΣ) as []. - assert (∥ Σ;;; Γ |- array_type a : tSort (sType (Universe.make' (array_level a))) ∥) as []. + assert (∥ Σ;;; Γ |- array_type a : tSort (sType (Universe.of_level (array_level a))) ∥) as []. { sq. eapply checking_typing in X0; eauto. erewrite <- abstract_env_ext_wf_universeb_correct in i; tea. eapply has_sort_isType; eapply type_Sort; eauto. now move/@wf_universe_reflect: i. } diff --git a/template-rocq/_PluginProject.in b/template-rocq/_PluginProject.in index 99313f3c6..ea2789276 100644 --- a/template-rocq/_PluginProject.in +++ b/template-rocq/_PluginProject.in @@ -122,6 +122,8 @@ gen-src/logic1.ml gen-src/logic1.mli gen-src/logic2.ml gen-src/logic2.mli +gen-src/mRClasses.mli +gen-src/mRClasses.ml gen-src/mRCompare.ml gen-src/mRCompare.mli gen-src/mRFSets.ml @@ -156,6 +158,8 @@ gen-src/mSetInterface.ml gen-src/mSetInterface.mli gen-src/mSetProperties.ml gen-src/mSetProperties.mli +gen-src/mRInstances.mli +gen-src/mRInstances.ml gen-src/monad_utils.ml gen-src/monad_utils.mli gen-src/nat0.ml @@ -233,6 +237,13 @@ gen-src/typing0.ml gen-src/typing0.mli gen-src/uint63Axioms.ml gen-src/uint63Axioms.mli + +gen-src/semiLattice.mli +gen-src/semiLattice.ml +gen-src/univConstraintType.mli +gen-src/univConstraintType.ml +gen-src/nonEmptyLevelExprSet.mli +gen-src/nonEmptyLevelExprSet.ml gen-src/universes0.ml gen-src/universes0.mli gen-src/wf.ml diff --git a/template-rocq/src/constr_quoter.ml b/template-rocq/src/constr_quoter.ml index aab8d1d31..2bdb8b79e 100644 --- a/template-rocq/src/constr_quoter.ml +++ b/template-rocq/src/constr_quoter.ml @@ -205,9 +205,11 @@ struct | Some x -> constr_mkApp (tLevelVar, [| quote_int x |]) | None -> constr_mkApp (tLevel, [| string_of_level l |]) + let of_level l = constr_mkApp (tof_level, [| l |]) + let quote_universe s = match Univ.Universe.level s with - Some l -> constr_mkApp (tof_level, [| quote_level l |]) + Some l -> of_level (quote_level l) | _ -> let levels = List.map (fun (l,i) -> pairl tlevel tnat (quote_level l) (quote_int i)) (Universe.repr s) in let hd = List.hd levels in let tl = to_coq_list (prodl tlevel tnat) (List.tl levels) in @@ -220,15 +222,16 @@ struct let quote_constraint_type (c : Univ.constraint_type) = match c with - | Lt -> Lazy.force tunivLt - | Le -> Lazy.force tunivLe0 + | Lt -> Lazy.force tunivLe (* BEWARE: this is fixed in quote_univ_constraint *) + | Le -> Lazy.force tunivLe | Eq -> Lazy.force tunivEq let quote_univ_constraint ((l1, ct, l2) : Univ.univ_constraint) = let l1 = quote_level l1 in let l2 = quote_level l2 in + let u1 = if ct == Lt then constr_mkApp (tsucc, [| of_level l1 |]) else of_level l1 in let ct = quote_constraint_type ct in - constr_mkApp (tmake_univ_constraint, [| l1; ct; l2 |]) + constr_mkApp (tmake_univ_constraint, [| u1; ct; of_level l2 |]) let quote_univ_level u = quote_level u (* todo : can be deduced from quote_level, hence shoud be in the Reify module *) @@ -333,7 +336,7 @@ struct let inst' = quote_univ_instance UVars.Instance.empty in let const' = quote_univ_constraints (fst (UGraph.constraints_of_universes g)) in let uctx = constr_mkApp (tUContextmake, [|inst' ; const'|]) in - constr_mkApp (tadd_global_constraints, [|constr_mkApp (cMonomorphic_ctx, [| uctx |]); Lazy.force tinit_graph|]) + constr_mkApp (tadd_global_constraints, [|Lazy.force tinit_graph; constr_mkApp (cMonomorphic_ctx, [| uctx |])|]) let sprop = diff --git a/template-rocq/src/constr_reification.ml b/template-rocq/src/constr_reification.ml index 5cd3f26fe..7dba024f2 100644 --- a/template-rocq/src/constr_reification.ml +++ b/template-rocq/src/constr_reification.ml @@ -172,14 +172,13 @@ struct let tLevel = ast "level.Level" let tLevelVar = ast "level.Var" let tunivLe = ast "constraints.Le" - let tunivLe0 = ast "constraints.Le0" - let tunivLt = ast "constraints.Lt" let tunivEq = ast "constraints.Eq" let tMktLevelExprSet = ast "levelexprset.mkt" let tBuild_Universe = ast "universe.build0" let tfrom_kernel_repr = ast "universe.from_kernel_repr" (* let tto_kernel_repr = ast "universe.to_kernel_repr" *) let tof_level = ast "universe.make_of_level" + let tsucc = ast "universe.succ" let tLevelSet_of_list = ast "universe.of_list" let noprop_tSet = ast "noproplevel.lzero" let noprop_tLevel = ast "noproplevel.Level" diff --git a/template-rocq/src/g_template_rocq.ml b/template-rocq/src/g_template_rocq.ml new file mode 100644 index 000000000..a9187abbd --- /dev/null +++ b/template-rocq/src/g_template_rocq.ml @@ -0,0 +1,360 @@ +let _ = Mltop.add_known_module "rocq-metarocq-template-rocq.plugin" + +# 4 "src/g_template_rocq.mlg" + + +open Attributes +open Ltac_plugin +open Names + +(** Calling Ltac **) + +let ltac_lcall tac args = + let (location, name) = Loc.tag (Names.Id.of_string tac) + (* Loc.tag @@ Names.Id.of_string tac *) + in + CAst.make ?loc:location (Tacexpr.TacArg(Tacexpr.TacCall + (CAst.make (Locus.ArgVar (CAst.make ?loc:location name),args)))) + +open Tacexpr +open Tacinterp +open Stdarg +open Tacarg +open Redexpr + +(* If strict unquote universe mode is on then fail when unquoting a non *) +(* declared universe / an empty list of level expressions. *) +(* Otherwise, add it / a fresh level the global environnment. *) + +let _ = + let open Goptions in + declare_bool_option + { optdepr = None; + optstage = Interp; + optkey = ["MetaRocq"; "Strict"; "Unquote"; "Universe"; "Mode"]; + optread = (fun () -> !Denoter.strict_unquote_universe_mode); + optwrite = (fun b -> Denoter.strict_unquote_universe_mode := b) } + +let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) = + let fold arg (i, vars, lfun) = + let id = Names.Id.of_string ("x" ^ string_of_int i) in + let (l,n) = (Loc.tag id) in + let x = Reference (Locus.ArgVar (CAst.make ?loc:l n)) in + (succ i, x :: vars, Id.Map.add id arg lfun) + in + let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in + let lfun = Id.Map.add (Id.of_string "F") f lfun in + let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in + Tacinterp.eval_tactic_ist ist (ltac_lcall "F" args) + +let to_ltac_val c = Tacinterp.Value.of_constr c + +let run_template_program ~pm env evm ~poly pgm = + Run_template_monad.run_template_program_rec ~poly (fun ~st _ _ _ -> st) ~st:pm env (evm, pgm) + +let fresh_env () = + let env = Global.env () in + let sigma = Evd.from_env env in + env, sigma + +let to_constr_evars sigma c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c + + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Test_Quote" ~classifier:(fun _ -> Vernacextend.classify_as_query) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Test", + Vernacextend.TyTerminal + ("Quote", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil)))), + (let coqpp_body def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 67 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (evm, def) = Constrintern.interp_open_constr env evm def in + let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmTestQuote) in + let pgm = Constr.mkApp (EConstr.to_constr evm pgm, + [|Constr.mkRel 0; to_constr_evars evm def|]) in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun def ?loc ~atts () -> + coqpp_body def (Attributes.parse +# 66 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Quote", + Vernacextend.TyTerminal + ("Definition", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), + Vernacextend.TyTerminal + (":=", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil)))))), + (let coqpp_body name def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 77 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (evm, def) = Constrintern.interp_open_constr env evm def in + let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteDefinition) in + let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; + to_constr_evars evm def|]) in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun name def ?loc ~atts () -> + coqpp_body name def (Attributes.parse +# 76 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Definition_Eval" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Quote", + Vernacextend.TyTerminal + ("Definition", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), + Vernacextend.TyTerminal + (":=", + Vernacextend.TyTerminal + ("Eval", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_red_expr), + Vernacextend.TyTerminal + ("in", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil))))))))), + (let coqpp_body name rd def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 87 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (evm, def) = Constrintern.interp_open_constr env evm def in + (* TODO : implem quoting of tactic reductions so that we can use ptmQuoteDefinitionRed *) + let (evm, rd) = Redexpr.interp_redexp_no_ltac env evm rd in + let (evm, def) = Plugin_core.reduce env evm rd (to_constr_evars evm def) in + let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteDefinition) in + let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; def|]) in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun name rd def ?loc ~atts () -> + coqpp_body name rd def (Attributes.parse +# 86 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Recursively_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Quote", + Vernacextend.TyTerminal + ("Recursively", + Vernacextend.TyTerminal + ("Definition", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), + Vernacextend.TyTerminal + (":=", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil))))))), + (let coqpp_body name def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 99 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (evm, def) = Constrintern.interp_open_constr env evm def in + let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteRecDefinition) in + let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; + to_constr_evars evm def|]) in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun name def ?loc ~atts () -> + coqpp_body name def (Attributes.parse +# 98 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Test_Unquote" ~classifier:(fun _ -> Vernacextend.classify_as_query) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Test", + Vernacextend.TyTerminal + ("Unquote", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil)))), + (let coqpp_body def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 109 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (evm, def) = Constrintern.interp_open_constr env evm def in + let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmTestUnquote) in + let pgm = Constr.mkApp (EConstr.to_constr evm pgm, + [|to_constr_evars evm def|]) in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun def ?loc ~atts () -> + coqpp_body def (Attributes.parse +# 108 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Make_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Unquote", + Vernacextend.TyTerminal + ("Definition", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), + Vernacextend.TyTerminal + (":=", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil)))))), + (let coqpp_body name def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 119 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (evm, def) = Constrintern.interp_open_constr env evm def in + let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmMkDefinition) in + let pgm = Constr.mkApp (EConstr.to_constr evm pgm, + [|Constr_quoter.quote_ident name; + to_constr_evars evm def|]) in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun name def ?loc ~atts () -> + coqpp_body name def (Attributes.parse +# 118 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Make_Inductive" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Unquote", + Vernacextend.TyTerminal + ("Inductive", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil)))), + (let coqpp_body def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 130 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (evm, def) = Constrintern.interp_open_constr env evm def in + let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmMkInductive) in + let pgm = Constr.mkApp (EConstr.to_constr evm pgm, + [|Constr_quoter.quote_bool false; to_constr_evars evm def|]) in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun def ?loc ~atts () -> + coqpp_body def (Attributes.parse +# 129 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Run_Template_Program" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Run", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil))), + (let coqpp_body def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 140 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (pgm, ctx) = Constrintern.interp_constr env evm def in + let evm = Evd.from_ctx ctx in + let pgm = EConstr.to_constr ~abort_on_undefined_evars:true evm pgm in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun def ?loc ~atts () -> + coqpp_body def (Attributes.parse +# 139 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_quote_term" ~level:0 + [(Tacentries.TyML (Tacentries.TyIdent ("quote_term", Tacentries.TyArg ( + Extend.TUentry (Genarg.get_arg_tag wit_constr), + Tacentries.TyArg ( + Extend.TUentry (Genarg.get_arg_tag wit_tactic), + Tacentries.TyNil))), + (fun c tac ist -> +# 152 "src/g_template_rocq.mlg" + (* quote the given term, pass the result to t *) + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let c = to_constr_evars sigma c in + let c = Constr_quoter.quote_term env sigma c in + ltac_apply tac (List.map to_ltac_val [EConstr.of_constr c]) + end + )))] + +let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_denote_term" ~level:0 + [(Tacentries.TyML (Tacentries.TyIdent ("denote_term", Tacentries.TyArg ( + Extend.TUentry (Genarg.get_arg_tag wit_constr), + Tacentries.TyArg ( + Extend.TUentry (Genarg.get_arg_tag wit_tactic), + Tacentries.TyNil))), + (fun c tac ist -> +# 164 "src/g_template_rocq.mlg" + Proofview.Goal.enter (begin fun gl -> + let env = Proofview.Goal.env gl in + let evm = Proofview.Goal.sigma gl in + let evm, c = Constr_denoter.denote_term env evm (to_constr_evars evm c) in + let evm, _ = Typing.type_of env evm (EConstr.of_constr c) in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) + (ltac_apply tac (List.map to_ltac_val [EConstr.of_constr c])) + end) + )))] + +let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_run_template_program" ~level:0 + [(Tacentries.TyML (Tacentries.TyIdent ("run_template_program", + Tacentries.TyArg (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Tacentries.TyArg (Extend.TUentry (Genarg.get_arg_tag wit_tactic), + Tacentries.TyNil))), (fun c tac ist -> +# 176 "src/g_template_rocq.mlg" + let open Proofview.Notations in + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (name, poly) -> + Proofview.Goal.enter (begin fun gl -> + let env = Proofview.Goal.env gl in + let evm = Proofview.Goal.sigma gl in + let ret = ref None in + (* We don't allow opening obligations / updating the vernacular inside proofs / as tactics *) + let pm = Declare.OblState.empty in + let _pm = Run_template_monad.run_template_program_rec + ~poly ~intactic:true ~st:pm (fun ~st env evm t -> ret := Some (env,evm,t); st) + env (evm, to_constr_evars evm c) + in + match !ret with + | Some (env, evm, t) -> + Proofview.tclTHEN + (Proofview.Unsafe.tclEVARS evm) + (ltac_apply tac (List.map to_ltac_val [EConstr.of_constr t])) + | None -> Proofview.tclUNIT () + end) + )))] + diff --git a/template-rocq/theories/Ast.v b/template-rocq/theories/Ast.v index cfdd95534..7a585b8d2 100644 --- a/template-rocq/theories/Ast.v +++ b/template-rocq/theories/Ast.v @@ -417,7 +417,7 @@ Inductive term : Type := | tInt (i : PrimInt63.int) | tFloat (f : PrimFloat.float) | tString (s : PrimString.string) -| tArray (u : Level.t) (arr : list term) (default : term) (type : term). +| tArray (u : Universe.t) (arr : list term) (default : term) (type : term). (** This can be used to represent holes, that, when unquoted, turn into fresh existential variables. The fresh evar will depend on the whole context at this point in the term, despite the empty instance. @@ -567,7 +567,7 @@ Fixpoint noccur_between k n (t : term) : bool := match c with | tRel _ | tVar _ => c | tInt _ | tFloat _ | tString _ => c - | tArray u' arr def ty => tArray (subst_instance_level u u') (List.map (subst_instance_constr u) arr) + | tArray u' arr def ty => tArray (subst_instance_universe u u') (List.map (subst_instance_constr u) arr) (subst_instance_constr u def) (subst_instance_constr u ty) | tEvar ev args => tEvar ev (List.map (subst_instance_constr u) args) | tSort s => tSort (subst_instance_sort u s) @@ -616,7 +616,7 @@ Fixpoint closedu (k : nat) (t : term) : bool := | tCoFix mfix idx => forallb (test_def (closedu k) (closedu k)) mfix | tArray u arr def ty => - closedu_level k u && forallb (closedu k) arr && closedu k def && closedu k ty + closedu_universe k u && forallb (closedu k) arr && closedu k def && closedu k ty | _ => true end. @@ -779,7 +779,7 @@ Qed. Definition ind_predicate_context ind mdecl idecl : context := let ictx := (expand_lets_ctx mdecl.(ind_params) idecl.(ind_indices)) in - let indty := mkApps (tInd ind (abstract_instance mdecl.(ind_universes))) + let indty := mkApps (tInd ind (Instance.of_level_instance (abstract_instance mdecl.(ind_universes)))) (to_extended_list (smash_context [] mdecl.(ind_params) ,,, ictx)) in let inddecl := {| decl_name := diff --git a/template-rocq/theories/AstUtils.v b/template-rocq/theories/AstUtils.v index dab13eeb7..764f2c8f6 100644 --- a/template-rocq/theories/AstUtils.v +++ b/template-rocq/theories/AstUtils.v @@ -71,7 +71,7 @@ Module string_of_term_tree. | tInt i => "Int(" ^ string_of_prim_int i ^ ")" | tFloat f => "Float(" ^ string_of_float f ^ ")" | tString s => "String(" ^ string_of_pstring s ^ ")" - | tArray u arr def ty => "Array(" ^ string_of_level u ^ "," ^ + | tArray u arr def ty => "Array(" ^ string_of_universe u ^ "," ^ string_of_list string_of_term arr ^ "," ^ string_of_term def ^ "," ^ string_of_term ty ^ ")" end. End string_of_term_tree. @@ -761,14 +761,14 @@ Section Lookups. | _ => None end. - Definition lookup_ind_type ind i (u : list Level.t) := + Definition lookup_ind_type ind i (u : Instance.t) := match lookup_ind_decl ind i with |None => None |Some res => Some (subst_instance u (snd res).(ind_type)) end. - Definition lookup_ind_type_cstrs ind i (u : list Level.t) := + Definition lookup_ind_type_cstrs ind i (u : Instance.t) := match lookup_ind_decl ind i with |None => None |Some res => diff --git a/template-rocq/theories/Checker.v b/template-rocq/theories/Checker.v index a54de87c5..abbc25558 100644 --- a/template-rocq/theories/Checker.v +++ b/template-rocq/theories/Checker.v @@ -128,11 +128,11 @@ Section Lookups. | _ => raise (UndeclaredInductive (mkInd ind i)) end. - Definition lookup_ind_type ind i (u : list Level.t) := + Definition lookup_ind_type ind i (u : Instance.t) := res <- lookup_ind_decl ind i ;; ret (subst_instance u (snd res).(ind_type)). - Definition lookup_ind_type_cstrs ind i (u : list Level.t) := + Definition lookup_ind_type_cstrs ind i (u : Instance.t) := res <- lookup_ind_decl ind i ;; let '(mib, body) := res in let uctx := mib.(ind_universes) in @@ -296,7 +296,7 @@ Inductive conv_pb := Definition eq_case_info (ci ci' : case_info) := eq_inductive ci.(ci_ind) ci'.(ci_ind) && Nat.eqb ci.(ci_npar) ci'.(ci_npar). (* FIXME relevance check *) -Fixpoint eq_term `{checker_flags} (φ : universes_graph) (t u : term) {struct t} := +Fixpoint eq_term `{checker_flags} (φ : universe_model) (t u : term) {struct t} := match t, u with | tRel n, tRel n' => Nat.eqb n n' | tEvar ev args, tEvar ev' args' => Nat.eqb ev ev' && forallb2 (eq_term φ) args args' @@ -328,7 +328,7 @@ Fixpoint eq_term `{checker_flags} (φ : universes_graph) (t u : term) {struct t} end. -Fixpoint leq_term `{checker_flags} (φ : universes_graph) (t u : term) {struct t} := +Fixpoint leq_term `{checker_flags} (φ : universe_model) (t u : term) {struct t} := match t, u with | tRel n, tRel n' => Nat.eqb n n' | tEvar ev args, tEvar ev' args' => Nat.eqb ev ev' && forallb2 (eq_term φ) args args' @@ -361,7 +361,7 @@ Fixpoint leq_term `{checker_flags} (φ : universes_graph) (t u : term) {struct t Section Conversion. Context `{checker_flags} (flags : RedFlags.t). - Context (Σ : global_env) (G : universes_graph). + Context (Σ : global_env) (G : universe_model). Definition nodelta_flags := RedFlags.mk true true true false true true. @@ -546,7 +546,7 @@ Definition check_conv `{checker_flags} {F:Fuel} := check_conv_gen Conv. Definition is_graph_of_global_env_ext `{checker_flags} Σ G := - is_graph_of_uctx G (global_ext_uctx Σ). + model_of_uctx G (global_ext_uctx Σ). Section Typecheck. Context {F : Fuel}. @@ -587,7 +587,7 @@ Section Typecheck. end. Definition reduce_to_ind Γ (t : term) : - typing_result (inductive * list Level.t * list term) := + typing_result (inductive * Instance.t * list term) := match decompose_app t with | (tInd i u, l) => ret (i, u, l) | _ => t' <- hnf_stack Γ t ;; @@ -600,7 +600,7 @@ End Typecheck. Section Typecheck. Context {cf : checker_flags} {F : Fuel}. - Context (Σ : global_env) (G : universes_graph). + Context (Σ : global_env) (G : universe_model). Definition convert_leq Γ (t u : term) : typing_result unit := if eq_term G t u then ret () @@ -821,12 +821,10 @@ Section Checker. else ret () end. - Definition add_gc_constraints ctrs (G : universes_graph) : universes_graph - := (G.1.1, GoodUnivConstraintSet.fold - (fun ctr => wGraph.EdgeSet.add (edge_of_constraint ctr)) ctrs G.1.2, - G.2). + Definition add_constraints ctrs (G : universe_model) : option universe_model + := push_uctx G (LevelSet.empty, ctrs). - Fixpoint check_wf_declarations (univs : ContextSet.t) (retro : Retroknowledge.t) (G : universes_graph) (g : global_declarations) + Fixpoint check_wf_declarations (univs : ContextSet.t) (retro : Retroknowledge.t) (G : universe_model) (g : global_declarations) : EnvCheck () := match g with | [] => ret tt @@ -840,16 +838,12 @@ Section Checker. Definition typecheck_program (p : program) : EnvCheck term := let Σ := fst p in let '(univs, decls, retro) := (Σ.(universes), Σ.(declarations), Σ.(retroknowledge)) in - match gc_of_constraints (snd univs) with + match push_uctx init_model univs with | None => EnvError (IllFormedDecl "toplevel" (UnsatisfiableConstraints univs.2)) - | Some ctrs => - let G := add_gc_constraints ctrs init_graph in - if wGraph.is_acyclic G then - check_wf_declarations univs retro G decls ;; - infer_term Σ G (snd p) - else EnvError (IllFormedDecl "toplevel" - (UnsatisfiableConstraints univs.2)) + | Some G => + check_wf_declarations univs retro G decls ;; + infer_term Σ G (snd p) end. End Checker. @@ -857,8 +851,8 @@ End Checker. (* for compatibility, will go away *) Definition infer' `{checker_flags} `{Fuel} (Σ : global_env_ext) Γ t := let uctx := (global_ext_uctx Σ) in - match gc_of_uctx uctx with + match push_uctx init_model uctx with | None => raise (UnsatisfiableConstraints uctx.2) - | Some uctx => infer (fst Σ) (make_graph uctx) Γ t + | Some m => infer (fst Σ) m Γ t end. diff --git a/template-rocq/theories/Constants.v b/template-rocq/theories/Constants.v index 28f18505e..50d956730 100644 --- a/template-rocq/theories/Constants.v +++ b/template-rocq/theories/Constants.v @@ -102,12 +102,11 @@ Register MetaRocq.Common.Universes.IntoPropSProp as metarocq.ast.IntoPropSProp. Register MetaRocq.Common.Universes.IntoSetPropSProp as metarocq.ast.IntoSetPropSProp. Register MetaRocq.Common.Universes.IntoAny as metarocq.ast.IntoAny. (* We convert from simple constraints to ones in Z *) -Register MetaRocq.Common.Universes.ConstraintType.Lt as metarocq.ast.constraints.Lt. -Register MetaRocq.Common.Universes.ConstraintType.Le0 as metarocq.ast.constraints.Le0. -Register MetaRocq.Common.Universes.ConstraintType.Le as metarocq.ast.constraints.Le. -Register MetaRocq.Common.Universes.ConstraintType.Eq as metarocq.ast.constraints.Eq. +Register MetaRocq.Common.UnivConstraintType.ConstraintType.Le as metarocq.ast.constraints.Le. +Register MetaRocq.Common.UnivConstraintType.ConstraintType.Eq as metarocq.ast.constraints.Eq. Register MetaRocq.Common.Universes.Universe.t as metarocq.ast.universe.t. -Register MetaRocq.Common.Universes.Universe.make' as metarocq.ast.universe.make_of_level. +Register MetaRocq.Common.Universes.Universe.of_level as metarocq.ast.universe.make_of_level. +Register MetaRocq.Common.Universes.Universe.succ as metarocq.ast.universe.succ. Register MetaRocq.Common.Universes.Universe.from_kernel_repr as metarocq.ast.universe.from_kernel_repr. Register MetaRocq.Common.Universes.LevelSetProp.of_list as metarocq.ast.universe.of_list. Register MetaRocq.Common.Universes.Level.t as metarocq.ast.level.t. @@ -119,7 +118,7 @@ Register MetaRocq.Common.Universes.Level.lzero as metarocq.ast.level.lzero. Register MetaRocq.Common.Universes.Level.lvar as metarocq.ast.level.Var. Register MetaRocq.Common.Universes.LevelExprSet.Mkt as metarocq.ast.levelexprset.mkt. -Register MetaRocq.Common.Universes.LevelExprSet.Build_nonEmptyLevelExprSet as metarocq.ast.universe.build0. +Register MetaRocq.Common.Universes.Universe.NES.Build_t as metarocq.ast.universe.build0. Register MetaRocq.Common.Universes.Sort.sSProp as metarocq.ast.sort.sprop. Register MetaRocq.Common.Universes.Sort.sProp as metarocq.ast.sort.prop. Register MetaRocq.Common.Universes.Sort.sType as metarocq.ast.sort.type. @@ -148,9 +147,9 @@ Register MetaRocq.Common.Universes.LevelSet.t_ as metarocq.ast.LevelSet.t. Register MetaRocq.Common.Universes.LevelSet.elements as metarocq.ast.LevelSet.elements. Register MetaRocq.Common.Universes.UnivConstraint.make as metarocq.ast.make_univ_constraint. -Register MetaRocq.Common.uGraph.init_graph as metarocq.ast.graph.init. +Register MetaRocq.Common.uGraph.init_model as metarocq.ast.graph.init. (* FIXME wrong! *) -Register MetaRocq.Common.uGraph.gc_of_constraints as metarocq.ast.graph.add_global_constraints. +Register MetaRocq.Common.uGraph.push_uctx as metarocq.ast.graph.add_global_constraints. (* Terms *) diff --git a/template-rocq/theories/Induction.v b/template-rocq/theories/Induction.v index d84179928..f1239ae2c 100644 --- a/template-rocq/theories/Induction.v +++ b/template-rocq/theories/Induction.v @@ -23,9 +23,9 @@ Lemma term_forall_list_ind : (forall (n : aname) (t : term), P t -> forall t0 : term, P t0 -> forall t1 : term, P t1 -> P (tLetIn n t t0 t1)) -> (forall t : term, P t -> forall l : list term, Forall P l -> P (tApp t l)) -> - (forall s (u : list Level.t), P (tConst s u)) -> - (forall (i : inductive) (u : list Level.t), P (tInd i u)) -> - (forall (i : inductive) (n : nat) (u : list Level.t), P (tConstruct i n u)) -> + (forall s (u : Instance.t), P (tConst s u)) -> + (forall (i : inductive) (u : Instance.t), P (tInd i u)) -> + (forall (i : inductive) (n : nat) (u : Instance.t), P (tConstruct i n u)) -> (forall (ci : case_info) (t : predicate term), tCasePredProp P P t -> forall t0 : term, P t0 -> forall l : list (branch term), tCaseBrsProp P l -> P (tCase ci t t0 l)) -> @@ -68,9 +68,9 @@ Lemma term_forall_list_rect : (forall (n : aname) (t : term), P t -> forall t0 : term, P t0 -> forall t1 : term, P t1 -> P (tLetIn n t t0 t1)) -> (forall t : term, P t -> forall l : list term, All P l -> P (tApp t l)) -> - (forall s (u : list Level.t), P (tConst s u)) -> - (forall (i : inductive) (u : list Level.t), P (tInd i u)) -> - (forall (i : inductive) (n : nat) (u : list Level.t), P (tConstruct i n u)) -> + (forall s (u : Instance.t), P (tConst s u)) -> + (forall (i : inductive) (u : Instance.t), P (tInd i u)) -> + (forall (i : inductive) (n : nat) (u : Instance.t), P (tConstruct i n u)) -> (forall (ci : case_info) (p0 : predicate term), tCasePredProp P P p0 -> forall t : term, P t -> forall l : list (branch term), tCaseBrsType P l -> P (tCase ci p0 t l)) -> diff --git a/template-rocq/theories/Lib.v b/template-rocq/theories/Lib.v index f6e81ed3a..6b90ee5a3 100644 --- a/template-rocq/theories/Lib.v +++ b/template-rocq/theories/Lib.v @@ -1,3 +1,4 @@ +(* Distributed under the terms of the MIT license. *) From MetaRocq.Common Require Import uGraph. From MetaRocq.Template Require Import Ast TemplateMonad Loader Checker. From MetaRocq.Utils Require Import utils. @@ -73,9 +74,10 @@ Notation "'$quote_def_rec' x" := (** * Useful shortcuts. *) -(** [term_eqb t1 t2] checks if [t1] and [t2] are equal modulo alpha equivalence. *) +(** [term_eqb t1 t2] checks if [t1] and [t2] are equal modulo alpha equivalence. + No universe constraints are taken into account. *) Definition term_eqb (t1 t2 : term) := - @eq_term config.default_checker_flags init_graph t1 t2. + @eq_term config.default_checker_flags init_model t1 t2. (** Short-form notation for [tLambda]. *) Notation tLam x A b := diff --git a/template-rocq/theories/Pretty.v b/template-rocq/theories/Pretty.v index 14aa9d63c..7c46e0bbd 100644 --- a/template-rocq/theories/Pretty.v +++ b/template-rocq/theories/Pretty.v @@ -253,7 +253,7 @@ Module PrintTermTree. | tInt i => "Int(" ^ string_of_prim_int i ^ ")" | tFloat f => "Float(" ^ string_of_float f ^ ")" | tString s => "Float(" ^ string_of_pstring s ^ ")" - | tArray u arr def ty => "Array(" ^ string_of_level u ^ "," ^ + | tArray u arr def ty => "Array(" ^ string_of_universe u ^ "," ^ string_of_list string_of_term arr ^ "," ^ string_of_term def ^ "," ^ string_of_term ty ^ ")" end. diff --git a/template-rocq/theories/TemplateMonad/Core.v b/template-rocq/theories/TemplateMonad/Core.v index a50ecdb28..74a4977d8 100644 --- a/template-rocq/theories/TemplateMonad/Core.v +++ b/template-rocq/theories/TemplateMonad/Core.v @@ -231,9 +231,9 @@ Definition tmFix@{a b t u} {A : Type@{a}} {B : Type@{b}} (f : (A -> TemplateMona := f (fun a => (qA <- tmQuote A;; qB <- tmQuote B;; - qa <- tmQuoteLevel@{a _ _};; - qb <- tmQuoteLevel@{b _ _};; - qt <- tmQuoteLevel@{t _ _};; - qu <- tmQuoteLevel@{u _ _};; + qa <- tmQuoteUniverse@{a _ _};; + qb <- tmQuoteUniverse@{b _ _};; + qt <- tmQuoteUniverse@{t _ _};; + qu <- tmQuoteUniverse@{u _ _};; let self := tConst (MPfile ["Core"; "TemplateMonad"; "Template"; "MetaRocq"], "tmFix'")%bs [qa;qb;qt;qu] in @tmFix'@{a b t u} A B (mkApps self [qA; qB]) f a)). diff --git a/template-rocq/theories/TermEquality.v b/template-rocq/theories/TermEquality.v index db376a7c6..562d2af87 100644 --- a/template-rocq/theories/TermEquality.v +++ b/template-rocq/theories/TermEquality.v @@ -10,7 +10,7 @@ From Equations Require Import Equations. Set Equations With UIP. Definition cmp_universe_instance (cmp_univ : Universe.t -> Universe.t -> Prop) : Instance.t -> Instance.t -> Prop := - Forall2 (on_rel cmp_univ Universe.make'). + Forall2 cmp_univ. (** Cumulative inductive types: @@ -22,8 +22,8 @@ Definition cmp_universe_instance (cmp_univ : Universe.t -> Universe.t -> Prop) : Definition cmp_universe_variance (cmp_univ : conv_pb -> Universe.t -> Universe.t -> Prop) pb v u u' := match v with | Variance.Irrelevant => True - | Variance.Covariant => on_rel (cmp_univ pb) Universe.make' u u' - | Variance.Invariant => on_rel (cmp_univ Conv) Universe.make' u u' + | Variance.Covariant => cmp_univ pb u u' + | Variance.Invariant => cmp_univ Conv u u' end. Definition cmp_universe_instance_variance cmp_univ pb v u u' := @@ -79,7 +79,7 @@ Qed. Lemma cmp_universe_universe_variance (cmp_univ : conv_pb -> Universe.t -> Universe.t -> Prop) pb v u u' : RelationClasses.subrelation (cmp_univ Conv) (cmp_univ pb) -> - on_rel (cmp_univ Conv) Universe.make' u u' -> cmp_universe_variance cmp_univ pb v u u'. + cmp_univ Conv u u' -> cmp_universe_variance cmp_univ pb v u u'. Proof. destruct v => //=. intros H H1; apply H, H1. diff --git a/template-rocq/theories/Typing.v b/template-rocq/theories/Typing.v index bc3b36370..fe260a9a8 100644 --- a/template-rocq/theories/Typing.v +++ b/template-rocq/theories/Typing.v @@ -29,7 +29,7 @@ Fixpoint isArity T := | _ => false end. -Definition type_of_constructor mdecl cdecl (c : inductive * nat) (u : list Level.t) := +Definition type_of_constructor mdecl cdecl (c : inductive * nat) (u : Instance.t) := let mind := inductive_mind (fst c) in subst0 (inds mind u mdecl.(ind_bodies)) (subst_instance u cdecl.(cstr_type)). @@ -893,7 +893,7 @@ Inductive typing `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> primitive_constant Σ primArray = Some prim_ty -> declared_constant Σ prim_ty cdecl -> primitive_invariants primArray cdecl -> - let s := sType (Universe.make' u) in + let s := sType u in Σ ;;; Γ |- ty : tSort s -> Σ ;;; Γ |- def : ty -> All (fun t => Σ ;;; Γ |- t : ty) arr -> @@ -1309,7 +1309,7 @@ Lemma typing_ind_env `{cf : checker_flags} : primitive_constant Σ primArray = Some prim_ty -> declared_constant Σ prim_ty cdecl -> primitive_invariants primArray cdecl -> - let s := sType (Universe.make' u) in + let s := sType u in Σ ;;; Γ |- ty : tSort s -> P Σ Γ ty (tSort s) -> Σ ;;; Γ |- def : ty -> diff --git a/template-rocq/theories/TypingWf.v b/template-rocq/theories/TypingWf.v index 896c9e9eb..38113e463 100644 --- a/template-rocq/theories/TypingWf.v +++ b/template-rocq/theories/TypingWf.v @@ -554,7 +554,7 @@ Section WfAst. Qed. Lemma declared_constructor_wf - (ind : inductive) (i : nat) (u : list Level.t) + (ind : inductive) (i : nat) (mdecl : mutual_inductive_body) (idecl : one_inductive_body) (cdecl : constructor_body) : on_global_env cumul_gen wf_decl_pred Σ -> declared_constructor Σ (ind, i) mdecl idecl cdecl -> diff --git a/template-rocq/theories/WfAst.v b/template-rocq/theories/WfAst.v index c86d9a28d..355a2b808 100644 --- a/template-rocq/theories/WfAst.v +++ b/template-rocq/theories/WfAst.v @@ -133,9 +133,9 @@ Lemma term_wf_forall_list_ind Σ : P t -> forall t0 : term, P t0 -> forall t1 : term, P t1 -> P (tLetIn n t t0 t1)) -> (forall t : term, isApp t = false -> wf Σ t -> P t -> forall l : list term, l <> nil -> All (wf Σ) l -> All P l -> P (tApp t l)) -> - (forall s (u : list Level.t), P (tConst s u)) -> - (forall (i : inductive) (u : list Level.t), P (tInd i u)) -> - (forall (i : inductive) (n : nat) (u : list Level.t), + (forall s (u : Instance.t), P (tConst s u)) -> + (forall (i : inductive) (u : Instance.t), P (tInd i u)) -> + (forall (i : inductive) (n : nat) (u : Instance.t), P (tConstruct i n u)) -> (forall (ci : case_info) (p : predicate term) mdecl idecl, declared_inductive Σ ci.(ci_ind) mdecl idecl -> diff --git a/test-suite/univ.v b/test-suite/univ.v index 61f5709f4..e155a2a34 100644 --- a/test-suite/univ.v +++ b/test-suite/univ.v @@ -17,7 +17,7 @@ MetaRocq Quote Definition a_random_univ := Type. Example a_random_univ_ex : exists l, a_random_univ = - tSort (sType (Universe.make' (Level.level l))). + tSort (sType (Universe.of_level (Level.level l))). Proof. eexists. reflexivity. Qed. (* Back and forth *) @@ -30,18 +30,18 @@ MetaRocq Unquote Definition univ_foo_back := univ_foo_syn. (* Print univ_foo_back. *) -Fail MetaRocq Unquote Definition t1 := (tSort (sType (Universe.make' (Level.level "Top.400")))). +Fail MetaRocq Unquote Definition t1 := (tSort (sType (Universe.of_level (Level.level "Top.400")))). (* Fails with "Level Top. not a declared level and you are in Strict Unquote Universe Mode." *) Unset MetaRocq Strict Unquote Universe Mode. MetaRocq Unquote Definition t2 := (tSort (sType fresh_universe)). -MetaRocq Unquote Definition t3 := (tSort (sType (Universe.make' (Level.level "Top.400")))). +MetaRocq Unquote Definition t3 := (tSort (sType (Universe.of_level (Level.level "Top.400")))). Monomorphic Universe i j. Set MetaRocq Strict Unquote Universe Mode. MetaRocq Quote Definition testij := (Type@{j} -> Type@{i}). -MetaRocq Unquote Definition T'' := (tSort (sType (Universe.make' (Level.level "j")))). +MetaRocq Unquote Definition T'' := (tSort (sType (Universe.of_level (Level.level "j")))). Unset MetaRocq Strict Unquote Universe Mode. @@ -195,7 +195,7 @@ Definition nNamedR (s : string) := mkBindAnn (nNamed s) Relevant. Definition nAnonR := mkBindAnn nAnon Relevant. Unset MetaRocq Strict Unquote Universe Mode. -MetaRocq Unquote Definition bla' := (tLambda (nNamedR "T") (tSort (sType (Universe.make' (Level.level "Top.46")))) (tLambda (nNamedR "T2") (tSort (sType (Universe.make' (Level.level "Top.477")))) (tProd nAnonR (tRel 1) (tRel 1)))). +MetaRocq Unquote Definition bla' := (tLambda (nNamedR "T") (tSort (sType (Universe.of_level (Level.level "Top.46")))) (tLambda (nNamedR "T2") (tSort (sType (Universe.of_level (Level.level "Top.477")))) (tProd nAnonR (tRel 1) (tRel 1)))). (* Set Printing Universes. From a923a916e78693b05c9c24b30fb039ad69766c21 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 4 Nov 2025 13:38:59 +0100 Subject: [PATCH 119/164] Adapted TemplateRocq plugin --- common/theories/Universes.v | 2 +- template-rocq/_PluginProject.in | 2 - .../gen-src/metarocq_template_plugin.mlpack | 4 ++ template-rocq/src/ast_denoter.ml | 24 +++++++---- template-rocq/src/ast_quoter.ml | 42 +++++++++++++------ template-rocq/src/constr_quoter.ml | 8 ++-- template-rocq/src/constr_reification.ml | 7 +++- template-rocq/src/denoter.ml | 9 +++- template-rocq/src/quoter.ml | 7 ++-- template-rocq/src/reification.ml | 2 + template-rocq/src/tm_util.ml | 6 ++- utils/theories/NonEmptyLevelExprSet.v | 5 ++- 12 files changed, 79 insertions(+), 39 deletions(-) diff --git a/common/theories/Universes.v b/common/theories/Universes.v index a0fcbc144..a35268d9d 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -422,7 +422,7 @@ Module Universe. Definition eq_leibniz x y : eq x y -> x = y := fun e => e. End Q. - Module NES := NonEmptyLevelExprSet Level Level Q LevelSet LevelExpr LevelExprSet. + Module NES := NonEmptyLevelExprSet Level Q LevelSet LevelExpr LevelExprSet. Include NES. #[global] Instance eq_dec_univ0 : EqDec t := eq_dec. diff --git a/template-rocq/_PluginProject.in b/template-rocq/_PluginProject.in index ea2789276..cbe9d6845 100644 --- a/template-rocq/_PluginProject.in +++ b/template-rocq/_PluginProject.in @@ -158,8 +158,6 @@ gen-src/mSetInterface.ml gen-src/mSetInterface.mli gen-src/mSetProperties.ml gen-src/mSetProperties.mli -gen-src/mRInstances.mli -gen-src/mRInstances.ml gen-src/monad_utils.ml gen-src/monad_utils.mli gen-src/nat0.ml diff --git a/template-rocq/gen-src/metarocq_template_plugin.mlpack b/template-rocq/gen-src/metarocq_template_plugin.mlpack index 4c32d6eab..6658c70d4 100644 --- a/template-rocq/gen-src/metarocq_template_plugin.mlpack +++ b/template-rocq/gen-src/metarocq_template_plugin.mlpack @@ -68,6 +68,7 @@ MRRelations MROption MRProd MRCompare +MRClasses Bytestring Caml_bytestring Monad_utils @@ -93,7 +94,10 @@ MRMSets Config0 Kernames Primitive +UnivConstraintType +SemiLattice BasicAst +NonEmptyLevelExprSet Universes0 Environment EnvironmentTyping diff --git a/template-rocq/src/ast_denoter.ml b/template-rocq/src/ast_denoter.ml index 846f72b2f..8a3792f1a 100644 --- a/template-rocq/src/ast_denoter.ml +++ b/template-rocq/src/ast_denoter.ml @@ -25,12 +25,14 @@ struct type quoted_proj = projection type quoted_global_reference = global_reference + type quoted_universe = Universes0.Universe.t type quoted_sort_family = Universes0.allowed_eliminations - type quoted_constraint_type = Universes0.ConstraintType.t - type quoted_univ_constraint = Universes0.LevelConstraint.t + type quoted_constraint_type = UnivConstraintType.ConstraintType.t + type quoted_univ_constraint = Universes0.UnivConstraint.t type quoted_univ_constraints = Universes0.UnivConstraintSet.t type quoted_univ_level = Universes0.Level.t type quoted_univ_instance = Universes0.Instance.t + type quoted_univ_level_instance = Universes0.LevelInstance.t type quoted_univ_context = Universes0.UContext.t type quoted_univ_contextset = Universes0.ContextSet.t type quoted_abstract_univ_context = Universes0.AUContext.t @@ -104,7 +106,7 @@ struct aci_relevance = x.ci_relevance } let inspect_term (tt: t):(t, quoted_int, quoted_ident, quoted_aname, quoted_sort, quoted_cast_kind, - quoted_kernel_name, quoted_inductive, quoted_relevance, quoted_univ_level, quoted_univ_instance, quoted_proj, + quoted_kernel_name, quoted_inductive, quoted_relevance, quoted_universe, quoted_univ_instance, quoted_proj, quoted_int63, quoted_float64, quoted_pstring) structure_of_term = match tt with | Coq_tRel n -> ACoq_tRel n @@ -214,26 +216,32 @@ struct let u = Univ.Universe.make l in Caml_nat.iter_nat Univ.Universe.super u (snd trm) - let unquote_universe evm (trm : Universes0.Universe.t) = - let u = Universes0.LevelExprSet.t_set trm in + let unquote_universe (trm : Universes0.Universe.t) = + let u = Universes0.Universe.t_set trm in let ux_list = Universes0.LevelExprSet.elements u in let l = List.map unquote_level_expr ux_list in let u = List.fold_left Univ.Universe.sup (List.hd l) (List.tl l) in - evm, u + u let unquote_sort evm trm = match trm with | Universes0.Sort.Coq_sSProp -> evm, Sorts.sprop | Universes0.Sort.Coq_sProp -> evm, Sorts.prop | Universes0.Sort.Coq_sType u -> - let evm, u = unquote_universe evm u in + let u = unquote_universe u in evm, Sorts.sort_of_univ u let unquote_universe_level evm l = evm, unquote_level l + let universe_to_level u = + match Univ.Universe.level u with + | Some l -> l + | None -> CErrors.user_err Pp.(str"universe_to_level: not a level " ++ Univ.Universe.pr Univ.Level.raw_pr u) + let unquote_universe_instance(evm: Evd.evar_map) (l: quoted_univ_instance): Evd.evar_map * UVars.Instance.t - = (evm, UVars.Instance.of_array ([||], Array.of_list (List.map unquote_level l))) + = (evm, UVars.Instance.of_array ([||], Array.of_list (List.map (universe_to_level $ unquote_universe) l))) (* FIXME: algebraics *) + let unquote_universe evm trm = evm, unquote_universe trm let unquote_global_reference (trm : Kernames.global_reference) : GlobRef.t = let open GlobRef in diff --git a/template-rocq/src/ast_quoter.ml b/template-rocq/src/ast_quoter.ml index 7eea95cc9..307c942f6 100644 --- a/template-rocq/src/ast_quoter.ml +++ b/template-rocq/src/ast_quoter.ml @@ -19,6 +19,7 @@ struct type quoted_name = BasicAst.name type quoted_aname = BasicAst.aname type quoted_relevance = BasicAst.relevance + type quoted_universe = Universes0.Universe.t type quoted_sort = Universes0.Sort.t type quoted_cast_kind = cast_kind type quoted_kernel_name = Kernames.kername @@ -27,10 +28,11 @@ struct type quoted_global_reference = global_reference type quoted_sort_family = Universes0.allowed_eliminations - type quoted_constraint_type = Universes0.ConstraintType.t - type quoted_univ_constraint = Universes0.LevelConstraint.t + type quoted_constraint_type = UnivConstraintType.ConstraintType.t + type quoted_univ_constraint = Universes0.UnivConstraint.t type quoted_univ_constraints = Universes0.UnivConstraintSet.t type quoted_univ_level = Universes0.Level.t + type quoted_univ_level_instance = Universes0.LevelInstance.t type quoted_univ_instance = Universes0.Instance.t type quoted_univ_context = Universes0.UContext.t type quoted_univ_contextset = Universes0.ContextSet.t @@ -93,7 +95,7 @@ struct let quote_universe u : Universes0.Universe.t = match Univ.Universe.level u with - Some l -> Universes0.Universe.make' (quote_level l) + Some l -> Universes0.Universe.of_level (quote_level l) | _ -> let levels = Univ.Universe.repr u |> List.map quote_level_expr in Universes0.Universe.from_kernel_repr (List.hd levels) (List.tl levels) @@ -136,11 +138,6 @@ struct let quote_inductive (kn, i) = { inductive_mind = kn ; inductive_ind = i } let quote_proj ind p a = { proj_ind = ind; proj_npars = p; proj_arg = a } - let quote_constraint_type = function - | Univ.Lt -> Universes0.ConstraintType.Le BinNums.(Zpos Coq_xH) - | Univ.Le -> Universes0.ConstraintType.Le BinNums.Z0 - | Univ.Eq -> Universes0.ConstraintType.Eq - let is_Lt = function | Univ.Lt -> true | _ -> false @@ -153,13 +150,22 @@ struct | Univ.Eq -> true | _ -> false - let quote_univ_constraint ((l, ct, l') : Univ.univ_constraint) : quoted_univ_constraint = - try ((quote_level l, quote_constraint_type ct), quote_level l') - with e -> assert false + let universe_of_level = Universes0.Universe.of_level + + let quote_univ_constraint ((l, ct, r) : Univ.univ_constraint) : quoted_univ_constraint = + let ql = quote_level l in + let qr = quote_level r in + let ul = Universes0.Universe.of_level ql in + let ur = Universes0.Universe.of_level qr in + let open UnivConstraintType.ConstraintType in + match ct with + | Univ.Lt -> ((Universes0.Universe.succ ul, Le), ur) + | Univ.Le -> ((ul, Le), ur) + | Univ.Eq -> ((ul, Eq), ur) let quote_univ_level = quote_level - let quote_univ_instance (i : UVars.Instance.t) : quoted_univ_instance = + let quote_univ_level_instance (i : UVars.Instance.t) : quoted_univ_level_instance = let qarr, uarr = UVars.Instance.to_array i in let () = if not (CArray.is_empty qarr) then CErrors.user_err Pp.(str "Quoting sort polymorphic instances not yet supported.") @@ -168,6 +174,16 @@ struct try CArray.map_to_list quote_level uarr with e -> assert false + + let quote_univ_instance (i : UVars.Instance.t) : quoted_univ_instance = + let qarr, uarr = UVars.Instance.to_array i in + let () = if not (CArray.is_empty qarr) then + CErrors.user_err Pp.(str "Quoting sort polymorphic instances not yet supported.") + in + (* we assume that valid instances do not contain [Prop] or [SProp] *) + try CArray.map_to_list (Universes0.Universe.of_level $ quote_level) uarr + with e -> assert false + (* (Prop, Le | Lt, l), (Prop, Eq, Prop) -- trivial, (l, c, Prop) -- unsatisfiable *) let rec constraints_ (cs : Univ.univ_constraint list) : quoted_univ_constraint list = match cs with @@ -193,7 +209,7 @@ struct let names = CArray.map_to_list quote_name uarr in let levels = UVars.UContext.instance uctx in let constraints = UVars.UContext.constraints uctx in - (names, (quote_univ_instance levels, quote_univ_constraints constraints)) + (names, (quote_univ_level_instance levels, quote_univ_constraints constraints)) let quote_univ_contextset (uctx : Univ.ContextSet.t) : quoted_univ_contextset = let levels = List.map quote_level (Univ.Level.Set.elements (Univ.ContextSet.levels uctx)) in diff --git a/template-rocq/src/constr_quoter.ml b/template-rocq/src/constr_quoter.ml index 2bdb8b79e..5f7b62f82 100644 --- a/template-rocq/src/constr_quoter.ml +++ b/template-rocq/src/constr_quoter.ml @@ -205,11 +205,11 @@ struct | Some x -> constr_mkApp (tLevelVar, [| quote_int x |]) | None -> constr_mkApp (tLevel, [| string_of_level l |]) - let of_level l = constr_mkApp (tof_level, [| l |]) + let universe_of_level l = constr_mkApp (tof_level, [| l |]) let quote_universe s = match Univ.Universe.level s with - Some l -> of_level (quote_level l) + Some l -> universe_of_level (quote_level l) | _ -> let levels = List.map (fun (l,i) -> pairl tlevel tnat (quote_level l) (quote_int i)) (Universe.repr s) in let hd = List.hd levels in let tl = to_coq_list (prodl tlevel tnat) (List.tl levels) in @@ -229,9 +229,9 @@ struct let quote_univ_constraint ((l1, ct, l2) : Univ.univ_constraint) = let l1 = quote_level l1 in let l2 = quote_level l2 in - let u1 = if ct == Lt then constr_mkApp (tsucc, [| of_level l1 |]) else of_level l1 in + let u1 = if ct == Lt then constr_mkApp (tsucc, [| universe_of_level l1 |]) else universe_of_level l1 in let ct = quote_constraint_type ct in - constr_mkApp (tmake_univ_constraint, [| u1; ct; of_level l2 |]) + constr_mkApp (tmake_univ_constraint, [| u1; ct; universe_of_level l2 |]) let quote_univ_level u = quote_level u (* todo : can be deduced from quote_level, hence shoud be in the Reify module *) diff --git a/template-rocq/src/constr_reification.ml b/template-rocq/src/constr_reification.ml index 7dba024f2..d1104a189 100644 --- a/template-rocq/src/constr_reification.ml +++ b/template-rocq/src/constr_reification.ml @@ -10,7 +10,7 @@ struct type quoted_name = Constr.t (* of type BasicAst.name *) type quoted_aname = Constr.t (* of type BasicAst.aname (names with relevance) *) type quoted_relevance = Constr.t (* of type BasicAst.relevance *) - type quoted_sort = Constr.t (* of type Ast.universe *) + type quoted_sort = Constr.t (* of type Universes.sort *) type quoted_cast_kind = Constr.t (* of type Ast.cast_kind *) type quoted_kernel_name = Constr.t (* of type Ast.kername *) type quoted_inductive = Constr.t (* of type Ast.inductive *) @@ -24,8 +24,11 @@ struct type quoted_constraint_type = Constr.t (* of type Universes.constraint_type *) type quoted_univ_constraint = Constr.t (* of type Universes.univ_constraint *) type quoted_univ_constraints = Constr.t (* of type Universes.constraints *) + type quoted_universe = Constr.t (* of type Universes.Universe.t *) + type quoted_univ_level = Constr.t (* of type Universes.Level.t *) - type quoted_univ_instance = Constr.t (* of type Universes.universe_instance *) + type quoted_univ_level_instance = Constr.t (* of type Universes.LevelInstance.t *) + type quoted_univ_instance = Constr.t (* of type Universes.Instance.t *) type quoted_univ_context = Constr.t (* of type Universes.UContext.t *) type quoted_univ_contextset = Constr.t (* of type Universes.ContextSet.t *) type quoted_abstract_univ_context = Constr.t (* of type Universes.AUContext.t *) diff --git a/template-rocq/src/denoter.ml b/template-rocq/src/denoter.ml index 5e4bcdfb2..512b010be 100644 --- a/template-rocq/src/denoter.ml +++ b/template-rocq/src/denoter.ml @@ -23,12 +23,13 @@ sig val unquote_proj : quoted_proj -> (quoted_inductive * quoted_int * quoted_int) (* val unquote_universe : Evd.evar_map -> quoted_universe -> Evd.evar_map * Univ.Universe.t *) val unquote_universe_level : Evd.evar_map -> quoted_univ_level -> Evd.evar_map * Univ.Level.t + val unquote_universe : Evd.evar_map -> quoted_universe -> Evd.evar_map * Univ.Universe.t val unquote_universe_instance: Evd.evar_map -> quoted_univ_instance -> Evd.evar_map * UVars.Instance.t val unquote_sort : Evd.evar_map -> quoted_sort -> Evd.evar_map * Sorts.t (* val unquote_sort_family : quoted_sort_family -> Sorts.family *) (* val representsIndConstuctor : quoted_inductive -> Term.constr -> bool *) val inspect_term : t -> (t, quoted_int, quoted_ident, quoted_aname, quoted_sort, quoted_cast_kind, - quoted_kernel_name, quoted_inductive, quoted_relevance, quoted_univ_level, quoted_univ_instance, quoted_proj, + quoted_kernel_name, quoted_inductive, quoted_relevance, quoted_universe, quoted_univ_instance, quoted_proj, quoted_int63, quoted_float64, quoted_pstring) structure_of_term end @@ -168,10 +169,14 @@ struct | ACoq_tFloat x -> evm, Constr.mkFloat (D.unquote_float64 x) | ACoq_tString x -> evm, Constr.mkString (D.unquote_pstring x) | ACoq_tArray (u, arr, def, ty) -> - let evm, u = D.unquote_universe_level evm u in + let evm, u = D.unquote_universe evm u in let evm, arr = CArray.fold_left_map (fun evm a -> aux env evm a) evm arr in let evm, def = aux env evm def in let evm, ty = aux env evm ty in + let u = match Univ.Universe.level u with + | Some u -> u + | None -> CErrors.user_err Pp.(str "Array universe is not a level.") + in evm, Constr.mkArray (UVars.Instance.of_array ([||], [|u|]), arr, def, ty) in aux env evm trm diff --git a/template-rocq/src/quoter.ml b/template-rocq/src/quoter.ml index 201db962c..22583518c 100644 --- a/template-rocq/src/quoter.ml +++ b/template-rocq/src/quoter.ml @@ -86,7 +86,7 @@ sig val mkInt : quoted_int63 -> t val mkFloat : quoted_float64 -> t val mkString : quoted_pstring -> t - val mkArray : quoted_univ_level -> t array -> default:t -> ty:t -> t + val mkArray : quoted_universe -> t array -> default:t -> ty:t -> t val mkBindAnn : quoted_name -> quoted_relevance -> quoted_aname val mkName : quoted_ident -> quoted_name @@ -110,7 +110,6 @@ sig val quote_float64 : Float64.t -> quoted_float64 val quote_pstring : Pstring.t -> quoted_pstring - val quote_constraint_type : Univ.constraint_type -> quoted_constraint_type val quote_univ_constraint : Univ.univ_constraint -> quoted_univ_constraint val quote_univ_level : Univ.Level.t -> quoted_univ_level val quote_univ_instance : UVars.Instance.t -> quoted_univ_instance @@ -183,6 +182,8 @@ sig val mk_global_env : quoted_univ_contextset -> quoted_global_declarations -> quoted_retroknowledge -> quoted_global_env val mk_program : quoted_global_env -> t -> quoted_program + + val universe_of_level : quoted_univ_level -> quoted_universe end @@ -343,7 +344,7 @@ struct let def', acc = quote_term acc env sigma def in let ty', acc = quote_term acc env sigma ty in let acc, arr' = CArray.fold_left_map (fun acc t -> let t', acc = quote_term acc env sigma t in acc, t') acc ar in - Q.mkArray (Q.quote_univ_level u) arr' ~default:def' ~ty:ty', acc + Q.mkArray (Q.universe_of_level (Q.quote_univ_level u)) arr' ~default:def' ~ty:ty', acc in aux acc env trm and quote_recdecl (acc : 'a) env sigma b (ns,ts,ds) = diff --git a/template-rocq/src/reification.ml b/template-rocq/src/reification.ml index 1f5e77788..c57f6b3c6 100644 --- a/template-rocq/src/reification.ml +++ b/template-rocq/src/reification.ml @@ -9,6 +9,7 @@ sig type quoted_name type quoted_aname type quoted_relevance + type quoted_universe type quoted_sort type quoted_cast_kind type quoted_kernel_name @@ -26,6 +27,7 @@ sig type quoted_univ_constraints type quoted_univ_level type quoted_univ_instance + type quoted_univ_level_instance type quoted_univ_context type quoted_univ_contextset type quoted_abstract_univ_context diff --git a/template-rocq/src/tm_util.ml b/template-rocq/src/tm_util.ml index 06a103ccd..4852d268d 100644 --- a/template-rocq/src/tm_util.ml +++ b/template-rocq/src/tm_util.ml @@ -2,6 +2,8 @@ open Pp let contrib_name = "template-rocq" +let ($) f g = fun x -> f (g x) + let gen_constant_in_modules s = lazy ( let tm_ref = Rocqlib.lib_ref s in @@ -344,7 +346,7 @@ type ('nat, 'inductive, 'relevance) acase_info = aci_npar : 'nat; aci_relevance : 'relevance } -type ('term, 'nat, 'ident, 'name, 'quoted_sort, 'cast_kind, 'kername, 'inductive, 'relevance, 'universe_level, 'universe_instance, 'projection, 'int63, 'float64, 'pstring) structure_of_term = +type ('term, 'nat, 'ident, 'name, 'quoted_sort, 'cast_kind, 'kername, 'inductive, 'relevance, 'universe, 'universe_instance, 'projection, 'int63, 'float64, 'pstring) structure_of_term = | ACoq_tRel of 'nat | ACoq_tVar of 'ident | ACoq_tEvar of 'nat * 'term list @@ -366,5 +368,5 @@ type ('term, 'nat, 'ident, 'name, 'quoted_sort, 'cast_kind, 'kername, 'inductive | ACoq_tInt of 'int63 | ACoq_tFloat of 'float64 | ACoq_tString of 'pstring - | ACoq_tArray of 'universe_level * 'term array * 'term * 'term + | ACoq_tArray of 'universe * 'term array * 'term * 'term diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v index 883c1a062..1ffddb54c 100644 --- a/utils/theories/NonEmptyLevelExprSet.v +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -64,8 +64,9 @@ Module Type LevelExprT (Level : OrderedTypeWithLeibniz) (Q : Quantity). Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. End LevelExprT. -Module Type LevelSet_fun (Level : UsualOrderedType). - Include S with Module E := Level. +Module Type LevelSet_fun (Level : OrderedType). + Include S with Definition E.t := Level.t + with Definition E.eq := @Logic.eq Level.t. End LevelSet_fun. Module Type LevelExprSet_fun (Level : OrderedTypeWithLeibniz) (Q : Quantity) From 405222e619899b806aec350c747de2131d219466 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Tue, 4 Nov 2025 14:16:21 +0100 Subject: [PATCH 120/164] Porting of PCUIC --- common/theories/Universes.v | 51 +++++-- common/theories/UniversesDec.v | 20 +-- .../Conversion/PCUICUnivSubstitutionConv.v | 144 ++++++++---------- pcuic/theories/PCUICConversion.v | 6 +- pcuic/theories/PCUICCumulativitySpec.v | 18 +-- pcuic/theories/PCUICEquality.v | 8 +- pcuic/theories/PCUICGlobalEnv.v | 26 +++- .../PCUICParallelReductionConfluence.v | 2 +- pcuic/theories/PCUICProgress.v | 2 +- pcuic/theories/PCUICReduction.v | 8 +- pcuic/theories/PCUICTyping.v | 8 +- pcuic/theories/PCUICValidity.v | 6 +- pcuic/theories/PCUICWcbvEval.v | 8 +- pcuic/theories/PCUICWeakeningConfig.v | 2 +- pcuic/theories/PCUICWeakeningEnv.v | 75 +++------ pcuic/theories/Syntax/PCUICOnFreeVars.v | 8 +- pcuic/theories/Syntax/PCUICPosition.v | 12 +- pcuic/theories/Syntax/PCUICReflect.v | 2 +- pcuic/theories/Typing/PCUICClosedTyp.v | 12 +- safechecker/theories/PCUICEqualityDec.v | 12 +- safechecker/theories/PCUICSafeConversion.v | 14 +- safechecker/theories/PCUICTypeChecker.v | 6 +- template-pcuic/theories/PCUICToTemplate.v | 2 +- .../theories/TemplateMonadToPCUIC.v | 2 +- template-pcuic/theories/TemplateToPCUIC.v | 2 +- .../theories/TemplateToPCUICCorrectness.v | 4 +- 26 files changed, 219 insertions(+), 241 deletions(-) diff --git a/common/theories/Universes.v b/common/theories/Universes.v index a35268d9d..7c782c012 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -233,6 +233,20 @@ Section LevelSetMoreFacts. Proof. intros x; rewrite LevelSet.union_spec. lsets. Qed. + + Lemma levelset_add_remove {l s} : LevelSet.add l (LevelSet.remove l s) =_lset LevelSet.add l s. + Proof. + intros l'. split. lsets. + destruct (Classes.eq_dec l l'). subst. + - move/LevelSet.add_spec => -[heq|hin] //; lsets. + - move/LevelSet.add_spec => -[heq|hin] //; lsets. + Qed. + + Lemma levelset_subset_add {ls ls' l} : LevelSet.Subset ls ls' -> LevelSet.Subset ls (LevelSet.add l ls'). + Proof. + intros l' hin. lsets. + Qed. + End LevelSetMoreFacts. (* prop level is Prop or SProp *) @@ -1264,27 +1278,40 @@ Section Univ. rewrite Universe.map_spec. reflexivity. Qed. - Lemma val_succ v l : val v (LevelExpr.succ l) = val v l + 1. + Lemma spec_plus l n x : + LevelExprSet.In x (Universe.plus n l) <-> + exists x', LevelExprSet.In x' l /\ x = LevelExpr.add n x'. + Proof using Type. + rewrite Universe.map_spec. reflexivity. + Qed. + + Lemma val_levelexpr_succ v l : val v (LevelExpr.succ l) = val v l + 1. + Proof using Type. + destruct l as []; simpl. cbn. lia. + Qed. + + Lemma val_levelexpr_plus v n l : val v (LevelExpr.add n l) = val v l + n. Proof using Type. destruct l as []; simpl. cbn. lia. Qed. - Lemma val_map_succ v l : val v (Universe.succ l) = val v l + 1. + Lemma val_plus v n l : val v (Universe.plus n l) = val v l + n. Proof using Type. - pose proof (spec_map_succ l). - set (n := Universe.succ l) in *. + pose proof (spec_plus l n). + set (un := Universe.plus n l) in *. destruct (val_In_max l v) as [max [inmax eqv]]. rewrite <-eqv. rewrite val_caract. split. intros. specialize (proj1 (H _) H0) as [x' [inx' eq]]. subst e. - rewrite val_succ. eapply (val_In_le _ v) in inx'. rewrite <- eqv in inx'. + rewrite val_levelexpr_plus. eapply (val_In_le _ v) in inx'. rewrite <- eqv in inx'. simpl in *. unfold LevelExprSet.elt, LevelExpr.t in *. lia. - exists (LevelExpr.succ max). split. apply H. + exists (LevelExpr.add n max). split. apply H. exists max; split; auto. - now rewrite val_succ. + now rewrite val_levelexpr_plus. Qed. - + Lemma val_succ v l : val v (Universe.succ l) = val v l + 1. + Proof. by rewrite (val_plus v 1). Qed. (* Lemma consistent_extension_on_union X cstrs (wfX : forall c, UCS.In c X.2 -> LS.Subset (Universe.levels c.1.1) X.1 /\ LS.Subset (Universe.levels c.2) X.1) : @@ -1486,7 +1513,7 @@ Qed. *) intro u. unfold complement. unfold_univ_rel => //. destruct H as [v Hv]; intros nH. specialize (nH v Hv). - rewrite val_map_succ in nH. lia. + rewrite val_succ in nH. lia. Qed. Global Instance lt_universe_trans {c: check_univs} φ : Transitive (lt_universe φ). @@ -1496,7 +1523,7 @@ Qed. *) move => v1 v2 v Hv. specialize (v1 v Hv). specialize (v2 v Hv). - rewrite !val_map_succ in v1, v2 |- *. lia. + rewrite !val_succ in v1, v2 |- *. lia. Qed. Global Instance lt_universe_str_order {c: check_univs} φ (H: consistent φ) : StrictOrder (lt_universe φ). @@ -2499,7 +2526,7 @@ Section no_prop_leq_type. Proof using Type. destruct s as [| | u1], s' as [| | u1']; cbnr; try absurd; intros H; unfold_univ_rel; - rewrite !val_map_succ; lia. + rewrite !val_succ; lia. Qed. Lemma leq_sort_prop_no_prop_sub_type s1 s2 : @@ -2579,7 +2606,7 @@ Definition subst_instance_level_expr (u : Instance.t) (l : LevelExpr.t) : Univer | (Level.lvar n, k) => match nth_error u n with | Some l => Universe.plus k l - | None => Universe.zero + | None => Universe.plus k Universe.zero end end. diff --git a/common/theories/UniversesDec.v b/common/theories/UniversesDec.v index 7859f1871..90c04b700 100644 --- a/common/theories/UniversesDec.v +++ b/common/theories/UniversesDec.v @@ -3,25 +3,14 @@ From Equations Require Import Equations. From MetaRocq.Utils Require Import MRList MROption MRUtils. From MetaRocq.Common Require Import uGraph. From MetaRocq.Common Require Import Universes. -(* Import wGraph. *) + Import UnivLoopChecking.UnivLoopChecking. +Import UnivConstraintType.ConstraintType. +Import Clauses.FLS. Definition levels_of_cs (cs : UnivConstraintSet.t) : LevelSet.t := LevelSet.remove Level.lzero (univ_constraints_levels cs). -Lemma levelset_add_remove {l s} : LevelSet.add l (LevelSet.remove l s) =_lset LevelSet.add l s. -Proof. - intros l'. split. lsets. - destruct (Classes.eq_dec l l'). subst. - - move/LevelSet.add_spec => -[heq|hin] //; lsets. - - move/LevelSet.add_spec => -[heq|hin] //; lsets. -Qed. - -Lemma levelset_subset_add {ls ls' l} : LevelSet.Subset ls ls' -> LevelSet.Subset ls (LevelSet.add l ls'). -Proof. - intros l' hin. lsets. -Qed. - Lemma levels_of_cs_spec cstr (lvls := levels_of_cs cstr) : uGraph.global_uctx_invariants (lvls, cstr). Proof. @@ -135,9 +124,6 @@ Proof. - admit. Admitted. -Import Clauses.FLS. -Import UnivConstraintType.ConstraintType. - Lemma declared_univ_cstrs_levels_spec cstrs : declared_univ_cstrs_levels (univ_constraints_levels cstrs) cstrs. Proof. intros cl hin. apply declared_univ_cstr_levels_spec. diff --git a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v index 272716b91..2cd34fad5 100644 --- a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v +++ b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v @@ -23,14 +23,36 @@ Create HintDb univ_subst. Local Ltac aa := rdest; eauto with univ_subst. -Import NonEmptySetFacts. +Import Universes. +Import Universe.NES. -Lemma subst_instance_level_val u l v v' +Lemma subst_instance_level_expr_val {u l v} v' (H1 : forall s, valuation_mono v s = valuation_mono v' s) - (H2 : forall n, val v (nth n u Level.lzero) = valuation_poly v' n) - : val v (subst_instance_level u l) = val v' l. + (H2 : forall n, val v (nth n u Universe.zero) = valuation_poly v' n) + : val v (subst_instance_level_expr u l) = val v' l. Proof. - destruct l; cbn; try congruence. apply H2. + destruct l as [l k]; cbn. destruct l; cbn; try congruence. cbn. + have hn := nth_nth_error n u Universe.zero. + move: (H2 n); rewrite hn. + destruct nth_error eqn:he => //. + * intros <-. rewrite val_plus //. lia. + * intros <-. cbn. lia. +Qed. + +Lemma subst_instance_universe_val u l v v' + (H1 : forall s, valuation_mono v s = valuation_mono v' s) + (H2 : forall n, val v (nth n u Universe.zero) = valuation_poly v' n) + : val v (subst_instance_universe u l) = val v' l. +Proof. + move: l; eapply Universe.NES.elim. + - intros le; cbn. rewrite (subst_instance_level_expr_val v') //. + - intros le x ih hin. + rewrite /subst_instance_universe. + rewrite val_add /Universe.concat_map. + rewrite -ih. + rewrite Universe.fold_union_add /Universe.sup. + rewrite val_sup. f_equal. + now apply subst_instance_level_expr_val. Qed. Lemma eq_valuation v v' @@ -41,8 +63,9 @@ Proof. intros [| | u]; cbnr. f_equal. assert (He : forall e : LevelExpr.t, val v e = val v' e). { intros [[] b]; cbnr; rewrite ?H1 ?H2; reflexivity. } - rewrite !val_fold_right. - induction ((List.rev (Universe.exprs u).2)); cbn; congruence. + eapply val_eq_levels_alg. 2:{ reflexivity. } + intros l _. specialize (He (l, 0)). now cbn in He. + Unshelve. exact config.default_checker_flags. Qed. (* Lemma is_prop_subst_instance_level u l @@ -55,38 +78,9 @@ Proof. destruct HH as [l [HH1 HH2]]. rewrite HH1. now apply ssrbool.negbTE. Qed. *) -Lemma subst_instance_level_expr_val u expr v v' - (H1 : forall s, valuation_mono v s = valuation_mono v' s) - (H2 : forall n, val v (nth n u Level.lzero) = valuation_poly v' n) - : val v (subst_instance_level_expr u expr) = val v' expr. -Proof. - destruct expr as [[] b]; cbnr. - { now rewrite <- H1. } - rewrite <- H2, nth_nth_error. - destruct nth_error; cbnr. -Qed. - -Lemma subst_instance_universe_val u exprs v v' - (H1 : forall s, valuation_mono v s = valuation_mono v' s) - (H2 : forall n, val v (nth n u Level.lzero) = valuation_poly v' n) - : val v (subst_instance_universe u exprs) = val v' exprs. -Proof. - symmetry. - apply val_caract. split. - - intros e Xe. - apply val_le_caract. eexists; split. - + apply map_spec. eexists; split; tea. reflexivity. - + erewrite subst_instance_level_expr_val with (v':=v'); tea. reflexivity. - - destruct ((val_caract (map (subst_instance_level_expr u) exprs) v _).p1 eq_refl) - as [_ [e [He1 <-]]]. - apply map_spec in He1 as [e0 [He0 ->]]. - eexists; split; tea. - symmetry; now apply subst_instance_level_expr_val. -Qed. - Lemma subst_instance_sort_val u s v v' (H1 : forall s, valuation_mono v s = valuation_mono v' s) - (H2 : forall n, val v (nth n u Level.lzero) = valuation_poly v' n) + (H2 : forall n, val v (nth n u Universe.zero) = valuation_poly v' n) : Sort.to_csort v (subst_instance_sort u s) = Sort.to_csort v' s. Proof. destruct s as [ | | exprs]; cbnr. @@ -95,16 +89,14 @@ Qed. Definition subst_instance_valuation (u : Instance.t) (v : valuation) := {| valuation_mono := valuation_mono v ; - valuation_poly := fun i => val v (nth i u Level.lzero) |}. - + valuation_poly := fun i => val v (nth i u Universe.zero) |}. Lemma subst_instance_level_val' u l v - : val v (subst_instance_level u l) = val (subst_instance_valuation u v) l. + : val v (subst_instance_level_expr u l) = val (subst_instance_valuation u v) l. Proof. - now apply subst_instance_level_val. + now apply subst_instance_level_expr_val. Qed. - Lemma subst_instance_universe_val' u exprs v : val v (subst_instance_universe u exprs) = val (subst_instance_valuation u v) exprs. Proof. @@ -118,16 +110,16 @@ Proof. Qed. Lemma subst_instance_universe_make' (l : LevelExpr.t) u : - subst_instance u (Universe.make l) = Universe.make (subst_instance_level_expr u l). + subst_instance u (Universe.make l) = subst_instance_level_expr u l. Proof. reflexivity. Qed. -Lemma subst_instance_universe_make l u : +(* Lemma subst_instance_universe_make l u : subst_instance_universe u (Universe.of_level l) = Universe.of_level (subst_instance u l). Proof. destruct l; cbnr. rewrite nth_nth_error. destruct nth_error; cbnr. -Qed. +Qed. *) Class SubstUnivPreserving eq_universe {A} `{UnivSubst A} (eqA : A -> A -> Prop) := Build_SubstUnivPreserving : @@ -142,8 +134,7 @@ Lemma subst_equal_inst_inst Re Re' : Proof. intros hRe u. induction u; cbnr; try now constructor. intros u1 u2; unfold cmp_universe_instance; cbn; constructor. - - pose proof (hRe (Universe.of_level a) u1 u2 H) as HH. - now rewrite /subst_instance !subst_instance_universe_make in HH. + - apply (hRe a u1 u2 H). - exact (IHu u1 u2 H). Qed. @@ -180,12 +171,17 @@ Proof. - reflexivity. - destruct p as [? []]; try now constructor. destruct X as (hty & hdef & harr). - constructor; cbn; eauto. - * rewrite /= -!subst_instance_universe_make. - now eapply hsubst_conv. - * solve_all. + constructor; cbn; eauto. solve_all. Qed. +Lemma add_subst le u i : (add le u)@[i] = union (subst_instance_level_expr i le) u@[i]. +Proof. + apply equal_exprsets => l. + rewrite [_@[i]]Universe.fold_union_add //=. +Qed. + +(* Lemma interp_nes_union (val : valuation): Universe.interp_nes val () *) + #[global] Instance eq_universe_SubstUnivPreserving {cf:checker_flags} φ : SubstUnivPreserving (eq_universe φ) (eq_universe φ). @@ -199,20 +195,15 @@ Proof. - intros l1 X. eapply Forall2_nth_error_Some_l in hu; tea. destruct hu as [l2 [-> H2]]. specialize (H2 v Hv). - cbn in *. lia. + cbn in *. rewrite !val_plus. lia. - intros X. eapply Forall2_nth_error_None_l in hu; tea. destruct (nth_error u2 n); [discriminate|reflexivity]. } simpl. - apply val_caract; split. - - intros e Xe. apply map_spec in Xe as [e' [H1 H2]]; subst. - apply val_le_caract. eexists; split. - + apply map_spec; eexists; split; tea; reflexivity. - + now rewrite He. - - destruct ((val_caract (map (subst_instance_level_expr u2) exprs) v _).p1 eq_refl) - as [_ [e [He1 He2]]]. rewrite <- He2. - apply map_spec in He1. destruct He1 as [e0 [He0 He1]]; subst. - eexists; split; [|eapply He]. eapply map_spec. - now eexists; split; tea. + move: exprs. + apply: Universe.NES.elim. + - intros le; cbn. apply He. + - intros le x hv hnin. + now rewrite -!interp_nes_val !add_subst !interp_nes_val !val_sup hv He. Qed. #[global] @@ -228,27 +219,16 @@ Proof. - intros l1 X. eapply Forall2_nth_error_Some_l in hu; tea. destruct hu as [l2 [-> H2]]. specialize (H2 v Hv). - cbn in *. lia. + cbn in *. rewrite !val_plus; lia. - intros X. eapply Forall2_nth_error_None_l in hu; tea. destruct (nth_error u2 n); [discriminate|reflexivity]. } simpl. - rewrite Z.sub_0_r. - eapply Nat2Z.inj_le. - remember (val v (subst_instance u2 exprs)) as val2 eqn:eq. symmetry in eq. - apply val_caract in eq. - destruct eq. - destruct H0 as [e [inet vale]]. - apply map_spec in inet as [e' [H1 H2]]; subst. - remember (val v (subst_instance u1 exprs)) as val1 eqn:eq. symmetry in eq. - apply val_caract in eq as [eq' [e'' [ine'' vale'']]]. - subst val1. - apply map_spec in ine'' as [e0 [ine0 eq]]. - specialize (He e0). subst e''. - etransitivity. - - eassumption. - - eapply H. - eapply map_spec. - exists e0; split; auto. + move: exprs. + apply: Universe.NES.elim. + - intros le; cbn. apply He. + - intros le x hv hnin. + rewrite -!interp_nes_val !add_subst !interp_nes_val !val_sup. + specialize (He le). lia. Qed. #[global] @@ -280,8 +260,8 @@ Global Instance subst_instance_nat : UnivSubst nat := fun _ n => n. Lemma subst_instance_level_two u1 u2 l : - subst_instance_level u1 (subst_instance_level u2 l) - = subst_instance_level (subst_instance u1 u2) l. + subst_instance_universe u1 (subst_instance_level_expr u2 l) + = subst_instance_level_expr (subst_instance u1 u2) l. Proof. destruct l; cbn; try reflexivity. unfold subst_instance. diff --git a/pcuic/theories/PCUICConversion.v b/pcuic/theories/PCUICConversion.v index bbaa90404..f292cd85f 100644 --- a/pcuic/theories/PCUICConversion.v +++ b/pcuic/theories/PCUICConversion.v @@ -850,7 +850,7 @@ Section ConvCongruences. (∑ s, p = (primString; primStringModel s) /\ T = tPrim p) + ∑ a a', [× p = (primArray; primArrayModel a), T = tPrim (primArray; primArrayModel a'), - a.(array_level) = a'.(array_level), + a.(array_universe) = a'.(array_universe), Σ ;;; Γ ⊢ a.(array_default) ⇝ a'.(array_default), Σ ;;; Γ ⊢ a.(array_type) ⇝ a'.(array_type) & All2 (fun x y => Σ ;;; Γ ⊢ x ⇝ y) a.(array_value) a'.(array_value)]. @@ -3909,8 +3909,8 @@ Proof. eapply ws_cumul_pb_alt_closed in w as [def [def' []]]. eapply ws_cumul_pb_alt_closed in w0 as [ty [ty' []]]. eapply ws_cumul_pb_alt. - exists (tPrim (primArray; primArrayModel {| array_level := array_level a; array_default := def; array_type := ty; array_value := args0 |})). - exists (tPrim (primArray; primArrayModel {| array_level := array_level a'; array_default := def'; array_type := ty'; array_value := args0' |})). + exists (tPrim (primArray; primArrayModel {| array_universe := array_universe a; array_default := def; array_type := ty; array_value := args0 |})). + exists (tPrim (primArray; primArrayModel {| array_universe := array_universe a'; array_default := def'; array_type := ty'; array_value := args0' |})). split; eauto; pcuic; cbn; rtoProp; intuition eauto; fvs. + eapply closed_red_terms_open_left in Hargs0. solve_all. + eapply closed_red_terms_open_left in Hargs0'. solve_all. diff --git a/pcuic/theories/PCUICCumulativitySpec.v b/pcuic/theories/PCUICCumulativitySpec.v index 42837f7b4..bd3f8e287 100644 --- a/pcuic/theories/PCUICCumulativitySpec.v +++ b/pcuic/theories/PCUICCumulativitySpec.v @@ -28,7 +28,7 @@ Definition cumul_predicate_dep {cumul cumul_universe Γ p p'} Lemma cumul_predicate_undep {cumul cumul_universe Γ p p' H cumul' cumul_universe'} : @cumul_predicate cumul' cumul_universe' Γ p p' <~> - @cumul_predicate_dep cumul cumul_universe Γ p p' H (fun Γ p p' _ => cumul' Γ p p') (fun x y _ => on_rel cumul_universe' Universe.of_level x y). + @cumul_predicate_dep cumul cumul_universe Γ p p' H (fun Γ p p' _ => cumul' Γ p p') (fun x y _ => cumul_universe' x y). Proof. cbv [cumul_predicate cumul_predicate_dep cmp_universe_instance cmp_universe_instance_dep] in *. split; intro; repeat destruct ?; subst; rdest; try assumption. @@ -380,7 +380,7 @@ Lemma cumulSpec0_rect : (forall (Γ : context) (pb : conv_pb) (indn : case_info) (p p' : predicate term) (c c' : term) (brs brs' : list (branch term)) (Hp : cumul_predicate (fun Γ => cumulSpec0 Σ Γ Conv) (compare_universe Σ Conv) Γ p p') - (_ : cumul_predicate_dep Hp (fun Γ => P cf Σ Γ Conv) (fun l l' _ => on_rel (fun _ _ => True) Universe.of_level l l')) + (_ : cumul_predicate_dep Hp (fun Γ => P cf Σ Γ Conv) (fun l l' _ => True)) (Hc : cumulSpec0 Σ Γ Conv c c') (_ : P cf Σ Γ Conv c c' Hc) (Hbody : cumul_branches (fun Γ => cumulSpec0 Σ Γ Conv) Γ p brs brs') (_ : All2_dep @@ -432,7 +432,7 @@ Lemma cumulSpec0_rect : (* cumulativity rules *) - (forall (Γ : context) (pb : conv_pb) (i : inductive) (u u' : list Level.t) + (forall (Γ : context) (pb : conv_pb) (i : inductive) (u u' : Instance.t) (args args' : list term) (Hu : cumul_Ind_univ Σ pb i #|args| u u') (Hargs : All2 (cumulSpec0 Σ Γ Conv) args args') @@ -441,7 +441,7 @@ Lemma cumulSpec0_rect : (cumul_Ind _ _ _ _ _ _ _ _ Hu Hargs)) -> (forall (Γ : context) (pb : conv_pb) (i : inductive) (k : nat) - (u u' : list Level.t) (args args' : list term) + (u u' : Instance.t) (args args' : list term) (Hu : cumul_Construct_univ Σ pb i k #|args| u u') (Hargs : All2 (cumulSpec0 Σ Γ Conv) args args') (_ : All2_dep (P cf Σ Γ Conv) Hargs), @@ -453,7 +453,7 @@ Lemma cumulSpec0_rect : P cf Σ Γ pb (tSort s) (tSort s') (cumul_Sort _ _ _ _ _ Hs)) -> - (forall (Γ : context) (pb : conv_pb) (c : kername) (u u' : list Level.t) + (forall (Γ : context) (pb : conv_pb) (c : kername) (u u' : Instance.t) (Hu : cmp_universe_instance (compare_universe Σ Conv) u u'), P cf Σ Γ pb (tConst c u) (tConst c u') (cumul_Const _ _ _ _ _ _ Hu)) -> @@ -654,7 +654,7 @@ Lemma convSpec0_ind_all : (forall (Γ : context) (indn : case_info) (p p' : predicate term) (c c' : term) (brs brs' : list (branch term)) (Hp : cumul_predicate (fun Γ => cumulSpec0 Σ Γ Conv) (compare_universe Σ Conv) Γ p p') - (_ : cumul_predicate_dep Hp (fun Γ => P cf Σ Γ Conv) (fun l l' _ => on_rel (fun _ _ => True) Universe.of_level l l')) + (_ : cumul_predicate_dep Hp (fun Γ => P cf Σ Γ Conv) (fun l l' _ => True)) (Hc : cumulSpec0 Σ Γ Conv c c') (_ : P cf Σ Γ Conv c c' Hc) (Hbody : cumul_branches (fun Γ => cumulSpec0 Σ Γ Conv) Γ p brs brs') (_ : All2_dep @@ -694,7 +694,7 @@ Lemma convSpec0_ind_all : (* cumulativity rules *) - (forall (Γ : context) (i : inductive) (u u' : list Level.t) + (forall (Γ : context) (i : inductive) (u u' : Instance.t) (args args' : list term) (Hu : cumul_Ind_univ Σ Conv i #|args| u u') (Hargs : All2 (cumulSpec0 Σ Γ Conv) args args') @@ -703,7 +703,7 @@ Lemma convSpec0_ind_all : (cumul_Ind _ _ _ _ _ _ _ _ Hu Hargs)) -> (forall (Γ : context) (i : inductive) (k : nat) - (u u' : list Level.t) (args args' : list term) + (u u' : Instance.t) (args args' : list term) (Hu : cumul_Construct_univ Σ Conv i k #|args| u u') (Hargs : All2 (cumulSpec0 Σ Γ Conv) args args') (_ : All2_dep (P cf Σ Γ Conv) Hargs), @@ -715,7 +715,7 @@ Lemma convSpec0_ind_all : P cf Σ Γ Conv (tSort s) (tSort s') (cumul_Sort _ _ _ _ _ Hs)) -> - (forall (Γ : context) (c : kername) (u u' : list Level.t) + (forall (Γ : context) (c : kername) (u u' : Instance.t) (Hu : cmp_universe_instance (compare_universe Σ Conv) u u'), P cf Σ Γ Conv (tConst c u) (tConst c u') (cumul_Const _ _ _ _ _ _ Hu)) -> diff --git a/pcuic/theories/PCUICEquality.v b/pcuic/theories/PCUICEquality.v index c5e22f124..897a3eba6 100644 --- a/pcuic/theories/PCUICEquality.v +++ b/pcuic/theories/PCUICEquality.v @@ -21,7 +21,7 @@ Instance All2_fold_len {A} P (Γ Δ : list A) : HasLen (All2_fold P Γ Δ) #|Γ| Implicit Types (cf : checker_flags). Definition cmp_universe_instance (cmp_univ : Universe.t -> Universe.t -> Prop) : Instance.t -> Instance.t -> Prop := - Forall2 (on_rel cmp_univ Universe.of_level). + Forall2 cmp_univ. Definition cmp_universe_instance_dep cmp_univ P' := fun {u u'} (H : cmp_universe_instance cmp_univ u u') => Forall2_dep P' H. @@ -36,8 +36,8 @@ Definition cmp_universe_instance_dep cmp_univ P' := Definition cmp_universe_variance (cmp_univ : conv_pb -> Universe.t -> Universe.t -> Prop) pb v u u' := match v with | Variance.Irrelevant => True - | Variance.Covariant => on_rel (cmp_univ pb) Universe.of_level u u' - | Variance.Invariant => on_rel (cmp_univ Conv) Universe.of_level u u' + | Variance.Covariant => cmp_univ pb u u' + | Variance.Invariant => cmp_univ Conv u u' end. Definition cmp_universe_instance_variance cmp_univ pb v u u' := @@ -84,7 +84,7 @@ Definition cmp_opt_variance cmp_univ pb v := Lemma cmp_universe_universe_variance (cmp_univ : conv_pb -> Universe.t -> Universe.t -> Prop) pb v u u' : RelationClasses.subrelation (cmp_univ Conv) (cmp_univ pb) -> - on_rel (cmp_univ Conv) Universe.of_level u u' -> cmp_universe_variance cmp_univ pb v u u'. + cmp_univ Conv u u' -> cmp_universe_variance cmp_univ pb v u u'. Proof. destruct v => //=. intros H H1; apply H, H1. diff --git a/pcuic/theories/PCUICGlobalEnv.v b/pcuic/theories/PCUICGlobalEnv.v index db9f27c14..65b411670 100644 --- a/pcuic/theories/PCUICGlobalEnv.v +++ b/pcuic/theories/PCUICGlobalEnv.v @@ -104,18 +104,25 @@ Section DeclaredInv. End DeclaredInv. +From MetaRocq.Common Require Import UniversesDec. + +Definition clean_uctx (uctx : ContextSet.t) := + (LevelSet.remove Level.lzero uctx.1, uctx.2). + Definition wf_global_uctx_invariants {cf:checker_flags} {P} Σ : on_global_env cumulSpec0 P Σ -> - global_uctx_invariants (global_uctx Σ). + global_uctx_invariants (clean_uctx (global_uctx Σ)). Proof. intros HΣ. split. - - cbn. apply global_levels_InSet. + - cbn. lsets. - unfold global_uctx. simpl. intros [[l ct] l'] Hctr. simpl in *. + rewrite levelset_add_remove. induction Σ in HΣ, l, ct, l', Hctr |- *. destruct HΣ. cbn in *. destruct o as [decls cu]. - now specialize (decls _ Hctr). + specialize (decls _ Hctr). + split; apply levelset_subset_add, decls. Qed. Lemma LevelSet_in_union_global Σ l ls : @@ -129,10 +136,10 @@ Qed. Definition wf_ext_global_uctx_invariants {cf:checker_flags} {P} Σ : on_global_env_ext cumulSpec0 P Σ -> - global_uctx_invariants (global_ext_uctx Σ). + global_uctx_invariants (clean_uctx (global_ext_uctx Σ)). Proof. intros HΣ. split. - - apply global_ext_levels_InSet. + - cbn. lsets. - destruct Σ as [Σ φ]. destruct HΣ as [HΣ Hφ]. destruct (wf_global_uctx_invariants _ HΣ) as [_ XX]. unfold global_ext_uctx, global_ext_levels, global_ext_constraints. @@ -140,8 +147,13 @@ Proof. destruct Hctr as [Hctr|Hctr]. + destruct Hφ as [_ [HH _]]. specialize (HH _ Hctr). cbn in HH. intuition auto using LevelSet_in_union_global. - + specialize (XX _ Hctr). - split; apply LevelSet.union_spec; right; apply XX. + rewrite levelset_add_remove. lsets. + rewrite levelset_add_remove. lsets. + + specialize (XX _ Hctr). cbn in XX. + rewrite !levelset_add_remove in XX. destruct XX as [Xl Xr]. + rewrite !levelset_add_remove. + rewrite levelset_add_union. + split; lsets. Qed. Lemma wf_consistent {cf:checker_flags} Σ {P} : diff --git a/pcuic/theories/PCUICParallelReductionConfluence.v b/pcuic/theories/PCUICParallelReductionConfluence.v index 711fab2ad..844d354ab 100644 --- a/pcuic/theories/PCUICParallelReductionConfluence.v +++ b/pcuic/theories/PCUICParallelReductionConfluence.v @@ -507,7 +507,7 @@ Section Rho. let ty := rho Γ a.(array_type) _ in let value := map_terms rho Γ a.(array_value) _ in let a' := {| - array_level := array_level a; + array_universe := array_universe a; array_type := ty; array_default := default; array_value := value diff --git a/pcuic/theories/PCUICProgress.v b/pcuic/theories/PCUICProgress.v index 9df7bcff6..5e2080b59 100644 --- a/pcuic/theories/PCUICProgress.v +++ b/pcuic/theories/PCUICProgress.v @@ -789,7 +789,7 @@ Proof with eauto with wcbv; try congruence. + destruct a as []; cbn in *. clear hty. solve_all. clear -hvalue0 Hargs v. - set (a := {| array_level := _ |}). + set (a := {| array_universe := _ |}). assert (All (fun x : term => ((∑ t' : term, Σ ⊢ x ⇝ᵥ t') + value Σ x))%type array_value). { solve_all. } clear hvalue0 Hargs. eapply All_or_disj in X as []. diff --git a/pcuic/theories/PCUICReduction.v b/pcuic/theories/PCUICReduction.v index d05f0449a..8b906d83e 100644 --- a/pcuic/theories/PCUICReduction.v +++ b/pcuic/theories/PCUICReduction.v @@ -17,19 +17,19 @@ Reserved Notation " Σ ;;; Γ |- t ⇝ u " (at level 50, Γ, t, u at next level) Local Open Scope type_scope. Definition set_array_default (ar : array_model term) (v : term) := - {| array_level := ar.(array_level); + {| array_universe := ar.(array_universe); array_default := v; array_type := ar.(array_type); array_value := ar.(array_value) |}. Definition set_array_type (ar : array_model term) (v : term) := - {| array_level := ar.(array_level); + {| array_universe := ar.(array_universe); array_default := ar.(array_default); array_type := v; array_value := ar.(array_value) |}. Definition set_array_value (ar : array_model term) (v : list term) := - {| array_level := ar.(array_level); + {| array_universe := ar.(array_universe); array_default := ar.(array_default); array_type := ar.(array_type); array_value := v |}. @@ -1998,7 +1998,7 @@ Section ReductionCongruence. Qed. Lemma red_primArray_congr (arr arr' : array_model term) : - array_level arr = array_level arr' -> + array_universe arr = array_universe arr' -> All2 (red Σ Γ) (array_value arr) (array_value arr') -> red Σ Γ (array_default arr) (array_default arr') -> red Σ Γ (array_type arr) (array_type arr') -> diff --git a/pcuic/theories/PCUICTyping.v b/pcuic/theories/PCUICTyping.v index caa63e6af..2cd0b0b4a 100644 --- a/pcuic/theories/PCUICTyping.v +++ b/pcuic/theories/PCUICTyping.v @@ -34,7 +34,7 @@ Fixpoint isArity T := | _ => false end. -Definition type_of_constructor mdecl (cdecl : constructor_body) (c : inductive * nat) (u : list Level.t) := +Definition type_of_constructor mdecl (cdecl : constructor_body) (c : inductive * nat) (u : Instance.t) := let mind := inductive_mind (fst c) in subst0 (inds mind u mdecl.(ind_bodies)) (subst_instance u (cstr_type cdecl)). @@ -181,8 +181,8 @@ Variant primitive_typing_hyps `{checker_flags} | prim_float_hyps f : primitive_typing_hyps typing Σ Γ (primFloat; primFloatModel f) | prim_string_hyps s : primitive_typing_hyps typing Σ Γ (primString; primStringModel s) | prim_array_hyps a - (wfl : wf_universe Σ (Universe.of_level a.(array_level))) - (hty : typing Σ Γ a.(array_type) (tSort (sType (Universe.of_level a.(array_level))))) + (wfl : wf_universe Σ a.(array_universe)) + (hty : typing Σ Γ a.(array_type) (tSort (sType a.(array_universe)))) (hdef : typing Σ Γ a.(array_default) a.(array_type)) (hvalue : All (fun x => typing Σ Γ x a.(array_type)) a.(array_value)) : primitive_typing_hyps typing Σ Γ (primArray; primArrayModel a). @@ -192,7 +192,7 @@ Equations prim_type (p : prim_val term) (cst : kername) : term := prim_type (primInt; _) cst := tConst cst []; prim_type (primFloat; _) cst := tConst cst []; prim_type (primString; _) cst := tConst cst []; -prim_type (primArray; primArrayModel a) cst := tApp (tConst cst [a.(array_level)]) a.(array_type). +prim_type (primArray; primArrayModel a) cst := tApp (tConst cst [a.(array_universe)]) a.(array_type). Transparent prim_type. Inductive typing `{checker_flags} (Σ : global_env_ext) (Γ : context) : term -> term -> Type := diff --git a/pcuic/theories/PCUICValidity.v b/pcuic/theories/PCUICValidity.v index 4479d7063..4d85d307a 100644 --- a/pcuic/theories/PCUICValidity.v +++ b/pcuic/theories/PCUICValidity.v @@ -335,12 +335,12 @@ Section Validity. depelim X0; depelim X1; simp prim_type; cbn in *. 1-3:destruct H1 as [hty hbod huniv]; eapply has_sort_isType with (s := _@[[]]); change (tSort ?s@[[]]) with (tSort s)@[[]]; rewrite <- hty; refine (type_Const _ _ _ [] _ wfΓ H0 _); rewrite huniv //. - set (s := sType (Universe.of_level (array_level a))). + set (s := sType (Universe.of_level (array_universe a))). destruct H1 as [hty' hbod huniv]. eapply has_sort_isType with s. eapply (type_App _ _ _ _ (tSort s) (tSort s)); tea; cycle 1. - + eapply (type_Const _ _ _ [array_level a]) in H0; tea. rewrite hty' in H0. cbn in H0. exact H0. - red. rewrite huniv. simpl. rtoProp; intuition eauto. eapply LevelSet.mem_spec. eapply (wfl (array_level a, 0)). cbn. lsets. + + eapply (type_Const _ _ _ [array_universe a]) in H0; tea. rewrite hty' in H0. cbn in H0. exact H0. + red. rewrite huniv. simpl. rtoProp; intuition eauto. eapply LevelSet.mem_spec. eapply (wfl (array_universe a, 0)). cbn. lsets. cbn. red. destruct check_univs => //. red. red. intros v H c. csets. + econstructor. 2: econstructor; eauto. 2: constructor; tas. all: repeat (eexists; tea; cbn). diff --git a/pcuic/theories/PCUICWcbvEval.v b/pcuic/theories/PCUICWcbvEval.v index 5b44ad5f5..8886d55df 100644 --- a/pcuic/theories/PCUICWcbvEval.v +++ b/pcuic/theories/PCUICWcbvEval.v @@ -209,8 +209,8 @@ Section Wcbv. | evalPrimArray u v def ty v' def' (ev : All2 eval v v') (ed : eval def def') : - let a := {| array_level := u; array_default := def; array_value := v; array_type := ty |} in - let a' := {| array_level := u; array_default := def'; array_value := v'; array_type := ty |} in + let a := {| array_universe := u; array_default := def; array_value := v; array_type := ty |} in + let a' := {| array_universe := u; array_default := def'; array_value := v'; array_type := ty |} in eval_primitive eval (prim_array a) (prim_array a'). Derive Signature for eval_primitive. @@ -222,8 +222,8 @@ Section Wcbv. (ev : All2 eval v v') (ed : eval def def') : All2_dep P ev -> P _ _ ed -> - let a := {| array_level := u; array_default := def; array_value := v; array_type := ty |} in - let a' := {| array_level := u; array_default := def'; array_value := v'; array_type := ty |} in + let a := {| array_universe := u; array_default := def; array_value := v; array_type := ty |} in + let a' := {| array_universe := u; array_default := def'; array_value := v'; array_type := ty |} in eval_primitive_ind eval P (prim_array a) (prim_array a') (evalPrimArray eval u v def ty v' def' ev ed). Derive Signature for eval_primitive_ind. diff --git a/pcuic/theories/PCUICWeakeningConfig.v b/pcuic/theories/PCUICWeakeningConfig.v index b7fbab671..ab0fe4188 100644 --- a/pcuic/theories/PCUICWeakeningConfig.v +++ b/pcuic/theories/PCUICWeakeningConfig.v @@ -18,7 +18,7 @@ Set Default Goal Selector "!". config.impl cf1 cf2 -> RelationClasses.subrelation (@compare_sort cf1 cs pb) (@compare_sort cf2 cs pb). Proof. - cbv [compare_sort eq_sort eq_sort_ leq_sort leq_sort_n leq_sort_n_ eq_universe leq_universe_n config.impl]. + cbv [compare_sort eq_sort eq_sort_ leq_sort leq_sort_ eq_universe leq_universe config.impl]. destruct cf1, cf2; cbn. move => H u1 u2; move: H. repeat match goal with diff --git a/pcuic/theories/PCUICWeakeningEnv.v b/pcuic/theories/PCUICWeakeningEnv.v index 4133507ba..c3b19bd0b 100644 --- a/pcuic/theories/PCUICWeakeningEnv.v +++ b/pcuic/theories/PCUICWeakeningEnv.v @@ -37,7 +37,7 @@ Ltac rename_hyp h ht ::= my_rename_hyp h ht. (** ** Constraints *) -Lemma weakening_env_global_ext_levels Σ Σ' φ (H : extends Σ Σ') l +Lemma weakening_env_global_ext_level Σ Σ' φ (H : extends Σ Σ') l : LevelSet.In l (global_ext_levels (Σ, φ)) -> LevelSet.In l (global_ext_levels (Σ', φ)). Proof. @@ -49,9 +49,17 @@ Proof. apply LevelSet.union_spec in Hl. apply LevelSet.union_spec; intuition auto. Qed. +#[global] Hint Resolve weakening_env_global_ext_level : extends. + +Lemma weakening_env_global_ext_levels Σ Σ' φ (H : extends Σ Σ') ls + : LevelSet.Subset ls (global_ext_levels (Σ, φ)) + -> LevelSet.Subset ls (global_ext_levels (Σ', φ)). +Proof. + move=> hs l /hs. now apply weakening_env_global_ext_level. +Qed. #[global] Hint Resolve weakening_env_global_ext_levels : extends. -Lemma weakening_env_global_ext_levels' Σ Σ' φ (H : extends Σ Σ') l +Lemma weakening_env_global_ext_level_mem Σ Σ' φ (H : extends Σ Σ') l : LevelSet.mem l (global_ext_levels (Σ, φ)) -> LevelSet.mem l (global_ext_levels (Σ', φ)). Proof. @@ -59,6 +67,13 @@ Proof. now eapply LevelSet.mem_spec, weakening_env_global_ext_levels. Qed. +Lemma weakening_env_global_ext_levels_subset Σ Σ' φ (H : extends Σ Σ') l + : LevelSet.subset l (global_ext_levels (Σ, φ)) + -> LevelSet.subset l (global_ext_levels (Σ', φ)). +Proof. + rewrite ![is_true _]LevelSet.subset_spec. now apply weakening_env_global_ext_levels. +Qed. + Lemma weakening_env_global_ext_constraints Σ Σ' φ (H : extends Σ Σ') : UnivConstraintSet.Subset (global_ext_constraints (Σ, φ)) (global_ext_constraints (Σ', φ)). @@ -165,7 +180,7 @@ Proof. destruct ctrs; tas. destruct X as (H0 & H1 & H2); repeat split; tas. - eapply forallb_Forall in H0; eapply forallb_Forall, Forall_impl; tea. - intros x ?; now eapply weakening_env_global_ext_levels'. + intros x ?; now eapply weakening_env_global_ext_levels_subset. - eapply valid_subset; tea; now eapply weakening_env_global_ext_constraints. Qed. @@ -237,7 +252,7 @@ Lemma declared_cstr_levels_sub l l' c : declared_univ_cstr_levels l c -> declared_univ_cstr_levels l' c. Proof. intros sub; unfold declared_univ_cstr_levels. - destruct c as [[l1 eq] l2]. intuition auto. + destruct c as [[l1 eq] l2]. firstorder. Qed. Lemma on_udecl_on_udecl_prop (Σ : global_env) ctx : @@ -369,6 +384,7 @@ Qed. *) (** ** Back to universes *) +Instance hr : RelationClasses.RewriteRelation LevelSet.Subset := {}. Lemma weaken_lookup_on_global_env' Σ c decl : wf Σ -> @@ -386,60 +402,17 @@ Proof using P Pcmp cf. destruct o as [H1 [H2 [H3 H4]]]. repeat split. clear -H2. intros [[? ?] ?] Hc. specialize (H2 _ Hc). destruct H2 as [H H']. simpl. split. - * apply LevelSet.union_spec in H. apply LevelSet.union_spec. - destruct H; [now left|right]; auto. - * apply LevelSet.union_spec in H'. apply LevelSet.union_spec. - destruct H'; [now left|right]; auto. - (*+ revert H3. case_eq (universes_decl_of_decl d); trivial. - intros ctx eq Hctx. repeat split. - * auto. - * intros l Hl. simpl. replace (monomorphic_levels_decl d) with ctx.1. - -- apply in_global_levels. apply LevelSet.union_spec; now left. - -- clear -eq. destruct d as [c|c]; cbn in *. - all: destruct c; cbn in *; now rewrite eq. - * simpl. replace (monomorphic_constraints_decl d) with ctx.2. - -- intros c Hc; apply UnivConstraintSet.union_spec; now left. - -- clear -eq. destruct d as [c|c]; cbn in *. - all: destruct c; cbn in *; now rewrite eq. - * clear -eq H4. destruct H4 as [v Hv]. exists v. - intros c Hc; apply (Hv c). - apply UnivConstraintSet.union_spec in Hc; destruct Hc as [Hc|Hc]. - 2: apply UnivConstraintSet.union_spec in Hc; destruct Hc as [Hc|Hc]. - -- apply UnivConstraintSet.union_spec. simpl in *. left; now rewrite eq. - -- apply UnivConstraintSet.union_spec; left. simpl. - destruct d as [[? ? []]|[? ? ? ? []]]; simpl in *; tas; - now apply UnivConstraintSet.empty_spec in Hc. - -- apply UnivConstraintSet.union_spec; now right.*) + * rewrite H. lsets. + * rewrite H'. lsets. - specialize (IHwfΣ HH). revert IHwfΣ o; clear. generalize (universes_decl_of_decl decl); intros d' HH Hd. unfold on_udecl_prop in *. intros [[? ?] ?] Hc. specialize (HH _ Hc). destruct HH as [H' H'']. simpl. split. - * apply LevelSet.union_spec in H'. apply LevelSet.union_spec. - destruct H'; [now left|right]; auto. - * apply LevelSet.union_spec in H''. apply LevelSet.union_spec. - destruct H''; [now left|right]; auto. - - (*+ destruct d'; trivial. repeat split. - * destruct H2; auto. - * intros l Hl. apply H2 in Hl. - apply LevelSet.union_spec; now right. - * intros c Hc. apply H2 in Hc. - apply UnivConstraintSet.union_spec; now right. - * destruct Hd as [_ [_ [_ Hd]]]; cbn in Hd. - destruct Hd as [v Hv]. exists v. intros c Hc; apply Hv; clear v Hv. - apply UnivConstraintSet.union_spec in Hc; destruct Hc as [Hc|Hc]; simpl in *. - 2: apply UnivConstraintSet.union_spec in Hc; destruct Hc as [Hc|Hc]; - simpl in *. - -- apply H2 in Hc. apply UnivConstraintSet.union_spec; now right. - -- clear -Hc. destruct d as [[? ? []]|[? ? ? ? []]]; cbn in *. - all: try (apply UnivConstraintSet.empty_spec in Hc; contradiction). - all: apply UnivConstraintSet.union_spec; now left. - -- apply UnivConstraintSet.union_spec; now right.*) + * rewrite H'. lsets. + * rewrite H''; lsets. Qed. - - Definition weaken_env_prop_full_gen (R : global_env_ext -> global_env_ext -> Type) (P : global_env_ext -> context -> term -> term -> Type) := diff --git a/pcuic/theories/Syntax/PCUICOnFreeVars.v b/pcuic/theories/Syntax/PCUICOnFreeVars.v index 828ee2cd1..9baef4abc 100644 --- a/pcuic/theories/Syntax/PCUICOnFreeVars.v +++ b/pcuic/theories/Syntax/PCUICOnFreeVars.v @@ -775,7 +775,7 @@ Proof. - eapply on_free_vars_subst_gen. 1:eapply on_free_vars_extended_subst; eauto. rewrite -> on_free_vars_lift. eauto. - - len. rewrite /substP /= /strengthenP /=. + - autorewrite with len; cbn -[strengthenP]. rewrite /substP /= /strengthenP /=. intros i. simpl. rewrite /shiftnP. repeat nat_compare_specs => /= //. rewrite Nat.sub_0_r. rewrite /orP. @@ -1358,9 +1358,9 @@ Lemma term_on_free_vars_ind : (forall p (t u : term), on_free_vars p t -> P p t -> on_free_vars p u -> P p u -> P p (tApp t u)) -> - (forall p s (u : list Level.t), P p (tConst s u)) -> - (forall p (i : inductive) (u : list Level.t), P p (tInd i u)) -> - (forall p (i : inductive) (c : nat) (u : list Level.t), P p (tConstruct i c u)) -> + (forall p s (u : Instance.t), P p (tConst s u)) -> + (forall p (i : inductive) (u : Instance.t), P p (tInd i u)) -> + (forall p (i : inductive) (c : nat) (u : Instance.t), P p (tConstruct i c u)) -> (forall p (ci : case_info) (pred : predicate term) discr brs, All (on_free_vars p) pred.(pparams) -> All (P p) pred.(pparams) -> diff --git a/pcuic/theories/Syntax/PCUICPosition.v b/pcuic/theories/Syntax/PCUICPosition.v index 8ce22c583..233e4383d 100644 --- a/pcuic/theories/Syntax/PCUICPosition.v +++ b/pcuic/theories/Syntax/PCUICPosition.v @@ -1026,10 +1026,10 @@ Variant stack_entry : Type := | LetIn_bd (na : aname) (B t : term) | LetIn_ty (na : aname) (b t : term) | LetIn_in (na : aname) (b B : term) -| PrimArray_ty (l : Level.t) (l : list term) (def : term) -| PrimArray_def (l : Level.t) (l : list term) (ty : term) +| PrimArray_ty (l : Universe.t) (l : list term) (def : term) +| PrimArray_def (l : Universe.t) (l : list term) (ty : term) (* Hole in one of the values *) -| PrimArray_val (l : Level.t) (bef : list term) (after : list term) (def : term) (ty : term). +| PrimArray_val (l : Universe.t) (bef : list term) (after : list term) (def : term) (ty : term). Definition stack := list stack_entry. @@ -1125,9 +1125,9 @@ Definition fill_hole (t : term) (se : stack_entry) : term := | LetIn_bd na B u => tLetIn na t B u | LetIn_ty na b u => tLetIn na b t u | LetIn_in na b B => tLetIn na b B t - | PrimArray_def l v ty => tPrim (primArray; primArrayModel {| array_level := l; array_value := v; array_default := t; array_type := ty |}) - | PrimArray_ty l v def => tPrim (primArray; primArrayModel {| array_level := l; array_value := v; array_default := def; array_type := t |}) - | PrimArray_val l bef after def ty => tPrim (primArray; primArrayModel {| array_level := l; array_value := bef ++ (t :: after); array_default := def; array_type := ty |}) + | PrimArray_def l v ty => tPrim (primArray; primArrayModel {| array_universe := l; array_value := v; array_default := t; array_type := ty |}) + | PrimArray_ty l v def => tPrim (primArray; primArrayModel {| array_universe := l; array_value := v; array_default := def; array_type := t |}) + | PrimArray_val l bef after def ty => tPrim (primArray; primArrayModel {| array_universe := l; array_value := bef ++ (t :: after); array_default := def; array_type := ty |}) end. (* Not using fold_left here to get the right unfolding behavior *) diff --git a/pcuic/theories/Syntax/PCUICReflect.v b/pcuic/theories/Syntax/PCUICReflect.v index df0c22c06..73539f700 100644 --- a/pcuic/theories/Syntax/PCUICReflect.v +++ b/pcuic/theories/Syntax/PCUICReflect.v @@ -28,7 +28,7 @@ Local Ltac term_dec_tac term_dec := | u : sort, u' : sort |- _ => fcase (eq_dec u u') | x : Instance.t, y : Instance.t |- _ => fcase (eq_dec x y) - | x : list Level.t, y : Instance.t |- _ => + | x : Instance.t, y : Instance.t |- _ => fcase (eq_dec x y) | x : list aname, y : list aname |- _ => fcase (eq_dec x y) | n : nat, m : nat |- _ => fcase (Nat.eq_dec n m) diff --git a/pcuic/theories/Typing/PCUICClosedTyp.v b/pcuic/theories/Typing/PCUICClosedTyp.v index 3251a22fe..c09dc4411 100644 --- a/pcuic/theories/Typing/PCUICClosedTyp.v +++ b/pcuic/theories/Typing/PCUICClosedTyp.v @@ -857,9 +857,9 @@ Lemma term_closedn_list_ind : (forall k (n : aname) (t : term), P k t -> forall t0 : term, P k t0 -> forall t1 : term, P (S k) t1 -> P k (tLetIn n t t0 t1)) -> (forall k (t u : term), P k t -> P k u -> P k (tApp t u)) -> - (forall k s (u : list Level.t), P k (tConst s u)) -> - (forall k (i : inductive) (u : list Level.t), P k (tInd i u)) -> - (forall k (i : inductive) (n : nat) (u : list Level.t), P k (tConstruct i n u)) -> + (forall k s (u : Instance.t), P k (tConst s u)) -> + (forall k (i : inductive) (u : Instance.t), P k (tInd i u)) -> + (forall k (i : inductive) (n : nat) (u : Instance.t), P k (tConstruct i n u)) -> (forall k (ci : case_info) (p : predicate term), tCasePredProp_k P k p -> forall t0 : term, P k t0 -> forall l : list (branch term), @@ -975,9 +975,9 @@ Lemma term_noccur_between_list_ind : (forall k n (na : aname) (t : term), P k n t -> forall t0 : term, P k n t0 -> forall t1 : term, P (S k) n t1 -> P k n (tLetIn na t t0 t1)) -> (forall k n (t u : term), P k n t -> P k n u -> P k n (tApp t u)) -> - (forall k n s (u : list Level.t), P k n (tConst s u)) -> - (forall k n (i : inductive) (u : list Level.t), P k n (tInd i u)) -> - (forall k n (i : inductive) (c : nat) (u : list Level.t), P k n (tConstruct i c u)) -> + (forall k n s (u : Instance.t), P k n (tConst s u)) -> + (forall k n (i : inductive) (u : Instance.t), P k n (tInd i u)) -> + (forall k n (i : inductive) (c : nat) (u : Instance.t), P k n (tConstruct i c u)) -> (forall k n (ci : case_info) (p : predicate term), tCasePredProp_k (fun k' => P k' n) k p -> forall t0 : term, P k n t0 -> forall l : list (branch term), diff --git a/safechecker/theories/PCUICEqualityDec.v b/safechecker/theories/PCUICEqualityDec.v index fbb6e1f0e..6a86b4a1d 100644 --- a/safechecker/theories/PCUICEqualityDec.v +++ b/safechecker/theories/PCUICEqualityDec.v @@ -79,7 +79,7 @@ Notation eqb_context_upto_names := (forallb2 eqb_decl_upto_names). Fixpoint eqb_term_upto_univ_napp (cmpu : conv_pb -> Universe.t -> Universe.t -> bool) (cmps : conv_pb -> sort -> sort -> bool) - (gen_compare_global_instance : conv_pb -> global_reference -> nat -> list Level.t -> list Level.t -> bool) + (gen_compare_global_instance : conv_pb -> global_reference -> nat -> Instance.t -> Instance.t -> bool) pb napp (u v : term) : bool := match u, v with | tRel n, tRel m => @@ -450,7 +450,7 @@ Qed. Transparent eqb_prim_val eqb_prim_model. Lemma reflect_eq_term_upto_univ Σ (p : Universe.t -> bool) (q : nat -> term -> bool) cmpu cmps cmp_universe cmp_sort - (gen_compare_global_instance : conv_pb -> global_reference -> nat -> list Level.t -> list Level.t -> bool) + (gen_compare_global_instance : conv_pb -> global_reference -> nat -> Instance.t -> Instance.t -> bool) pb napp : (forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) -> (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> @@ -531,7 +531,7 @@ Proof. Qed. Lemma eqb_term_upto_univ_impl Σ (p : Universe.t -> bool) (q : nat -> term -> bool) cmpu cmps cmp_universe cmp_sort - (gen_compare_global_instance : conv_pb -> global_reference -> nat -> list Level.t -> list Level.t -> bool) + (gen_compare_global_instance : conv_pb -> global_reference -> nat -> Instance.t -> Instance.t -> bool) pb napp : (forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) -> (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> @@ -567,7 +567,7 @@ Proof. Defined. Definition eqb_term_upto_univ_proper Σ cmpu cmpu' cmps cmps' - (gen_compare_global_instance gen_compare_global_instance' : conv_pb -> global_reference -> nat -> list Level.t -> list Level.t -> bool) + (gen_compare_global_instance gen_compare_global_instance' : conv_pb -> global_reference -> nat -> Instance.t -> Instance.t -> bool) pb napp (t u : term) : (forall pb u u', wf_universe Σ u -> wf_universe Σ u' -> cmpu pb u u' = cmpu' pb u u') -> (forall pb s s', wf_sort Σ s -> wf_sort Σ s' -> cmps pb s s' = cmps' pb s s') -> @@ -720,7 +720,7 @@ Proof. case: eqb_annot_reflect => //. Qed. Section reflectContext. Context Σ (p : Universe.t -> bool) (q : nat -> term -> bool) cmpu cmps cmp_universe cmp_sort - (gen_compare_global_instance : conv_pb -> global_reference -> nat -> list Level.t -> list Level.t -> bool) + (gen_compare_global_instance : conv_pb -> global_reference -> nat -> Instance.t -> Instance.t -> bool) pb (hu : forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) (hu' : forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) @@ -765,7 +765,7 @@ Section reflectContext. End reflectContext. Definition eqb_ctx_gen_proper Σ cmpu cmpu' cmps cmps' - (gen_compare_global_instance gen_compare_global_instance' : conv_pb -> global_reference -> nat -> list Level.t -> list Level.t -> bool) + (gen_compare_global_instance gen_compare_global_instance' : conv_pb -> global_reference -> nat -> Instance.t -> Instance.t -> bool) pb : (forall pb u u', wf_universe Σ u -> wf_universe Σ u' -> cmpu pb u u' = cmpu' pb u u') -> (forall pb s s', wf_sort Σ s -> wf_sort Σ s' -> cmps pb s s' = cmps' pb s s') -> diff --git a/safechecker/theories/PCUICSafeConversion.v b/safechecker/theories/PCUICSafeConversion.v index a6b23f728..b09a9ba52 100644 --- a/safechecker/theories/PCUICSafeConversion.v +++ b/safechecker/theories/PCUICSafeConversion.v @@ -3273,10 +3273,10 @@ Equations (noeqns) isconv_array_values_aux hx aux pre1 pre2 (t1 :: post1) (t2 :: post2) eq1 eq2 with isconv_red_raw Conv - t1 (PrimArray_val a1.(array_level) + t1 (PrimArray_val a1.(array_universe) pre1 post1 a1.(array_default) a1.(array_type) :: π1) - t2 (PrimArray_val a2.(array_level) + t2 (PrimArray_val a2.(array_universe) pre2 post2 a2.(array_default) a2.(array_type) :: π2) aux := { @@ -3590,12 +3590,12 @@ Equations (noeqns) isconv_array_values_aux { | @exist true eqf := yes | @exist false neqf := no (DistinctPrimValues (Γ ,,, stack_context π1) p (Γ ,,, stack_context π2) p') } | (primArray; primArrayModel a) | (primArray; primArrayModel a') - with inspect (abstract_env_compare_universe X Conv (Universe.of_level (array_level a)) (Universe.of_level (array_level a'))) := + with inspect (abstract_env_compare_universe X Conv (Universe.of_level (array_universe a)) (Universe.of_level (array_universe a'))) := { | @exist false neql := no (ArrayNotConvertibleLevels (Γ ,,, stack_context π1) a (Γ ,,, stack_context π2) a') - | @exist true eql with isconv_red_raw Conv (array_type a) (PrimArray_ty a.(array_level) a.(array_value) a.(array_default) :: π1) - (array_type a') (PrimArray_ty a'.(array_level) a'.(array_value) a'.(array_default) :: π2) aux := { - | Success convdiscrty with isconv_red_raw Conv (array_default a) (PrimArray_def a.(array_level) a.(array_value) a.(array_type) :: π1) - (array_default a') (PrimArray_def a'.(array_level) a'.(array_value) a'.(array_type) :: π2) aux := { + | @exist true eql with isconv_red_raw Conv (array_type a) (PrimArray_ty a.(array_universe) a.(array_value) a.(array_default) :: π1) + (array_type a') (PrimArray_ty a'.(array_universe) a'.(array_value) a'.(array_default) :: π2) aux := { + | Success convdiscrty with isconv_red_raw Conv (array_default a) (PrimArray_def a.(array_universe) a.(array_value) a.(array_type) :: π1) + (array_default a') (PrimArray_def a'.(array_universe) a'.(array_value) a'.(array_type) :: π2) aux := { | Success convdiscrdef with isconv_array_values Γ a π1 _ a' π2 _ hx aux := { | Success convdiscrval := yes | Error e h := no (ArrayNotConvertibleValues (Γ ,,, stack_context π1) a (Γ ,,, stack_context π2) a' e) diff --git a/safechecker/theories/PCUICTypeChecker.v b/safechecker/theories/PCUICTypeChecker.v index eb84e1f4d..0a733177e 100644 --- a/safechecker/theories/PCUICTypeChecker.v +++ b/safechecker/theories/PCUICTypeChecker.v @@ -1427,8 +1427,8 @@ Section Typecheck. | (primFloat; primFloatModel f) := ret _ | (primString; primStringModel f) := ret _ | (primArray; primArrayModel a) := - check_eq_true (abstract_env_ext_wf_universeb X (Universe.of_level a.(array_level))) (Msg "primitive array level is not well-formed") ;; - check_type <- bdcheck infer Γ wfΓ a.(array_type) (tSort (sType (Universe.of_level a.(array_level)))) _ ;; + check_eq_true (abstract_env_ext_wf_universeb X (Universe.of_level a.(array_universe))) (Msg "primitive array level is not well-formed") ;; + check_type <- bdcheck infer Γ wfΓ a.(array_type) (tSort (sType (Universe.of_level a.(array_universe)))) _ ;; check_default <- bdcheck infer Γ wfΓ a.(array_default) a.(array_type) _ ;; check_values <- make_All (fun x => bdcheck infer Γ wfΓ x a.(array_type) _) a.(array_value) ;; ret _. @@ -1453,7 +1453,7 @@ Section Typecheck. now move/@wf_universe_reflect: i. - specialize (check_type _ wfΣ) as []. specialize (check_default _ wfΣ) as []. - assert (∥ Σ;;; Γ |- array_type a : tSort (sType (Universe.of_level (array_level a))) ∥) as []. + assert (∥ Σ;;; Γ |- array_type a : tSort (sType (Universe.of_level (array_universe a))) ∥) as []. { sq. eapply checking_typing in X0; eauto. erewrite <- abstract_env_ext_wf_universeb_correct in i; tea. eapply has_sort_isType; eapply type_Sort; eauto. now move/@wf_universe_reflect: i. } diff --git a/template-pcuic/theories/PCUICToTemplate.v b/template-pcuic/theories/PCUICToTemplate.v index 1ada6b5ab..2a16a9485 100644 --- a/template-pcuic/theories/PCUICToTemplate.v +++ b/template-pcuic/theories/PCUICToTemplate.v @@ -18,7 +18,7 @@ Definition trans_prim (trans : PCUICAst.term -> Ast.term) (t : prim_val) : Ast.t | primIntModel i => Ast.tInt i | primFloatModel f => Ast.tFloat f | primStringModel s => Ast.tString s - | primArrayModel a => Ast.tArray (array_level a) (map trans (array_value a)) (trans (array_default a)) (trans (array_type a)) + | primArrayModel a => Ast.tArray (array_universe a) (map trans (array_value a)) (trans (array_default a)) (trans (array_type a)) end. Definition trans_predicate (t : PCUICAst.predicate Ast.term) : predicate Ast.term := diff --git a/template-pcuic/theories/TemplateMonadToPCUIC.v b/template-pcuic/theories/TemplateMonadToPCUIC.v index c7bfdbe63..e60641cb0 100644 --- a/template-pcuic/theories/TemplateMonadToPCUIC.v +++ b/template-pcuic/theories/TemplateMonadToPCUIC.v @@ -168,7 +168,7 @@ Section with_tc. v' <- monad_map@{t u t t} monad_trans' v ;; d' <- monad_trans' d ;; ty' <- monad_trans' ty ;; - ret (tPrim ((primArray; primArrayModel {| array_level := l; array_value := v'; array_default := d'; array_type := ty' |}))) + ret (tPrim ((primArray; primArrayModel {| array_universe := l; array_value := v'; array_default := d'; array_type := ty' |}))) end. End with_helper. End with_tc. diff --git a/template-pcuic/theories/TemplateToPCUIC.v b/template-pcuic/theories/TemplateToPCUIC.v index 78549cbba..ab3b5d76b 100644 --- a/template-pcuic/theories/TemplateToPCUIC.v +++ b/template-pcuic/theories/TemplateToPCUIC.v @@ -105,7 +105,7 @@ Section Trans. | Ast.tFloat n => tPrim (primFloat; primFloatModel n) | Ast.tString n => tPrim (primString; primStringModel n) | Ast.tArray l v d ty => tPrim (primArray; primArrayModel - {| array_level := l; + {| array_universe := l; array_value := List.map trans v; array_default := trans d; array_type := trans ty |}) diff --git a/template-pcuic/theories/TemplateToPCUICCorrectness.v b/template-pcuic/theories/TemplateToPCUICCorrectness.v index 3401838fc..d7b31c169 100644 --- a/template-pcuic/theories/TemplateToPCUICCorrectness.v +++ b/template-pcuic/theories/TemplateToPCUICCorrectness.v @@ -2513,7 +2513,7 @@ Proof. intros []; split => //; destruct cdecl as [ty [?|] ?]; cbn in *; subst; auto => //. + constructor. - - cbn. set (a := {| array_level := _ |}). + - cbn. set (a := {| array_universe := _ |}). replace (tApp (tConst prim_ty [u]) (trans (trans_global_env Σ.1) ty)) with (prim_type (primArray; primArrayModel a) prim_ty) by now simp prim_type. econstructor; cbn; eauto. + rewrite trans_env_retroknowledge //. @@ -2525,7 +2525,7 @@ Proof. now rewrite H1 H2 H3 /= in H0 |- *. * rewrite /trans_constant_body in H0 |- *. now rewrite H1 H2 H3 /= in H0 |- *. - + constructor; eauto. cbn [array_level a]. eapply validity in X1; eauto. + + constructor; eauto. cbn [array_universe a]. eapply validity in X1; eauto. eapply PCUICWfUniverses.isType_wf_universes in X1. cbn [trans PCUICWfUniverses.wf_universes] in X1. unfold PCUICWfUniverses.wf_universes in X1. cbn [PCUICWfUniverses.on_universes Sort.on_sort s] in X1. move: X1. case: PCUICWfUniverses.wf_universe_reflect => //; eauto. eauto. From 2f16fb182dbc399d616516a5c3542907bf6d087f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 5 Nov 2025 01:29:42 +0100 Subject: [PATCH 121/164] WIP on univ substitution --- common/theories/Universes.v | 42 ++- .../Conversion/PCUICUnivSubstitutionConv.v | 282 +++++++++++------- pcuic/theories/PCUICWeakeningEnv.v | 2 +- 3 files changed, 213 insertions(+), 113 deletions(-) diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 7c782c012..7cb6fc076 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -2599,17 +2599,21 @@ fun u e => match e with end end. -Definition subst_instance_level_expr (u : Instance.t) (l : LevelExpr.t) : Universe.t := +Definition subst_instance_level (u : Instance.t) (l : Level.t) : Universe.t := match l with - | (Level.lzero, _) - | (Level.level _, _) => Universe.make l - | (Level.lvar n, k) => + | Level.lzero + | Level.level _ => Universe.of_level l + | Level.lvar n => match nth_error u n with - | Some l => Universe.plus k l - | None => Universe.plus k Universe.zero + | Some u => u + | None => Universe.zero end end. + +Definition subst_instance_level_expr (u : Instance.t) (l : LevelExpr.t) : Universe.t := + Universe.plus l.2 (subst_instance_level u l.1). + #[global] Instance subst_level_instance_universe : UnivLevelSubst Universe.t := fun u => Universe.map (subst_level_instance_level_expr u). @@ -2717,6 +2721,12 @@ Section UniverseClosedSubst. destruct l; cbnr. discriminate. Qed. + Lemma closedu_subst_instance_level u e + : closedu_level 0 e -> subst_instance_level u e = Universe.of_level e. + Proof. + destruct e; cbn => //. + Qed. + Lemma closedu_subst_level_instance_level_expr u e : closedu_level_expr 0 e -> subst_level_instance_level_expr u e = e. Proof. @@ -2727,8 +2737,15 @@ Section UniverseClosedSubst. Lemma closedu_subst_instance_level_expr u e : closedu_level_expr 0 e -> subst_instance_level_expr u e = Universe.make e. Proof. - intros. - destruct e as [t b]. destruct t;cbnr. discriminate. + destruct e as [t b]. move/(closedu_subst_instance_level u); cbn. + rewrite /subst_instance_level_expr => ->. cbn. + rewrite /Universe.plus /Universe.of_level. cbn. + apply Universe.equal_exprsets => l. cbn. + rewrite LevelExprSet.add_spec LevelExprSet.singleton_spec. + split. + * intros [->|le]; cbn. rewrite /LevelExpr.add /LevelExpr.make. cbn. now rewrite Nat.add_0_r. + now apply LevelExprSet.empty_spec in le. + * intros ->. left. rewrite /LevelExpr.add /LevelExpr.make. cbn. now rewrite Nat.add_0_r. Qed. Lemma closedu_subst_level_instance_universe u e @@ -2928,9 +2945,12 @@ Section SubstInstanceClosed. case_eq (nth_error u n); cbnr. intros u' Hl; cbnr. apply nth_error_In in Hl. cbn in Hl. intros hn. - unfold closedu_instance in Hcl. - red in Hcl; rewrite -> forallb_forall in Hcl. specialize (Hcl _ Hl). - now rewrite -closedu_universe_plus. + rewrite -closedu_universe_plus. cbn. + destruct nth_error eqn:hnth => //. + eapply forallb_forall in Hcl; tea. + now eapply nth_error_In. + unfold subst_instance_level_expr. cbn. + intros ->. now cbn. Qed. Lemma subst_instance_universe_closedu s diff --git a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v index 2cd34fad5..96a6ed616 100644 --- a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v +++ b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v @@ -23,20 +23,23 @@ Create HintDb univ_subst. Local Ltac aa := rdest; eauto with univ_subst. -Import Universes. Import Universe.NES. +Import Universes. Lemma subst_instance_level_expr_val {u l v} v' (H1 : forall s, valuation_mono v s = valuation_mono v' s) (H2 : forall n, val v (nth n u Universe.zero) = valuation_poly v' n) : val v (subst_instance_level_expr u l) = val v' l. Proof. - destruct l as [l k]; cbn. destruct l; cbn; try congruence. cbn. - have hn := nth_nth_error n u Universe.zero. - move: (H2 n); rewrite hn. - destruct nth_error eqn:he => //. - * intros <-. rewrite val_plus //. lia. - * intros <-. cbn. lia. + destruct l as [l k]; cbn. destruct l; cbn; try congruence. + - cbn. lia. + - rewrite H1. lia. + - rewrite /subst_instance_level_expr //=. + have hn := nth_nth_error n u Universe.zero. + move: (H2 n); rewrite hn. + destruct nth_error eqn:he => //. + * intros <-. rewrite val_plus //. lia. + * intros <-. cbn. lia. Qed. Lemma subst_instance_universe_val u l v v' @@ -193,10 +196,12 @@ Proof. destruct e as [[] b]; cbnr. case_eq (nth_error u1 n). - intros l1 X. eapply Forall2_nth_error_Some_l in hu; tea. + rewrite /subst_instance_level_expr //=. destruct hu as [l2 [-> H2]]. specialize (H2 v Hv). - cbn in *. rewrite !val_plus. lia. + cbn in *. rewrite !val_plus X. lia. - intros X. eapply Forall2_nth_error_None_l in hu; tea. + rewrite /subst_instance_level_expr //= X. destruct (nth_error u2 n); [discriminate|reflexivity]. } simpl. move: exprs. @@ -217,10 +222,12 @@ Proof. destruct e as [[] b]; cbnr. case_eq (nth_error u1 n). - intros l1 X. eapply Forall2_nth_error_Some_l in hu; tea. + rewrite /subst_instance_level_expr //= X. destruct hu as [l2 [-> H2]]. specialize (H2 v Hv). cbn in *. rewrite !val_plus; lia. - intros X. eapply Forall2_nth_error_None_l in hu; tea. + rewrite /subst_instance_level_expr //= X. destruct (nth_error u2 n); [discriminate|reflexivity]. } simpl. move: exprs. @@ -259,41 +266,118 @@ Global Instance subst_instance_prod {A B} `(UnivSubst A) `(UnivSubst B) Global Instance subst_instance_nat : UnivSubst nat := fun _ n => n. -Lemma subst_instance_level_two u1 u2 l : - subst_instance_universe u1 (subst_instance_level_expr u2 l) - = subst_instance_level_expr (subst_instance u1 u2) l. +Lemma subst_instance_level_expr_make u l : + subst_instance_level_expr u l = Universe.plus l.2 (subst_instance_level u l.1). Proof. - destruct l; cbn; try reflexivity. - unfold subst_instance. - rewrite <- (map_nth (subst_instance_level u1)); reflexivity. + destruct l; simpl; auto. Qed. -Lemma subst_instance_level_expr_two u1 u2 e : - subst_instance_level_expr u1 (subst_instance_level_expr u2 e) - = subst_instance_level_expr (subst_instance u1 u2) e. +Lemma plus_plus n m u : Universe.plus n (Universe.plus m u) = Universe.plus (n + m) u. Proof. - destruct e as [[] b]; cbnr. - unfold subst_instance. erewrite nth_error_map. - destruct nth_error; cbnr. - destruct t; cbnr. - rewrite nth_nth_error. destruct nth_error; cbnr. + apply equal_exprsets => -[l k]. rewrite /Universe.plus. + rewrite Universe.map_spec. + setoid_rewrite Universe.map_spec. + split. + - move=> -[] e [] [] e1 [] hin -> ->. + exists e1. split => //. rewrite /LevelExpr.add //=. lia_f_equal. + - move=> -[] [l' k'] [] hin he. noconf he. + exists (l', m + k'). rewrite /LevelExpr.add. + split. + * eexists; split; trea. lia_f_equal. + * cbn. lia_f_equal. +Qed. + +Lemma subst_instance_level_expr_add i n u : + subst_instance_level_expr i (LevelExpr.add n u) = Universe.plus n (subst_instance_level_expr i u). +Proof. + apply equal_exprsets => -[l k']; destruct u as [[] k]. + 1-2:cbn; rewrite ?LevelExprSet.singleton_spec ?LevelExprSet.add_spec /LevelExpr.add //=. + - firstorder; rewrite H; left; lia_f_equal. + - firstorder; rewrite H; left; lia_f_equal. + - rewrite /LevelExpr.add. cbn -[subst_instance_level_expr Universe.plus]. + rewrite !subst_instance_level_expr_make plus_plus. cbn. reflexivity. +Qed. + +Lemma subst_instance_universe_plus i n u : + subst_instance_universe i (Universe.plus n u) = Universe.plus n (subst_instance_universe i u). +Proof. + apply equal_exprsets => -[l k]; rewrite /subst_instance_universe. + rewrite /Universe.concat_map Universe.fold_union_spec. + rewrite Universe.map_spec. setoid_rewrite Universe.map_spec. + setoid_rewrite Universe.fold_union_spec. firstorder. + - subst. destruct x0; noconf H1. destruct x1. cbn in H0. cbn. + exists (t0, n1 + n0). + split => //. + * eexists; split; trea. + apply Universe.map_spec. exists (t0, n0) => //. + * rewrite /LevelExpr.add //=. lia_f_equal. + - destruct x; noconf H0. + destruct x0. + rewrite subst_instance_level_expr_make in H1. + apply Universe.map_spec in H1 as [? []]. + destruct x; noconf H1. + exists (t1, n + n1). split. + * eexists; split; trea. rewrite /LevelExpr.add. lia_f_equal. + * cbn. eexists. split. + + exact H0. + + cbn. rewrite /LevelExpr.add. cbn. lia_f_equal. +Qed. + +Lemma subst_instance_level_expr_two u1 u2 (l : LevelExpr.t) : + subst_instance_universe u1 (subst_instance_level_expr u2 l) + = subst_instance_level_expr (subst_instance u1 u2) l. +Proof. + destruct l as [[] k]; cbn; try reflexivity. + - rewrite !subst_instance_level_expr_make. + cbn. now rewrite Nat.add_0_r. + - rewrite !subst_instance_level_expr_make. + cbn. now rewrite Nat.add_0_r. + - rewrite !subst_instance_level_expr_make. + cbn -[subst_instance_level]. + rewrite subst_instance_universe_plus. f_equal. + cbn. + rewrite nth_error_map. + destruct nth_error => //=. + apply equal_exprsets => l. rewrite Universe.fold_union_spec. + rewrite !LevelExprSet.singleton_spec. + setoid_rewrite Universe.map_spec. + setoid_rewrite LevelExprSet.singleton_spec. + split. + * intros [le' [hin hs]]. subst le'. + destruct hs as [e []]. subst l. cbn. + apply LevelExprSet.singleton_spec in H. + subst e. reflexivity. + * move=> ->. + exists (LevelExpr.make Level.lzero). split => //. + exists (LevelExpr.make Level.lzero). split => //. + apply LevelExprSet.singleton_spec. reflexivity. Qed. -Lemma subst_instance_univ0_two u1 u2 exprs : - subst_instance_universe u1 (subst_instance_universe u2 exprs) - = subst_instance_universe (subst_instance u1 u2) exprs. +Lemma subst_instance_universe_sup i (u u' : Universe.t) : + (u ∪ u')@[i]%nes = (u@[i] ∪ u'@[i])%nes. Proof. - unfold subst_instance_universe. - eapply eq_univ'. - intro l; split; intro Hl; apply map_spec in Hl as [l' [H1 H2]]; - apply map_spec; subst. - - apply map_spec in H1 as [l'' [H1 H2]]; subst. - eexists; split; tea. apply subst_instance_level_expr_two. - - eexists; split. 2: symmetry; eapply subst_instance_level_expr_two. - apply map_spec. eexists; split; tea; reflexivity. + apply equal_exprsets => l. + rewrite Universe.fold_union_spec. + cbn. rewrite LevelExprSet.union_spec. + rewrite !Universe.fold_union_spec. + setoid_rewrite Universe.map_spec. + setoid_rewrite LevelExprSet.union_spec. + firstorder. +Qed. + +Lemma subst_instance_univ0_two u1 u2 (exprs : Universe.t) : + exprs@[u2]@[u1] = exprs@[u2@[u1]]. +Proof. + move: exprs; apply elim. + - intros le. cbn. + apply subst_instance_level_expr_two. + - intros le x eq hnin. + rewrite [_@[u2]]add_subst //= [_@[u2@[u1]]]add_subst. + rewrite -subst_instance_level_expr_two -[x@[u2@[u1]]]eq. + rewrite -[union (subst_instance_universe u1 (subst_instance_level_expr u2 le)) _](subst_instance_universe_sup u1). + reflexivity. Qed. - Lemma subst_instance_univ_two u1 u2 s : subst_instance_sort u1 (subst_instance_sort u2 s) = subst_instance_sort (subst_instance u1 u2) s. @@ -307,10 +391,12 @@ Lemma subst_instance_two_instance u1 u2 (u : Instance.t) : = subst_instance (subst_instance u1 u2) u. Proof. rewrite /subst_instance /= /subst_instance_instance. - rewrite map_map. - apply map_ext, subst_instance_level_two. + rewrite List.map_map. + apply map_ext, subst_instance_univ0_two. Qed. +Import Lists.List (map_map). + Lemma subst_instance_two u1 u2 (t : term) : subst_instance u1 (subst_instance u2 t) = subst_instance (subst_instance u1 u2) t. @@ -329,7 +415,7 @@ Proof. - rewrite map_map. apply All_map_eq. solve_all. rewrite map_def_map_def; solve_all. - rewrite !mapu_prim_compose_rew. solve_all. - intro. eapply subst_instance_level_two. + intro. eapply subst_instance_univ0_two. Qed. Lemma subst_instance_two_context u1 u2 (Γ : context) : @@ -343,22 +429,22 @@ Proof. now rewrite !subst_instance_two. Qed. -Lemma subst_instance_cstr_two u1 u2 c : - subst_instance_cstr u1 (subst_instance_cstr u2 c) - = subst_instance_cstr (subst_instance u1 u2) c. +Lemma subst_instance_univ_cstr_two u1 u2 c : + subst_instance_univ_cstr u1 (subst_instance_univ_cstr u2 c) + = subst_instance_univ_cstr (subst_instance u1 u2) c. Proof. - destruct c as [[? ?] ?]; unfold subst_instance_cstr; cbn. - now rewrite !subst_instance_level_two. + destruct c as [[? ?] ?]; unfold subst_instance_univ_cstr; cbn. + now rewrite !subst_instance_univ0_two. Qed. Lemma In_subst_instance_cstrs u c ctrs : UCS.In c (subst_instance_cstrs u ctrs) - <-> exists c', c = subst_instance_cstr u c' /\ UCS.In c' ctrs. + <-> exists c', c = subst_instance_univ_cstr u c' /\ UCS.In c' ctrs. Proof. unfold subst_instance_cstrs. rewrite UCS.fold_spec. transitivity (UCS.In c UCS.empty \/ - exists c', c = subst_instance_cstr u c' + exists c', c = subst_instance_univ_cstr u c' /\ In c' (UCS.elements ctrs)). - generalize (UCS.elements ctrs), UCS.empty. induction l; cbn. @@ -375,8 +461,8 @@ Proof. -- left. destruct c' as [[l1 c'] l2]; apply UCS.add_spec; now left. -- right. exists c'. intuition. - - rewrite ConstraintSetFact.empty_iff. - transitivity (exists c', c = subst_instance_cstr u c' + - rewrite UnivConstraintSetFact.empty_iff. + transitivity (exists c', c = subst_instance_univ_cstr u c' /\ In c' (UCS.elements ctrs)). 1: intuition. apply iff_ex; intro. apply and_iff_compat_l. symmetry. @@ -388,7 +474,7 @@ Qed. Lemma In_subst_instance_cstrs' u c ctrs : UCS.In c ctrs -> - UCS.In (subst_instance_cstr u c) (subst_instance_cstrs u ctrs). + UCS.In (subst_instance_univ_cstr u c) (subst_instance_cstrs u ctrs). Proof. intro H. apply In_subst_instance_cstrs. now eexists. Qed. @@ -401,10 +487,10 @@ Proof. intro c; split; intro Hc; apply In_subst_instance_cstrs. - apply In_subst_instance_cstrs in Hc; destruct Hc as [c' [eq Hc']]. apply In_subst_instance_cstrs in Hc'; destruct Hc' as [c'' [eq' Hc'']]. - exists c''. subst; now rewrite subst_instance_cstr_two. + exists c''. subst; now rewrite subst_instance_univ_cstr_two. - apply In_subst_instance_cstrs in Hc; destruct Hc as [c' [eq Hc']]. - exists (subst_instance_cstr u2 c'). split. - + now rewrite subst_instance_cstr_two. + exists (subst_instance_univ_cstr u2 c'). split. + + now rewrite subst_instance_univ_cstr_two. + now apply In_subst_instance_cstrs'. Qed. @@ -436,16 +522,7 @@ Lemma sup_subst_instance_univ0 ui u1 u2 : subst_instance ui (Universe.sup u1 u2) = Universe.sup (subst_instance ui u1) (subst_instance ui u2). Proof. - apply eq_univ'. cbn. - intro x; split; intro Hx. - + apply map_spec in Hx as [y [H H']]; subst. - apply LevelExprSet.union_spec. - apply LevelExprSet.union_spec in H as [H|H]; [left|right]. - all: apply map_spec; eexists; split; tea; reflexivity. - + apply map_spec. - apply LevelExprSet.union_spec in Hx as [H|H]; - apply map_spec in H as [y [H H']]; subst. - all: eexists; split; [eapply LevelExprSet.union_spec|reflexivity]; auto. + apply subst_instance_universe_sup. Qed. Lemma sup_subst_instance_univ u s1 s2 : @@ -456,9 +533,9 @@ Proof. apply sup_subst_instance_univ0. Qed. -Lemma consistent_instance_declared {cf: checker_flags} lvs φ uctx u : +Lemma consistent_instance_declared {cf: checker_flags} lvs φ uctx (u : Instance.t) : consistent_instance lvs φ uctx u -> - forallb (fun l => LS.mem l lvs) u. + forallb (fun l : Universe.t => LS.subset (Universe.levels l) lvs) u. Proof. unfold consistent_instance. destruct uctx as [|ctx]. 1: destruct u; [reflexivity|discriminate]. @@ -496,13 +573,13 @@ Qed. satisfies_equal_sets satisfies_subsets : univ_subst. Lemma satisfies0_subst_instance_ctr u v c - : satisfies0 v (subst_instance_cstr u c) + : satisfies0 v (subst_instance_univ_cstr u c) <-> satisfies0 (subst_instance_valuation u v) c. Proof. - destruct c as [[l1 []] l2]; unfold subst_instance_cstr; cbn; + destruct c as [[l1 []] l2]; unfold subst_instance_univ_cstr; cbn; split; intro H; constructor; inv H. - all: rewrite <- ?subst_instance_level_val'; tea. - all: rewrite ?subst_instance_level_val'; tea. + all: rewrite <- ?subst_instance_universe_val'; tea. + all: rewrite ?subst_instance_universe_val'; tea. Qed. Lemma satisfies_subst_instance_ctr u v ctrs @@ -540,8 +617,8 @@ Proof. apply hΣ. Qed. Lemma levels_global_constraint {cf : checker_flags} Σ (hΣ : wf Σ) c : UCS.In c (global_constraints Σ) - -> LS.In c.1.1 (global_levels Σ) - /\ LS.In c.2 (global_levels Σ). + -> LS.Subset (levels c.1.1) (global_levels Σ) + /\ LS.Subset (levels c.2) (global_levels Σ). Proof. intros inc. destruct hΣ. destruct o. specialize (H c inc). @@ -550,19 +627,24 @@ Qed. Lemma levels_global_ext_constraint {cf : checker_flags} Σ φ (hΣ : wf_ext_wk (Σ, φ)) c : UCS.In c (global_ext_constraints (Σ, φ)) - -> LS.In c.1.1 (global_ext_levels (Σ, φ)) - /\ LS.In c.2 (global_ext_levels (Σ, φ)). + -> LS.Subset (levels c.1.1) (global_ext_levels (Σ, φ)) + /\ LS.Subset (levels c.2) (global_ext_levels (Σ, φ)). Proof. intro H. apply UCS.union_spec in H; simpl in H. destruct hΣ as [hΣ Hφ], H as [Hc|H]; simpl in *. - red in Hφ. unfold global_ext_levels. simpl. destruct c as [[l1 c] l2]; exact (Hφ _ Hc). - apply levels_global_constraint in H; tas. - split; apply LS.union_spec; right; apply H. + destruct H. split. + * unfold global_ext_levels. rewrite H. cbn. lsets. + * unfold global_ext_levels. rewrite H0. cbn. lsets. Qed. -Definition is_monomorphic_cstr (c : LevelConstraint.t) - := negb (Level.is_var c.1.1) && negb (Level.is_var c.2). +Definition monomorphic_univ (ls : Universe.t) := + LevelSet.for_all (fun b => negb (Level.is_var b)) (levels ls). + +Definition is_monomorphic_cstr (c : UnivConstraint.t) + := monomorphic_univ c.1.1 && monomorphic_univ c.2. Lemma monomorphic_global_constraint {cf : checker_flags} Σ (hΣ : wf Σ) c : UCS.In c (global_constraints Σ) @@ -570,8 +652,8 @@ Lemma monomorphic_global_constraint {cf : checker_flags} Σ (hΣ : wf Σ) c : Proof. intros H. apply levels_global_constraint in H; tas. apply andb_and. split; destruct H as [H1 H2]. - - now apply not_var_global_levels in H1. - - now apply not_var_global_levels in H2. + - now apply LevelSet.for_all_spec; tc => l /H1 /not_var_global_levels. + - now apply LevelSet.for_all_spec; tc => l /H2 /not_var_global_levels. Qed. Lemma monomorphic_global_constraint_ext {cf : checker_flags} Σ @@ -581,8 +663,8 @@ Lemma monomorphic_global_constraint_ext {cf : checker_flags} Σ Proof. intros H. apply levels_global_ext_constraint in H; tas. apply andb_and. split; destruct H as [H1 H2]. - - now apply not_var_global_ext_levels in H1. - - now apply not_var_global_ext_levels in H2. + - now apply LevelSet.for_all_spec; tc => l /H1 /not_var_global_ext_levels. + - now apply LevelSet.for_all_spec; tc => l /H2 /not_var_global_ext_levels. Qed. #[global] Hint Resolve monomorphic_global_constraint monomorphic_global_constraint_ext @@ -590,11 +672,12 @@ Qed. Lemma subst_instance_monom_cstr inst c : is_monomorphic_cstr c - -> subst_instance_cstr inst c = c. + -> subst_instance_univ_cstr inst c = c. Proof. intro H; apply andb_and in H. destruct H. - destruct c as [[[] ?] []]; cbnr; discriminate. -Qed. +Admitted. + (* destruct c as [[[] ?] []]; cbnr; discriminate. *) +(* Qed. *) Lemma equal_subst_instance_cstrs_mono u cstrs : UCS.For_all is_monomorphic_cstr cstrs -> @@ -669,6 +752,8 @@ Proof. + rewrite forallb_map. apply forallb_forall. intros l Hl. (* unfold global_ext_levels in *; simpl in *. *) eapply forallb_forall in H; tea. clear -H H2 Hl. +Admitted. +(* apply LevelSet_mem_union in H. destruct H as [H|H]. 2: { destruct l; simpl; try (apply LevelSet_mem_union; right; assumption). apply consistent_instance_declared in H2. @@ -698,6 +783,7 @@ Proof. * destruct H2 as [_ [_ H2]]. eapply consistent_ext_trans_polymorphic_case_aux; try eassumption. Qed. +*) Lemma consistent_ext_trans {cf : checker_flags} Σ φ φ' udecl inst inst' : wf_ext_wk (Σ, φ) -> @@ -727,8 +813,8 @@ Proof. - destruct φ as [|[φ1 φ2]]. + cbn. apply satisfies_subst_instance_ctr; tas. rewrite equal_subst_instance_cstrs_mono; aa. - * intros x hin. csets. - * intros x hin. csets. + * intros x hin. ucsets. + * intros x hin. ucsets. + destruct HH as [_ [_ H1]]. unfold valid_constraints in H1; rewrite Hcf in H1. apply satisfies_subst_instance_ctr; aa. @@ -802,9 +888,7 @@ Lemma precompose_subst_instance cmp_universe u i i' : <~> cmp_universe_instance (precompose cmp_universe (subst_instance_universe u)) i i'. Proof. unfold cmp_universe_instance, subst_instance, on_rel. - split; intro H; [apply Forall2_map_inv in H | apply Forall2_map]; apply Forall2_impl with (1 := H); intros. - - rewrite !subst_instance_universe_make //. - - rewrite -!subst_instance_universe_make //. + split; intro H; [apply Forall2_map_inv in H | apply Forall2_map]; apply Forall2_impl with (1 := H); intros => //. Qed. Definition precompose_subst_instance__1 Rle u i i' @@ -813,18 +897,15 @@ Definition precompose_subst_instance__1 Rle u i i' Definition precompose_subst_instance__2 Rle u i i' := snd (precompose_subst_instance Rle u i i'). -Lemma subst_instance_level_expr_make u l : - subst_instance_level_expr u (LevelExpr.make l) = LevelExpr.make (subst_instance_level u l). -Proof. - destruct l; simpl; auto. - rewrite nth_nth_error. now destruct nth_error. -Qed. +Lemma plus_0 u : Universe.plus 0 u = u. +Proof. Admitted. Lemma subst_instance_make'_make u l : subst_instance u (Universe.make (LevelExpr.make l)) = - Universe.make (LevelExpr.make (subst_instance_level u l)). + subst_instance_level u l. Proof. - now rewrite subst_instance_universe_make' subst_instance_level_expr_make. + rewrite subst_instance_universe_make' subst_instance_level_expr_make. + cbn. rewrite plus_0 //. Qed. Lemma precompose_subst_instance_global Σ cmp_universe pb gr napp u i i' : @@ -878,10 +959,7 @@ Proof. eapply cmp_universe_instance_impl; eauto. - destruct p as [? []]; depelim X1; try now constructor. destruct X as (hty & hdef & harr). - constructor; cbn; eauto. - * rewrite /= -!subst_instance_universe_make. - now eapply huniverse. - * solve_all. + constructor; cbn; eauto. solve_all. Qed. Lemma leq_term_subst_instance {cf : checker_flags} Σ : SubstUnivPreserved (fun φ => leq_term Σ φ). @@ -918,17 +996,19 @@ Qed. Lemma In_subst_instance x u (l : Universe.t) : LevelExprSet.In x (subst_instance u l) <-> - (exists x', LevelExprSet.In x' l /\ x = subst_instance u x'). + (exists x', LevelExprSet.In x' l /\ + LevelExprSet.In x (subst_instance_level_expr u x')). Proof. unfold subst_instance; cbn. unfold subst_instance_universe. - now rewrite map_spec. -Qed. +Admitted. Lemma subst_instance_univ_super l u : subst_instance_sort u (Sort.super l) = Sort.super (subst_instance u l). Proof. - destruct l; cbnr. f_equal. + destruct l; cbnr. + 3:{ cbn. } + f_equal. apply eq_univ'. intros x. rewrite In_subst_instance. diff --git a/pcuic/theories/PCUICWeakeningEnv.v b/pcuic/theories/PCUICWeakeningEnv.v index c3b19bd0b..f0cfd0b5d 100644 --- a/pcuic/theories/PCUICWeakeningEnv.v +++ b/pcuic/theories/PCUICWeakeningEnv.v @@ -537,7 +537,7 @@ Proof. eapply weaken_env_prop_gen_impl; repeat intro; tc; reflexivity. Qed. #[warnings="-ambiguous-paths"] Global Coercion weaken_env_prop_strictly_on_decls_to_strictly_decls {cf Pcmp P P0} : @weaken_env_strictly_on_decls_prop cf Pcmp P P0 -> @weaken_env_strictly_decls_prop cf Pcmp P P0. Proof. eapply weaken_env_prop_gen_impl; repeat intro; tc; reflexivity. Qed. -#[export] Set Warnings Append "ambiguous-paths". +(* #[export] Set Warnings Append "ambiguous-paths". *) #[global] Hint Resolve weaken_env_prop_full_to_decls : extends. #[global] Hint Resolve weaken_env_prop_full_to_strictly_on_decls : extends. From 702e0a8e25e74557df026ab72f9b66507559e976 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 5 Nov 2025 14:50:27 +0100 Subject: [PATCH 122/164] Finished porting univ subsitution proof --- common/theories/LoopChecking/Deciders.v | 6 +- common/theories/LoopChecking/Interfaces.v | 17 +- common/theories/LoopChecking/Model.v | 8 - .../LoopChecking/PartialLoopChecking.v | 2 +- common/theories/Universes.v | 22 +- .../Conversion/PCUICUnivSubstitutionConv.v | 512 +++++++++++++----- utils/theories/NonEmptyLevelExprSet.v | 26 +- 7 files changed, 413 insertions(+), 180 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index e4c4e2bf8..8bf817b78 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -713,7 +713,7 @@ Definition checking_clause (cl : clause) := destruct cl as [prems [concl k]]; rewrite /clause_premises_levels /checking_clause //=. rewrite /clause_levels. cbn. unfold pred_expr; cbn. intros l; firstorder. lsets. rsets. - rewrite NES.levels_spec. exists (k - 1). lsets. + rewrite NES.levels_spec //=. exists (k - 1). lsets. Qed. Lemma checking_clause_levels cl : @@ -721,7 +721,7 @@ Definition checking_clause (cl : clause) := Proof. destruct cl as [prems [concl k]]; rewrite /clause_premises_levels /checking_clause //=. rewrite /clause_levels. cbn. unfold pred_expr; cbn. - intros l. rewrite LevelSet.union_spec NES.levels_spec. + intros l. rewrite LevelSet.union_spec NES.levels_spec //=. setoid_rewrite LevelExprSet.union_spec; rewrite LevelSet.union_spec. setoid_rewrite NES.levels_spec. firstorder rsets. noconf H. now right. @@ -2474,7 +2474,7 @@ Lemma opt_valuation_of_model_equiv m l : destruct H as [lk [hin eq]]. subst x. apply clause_levels_spec in H0. destruct H0; cbn in *; firstorder. - right. apply NES.levels_spec in H as []. + right. apply NES.levels_spec in H as []; cbn in H. rsets. subst. left. apply In_add_prems in hin as [le' []]. subst lk. cbn. apply levels_spec. exists le'.2. destruct le' => //. diff --git a/common/theories/LoopChecking/Interfaces.v b/common/theories/LoopChecking/Interfaces.v index 29d283feb..9af357557 100644 --- a/common/theories/LoopChecking/Interfaces.v +++ b/common/theories/LoopChecking/Interfaces.v @@ -137,12 +137,15 @@ Qed. Lemma in_singleton l : LevelSet.In l (LevelSet.singleton l). Proof. lsets. Qed. -Lemma in_levels le prems : LevelExprSet.In le prems -> LevelSet.In le.1 (levels prems). +Lemma in_leset_levels le prems : LevelExprSet.In le prems -> LevelSet.In le.1 (leset_levels prems). Proof. destruct le. intros hin. - apply levels_spec. now exists z. + apply leset_levels_spec. now exists z. Qed. +Lemma in_levels le (prems : NES.t) : LevelExprSet.In le prems -> LevelSet.In le.1 (levels prems). +Proof. apply in_leset_levels. Qed. + Lemma not_in_union_inv l ls ls' : ~ LevelSet.In l (LevelSet.union ls ls') -> ~ LevelSet.In l ls /\ ~ LevelSet.In l ls'. @@ -206,10 +209,10 @@ Lemma non_W_atoms_subset W l : non_W_atoms W l ⊂_leset l. Proof. intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec. Qed. Lemma levels_exprs_non_W_atoms {W prem} : - LevelSet.Equal (levels (non_W_atoms W prem)) (LevelSet.diff (levels prem) W). + LevelSet.Equal (leset_levels (non_W_atoms W prem)) (LevelSet.diff (leset_levels prem) W). Proof. intros e. unfold non_W_atoms. - rewrite levels_spec LevelSet.diff_spec levels_spec. + rewrite leset_levels_spec LevelSet.diff_spec leset_levels_spec. firstorder eauto. rewrite LevelExprSet.filter_spec in H. now exists x. rewrite LevelExprSet.filter_spec in H. destruct H. @@ -220,13 +223,13 @@ Proof. rewrite LevelSetFact.not_mem_iff in H0. now rewrite H0. Qed. -Lemma levelexprset_empty_levels x : LevelExprSet.Empty x <-> LevelSet.Empty (levels x). +Lemma levelexprset_empty_levels x : LevelExprSet.Empty x <-> LevelSet.Empty (leset_levels x). Proof. split. - intros he. intros l hin. - eapply levels_spec in hin as [k hin]. lesets. - - intros emp l hin. eapply emp. eapply (levels_spec l.1). exists l.2. + eapply leset_levels_spec in hin as [k hin]. lesets. + - intros emp l hin. eapply emp. eapply (leset_levels_spec l.1). exists l.2. now destruct l. Qed. diff --git a/common/theories/LoopChecking/Model.v b/common/theories/LoopChecking/Model.v index 80ae137f4..de4012c2f 100644 --- a/common/theories/LoopChecking/Model.v +++ b/common/theories/LoopChecking/Model.v @@ -1497,14 +1497,6 @@ Module Model (LS : LevelSets). setoid_rewrite eqcl. now setoid_rewrite eqm; setoid_rewrite eqs. Qed. - #[export] Instance proper_levelexprset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) - levels. - Proof. - intros s s' eq l. - rewrite !levels_spec. - firstorder eauto. - Qed. - Lemma min_premise_spec' {m prems z} : min_premise m prems = Some z -> (forall l k, LevelExprSet.In (l, k) prems -> exists v, level_value m l = Some v /\ z <= (v - k))%Z. diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index b5bf01143..5a6d9bb66 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -352,7 +352,7 @@ Proof. { have vm := v_minus_w_bound_spec W m exmax.1. unfold levelexpr_value in eqmaxpre. rewrite -eqmaxpre in vm. have := (@levels_exprs_non_W_atoms W prem (level exmax)). - rewrite levels_spec => -[] /fwd. + rewrite leset_levels_spec => -[] /fwd. { exists exmax.2. now destruct exmax. } rewrite LevelSet.diff_spec => [] [_ nw] _. specialize (vm nw). depelim vm. lia. } diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 7cb6fc076..57539ca13 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -448,7 +448,7 @@ Module Universe. Definition of_level (l: Level.t) : t := singleton (LevelExpr.make l). #[deprecated(since = "1.4", note="use of_level instead")] - Notation make' := of_level. + Notation make' := of_level (only parsing). Lemma make'_inj l l' : of_level l = of_level l' -> l = l'. Proof. @@ -1194,7 +1194,7 @@ Section Univ. intros hs e hin. destruct e as [l k]. apply (hs l). clear hs. - unfold Universe.levels. + unfold Universe.levels, Universe.leset_levels. revert hin. eapply LevelExprSetProp.fold_rec. - intros s' emp hin. now specialize (emp _ hin). @@ -2589,15 +2589,7 @@ Notation "x @[ u ]" := (subst_instance u x) (at level 3, fun u l => map (subst_level_instance_level u) l. #[global] Instance subst_level_instance_level_expr : UnivLevelSubst LevelExpr.t := -fun u e => match e with - | (Level.lzero, _) - | (Level.level _, _) => e - | (Level.lvar n, b) => - match nth_error u n with - | Some l => (l,b) - | None => (Level.lzero, b) - end - end. +fun u e => (subst_level_instance_level u e.1, e.2). Definition subst_instance_level (u : Instance.t) (l : Level.t) : Universe.t := match l with @@ -2866,11 +2858,9 @@ Section SubstLevelInstanceClosed. Lemma subst_level_instance_level_expr_closedu e : closedu_level_expr #|u| e -> closedu_level_expr 0 (subst_level_instance_level_expr u e). Proof using Hcl. - destruct e as [l b]. destruct l;cbnr. - case_eq (nth_error u n); cbnr. intros [] Hl X; cbnr. - apply nth_error_In in Hl. - eapply forallb_forall in Hcl; tea. - discriminate. + destruct e as [l b]. + move/subst_level_instance_level_closedu. cbn. + destruct l => //. Qed. Lemma subst_level_instance_universe_closedu s diff --git a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v index 96a6ed616..e16f58132 100644 --- a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v +++ b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v @@ -1,5 +1,5 @@ (* Distributed under the terms of the MIT license. *) -From Stdlib Require Import ssreflect CRelationClasses. +From Stdlib Require Import ssreflect ssrbool ssrfun CRelationClasses. From MetaRocq.Utils Require Import utils. From MetaRocq.Common Require Import config Universes uGraph. From MetaRocq.PCUIC Require Import PCUICAst PCUICOnOne PCUICAstUtils PCUICInduction @@ -26,6 +26,11 @@ Local Ltac aa := rdest; eauto with univ_subst. Import Universe.NES. Import Universes. +Lemma subset_levels l s : LevelSet.Subset (levels l) s <-> (forall lk, LevelExprSet.In lk l -> LevelSet.In lk.1 s). +Proof. rewrite /LevelSet.Subset. setoid_rewrite levels_spec. firstorder. + apply H. exists lk.2; destruct lk => //. +Qed. + Lemma subst_instance_level_expr_val {u l v} v' (H1 : forall s, valuation_mono v s = valuation_mono v' s) (H2 : forall n, val v (nth n u Universe.zero) = valuation_poly v' n) @@ -472,6 +477,41 @@ Proof. now destruct H as [? [[] ?]]. Qed. +Lemma In_subst_level_instance_cstrs u c ctrs : + UCS.In c (subst_level_instance_cstrs u ctrs) + <-> exists c', c = subst_level_instance_univ_cstr u c' /\ UCS.In c' ctrs. +Proof. + unfold subst_level_instance_cstrs. + rewrite UCS.fold_spec. + transitivity (UCS.In c UCS.empty \/ + exists c', c = subst_level_instance_univ_cstr u c' + /\ In c' (UCS.elements ctrs)). + - generalize (UCS.elements ctrs), UCS.empty. + induction l; cbn. + + pcuicfo. now destruct H0 as [? ?]. + + intros t. etransitivity. 1: eapply IHl. + split; intros [HH|HH]. + * destruct a as [[l1 a] l2]. apply UCS.add_spec in HH. + destruct HH as [HH|HH]. 2: now left. + right; eexists. split; [|left; reflexivity]. assumption. + * destruct HH as [c' ?]. right; exists c'; intuition. + * left. destruct a as [[l1 a] l2]. apply UCS.add_spec. + now right. + * destruct HH as [c' [HH1 [?|?]]]; subst. + -- left. destruct c' as [[l1 c'] l2]; + apply UCS.add_spec; now left. + -- right. exists c'. intuition. + - rewrite UnivConstraintSetFact.empty_iff. + transitivity (exists c', c = subst_level_instance_univ_cstr u c' + /\ In c' (UCS.elements ctrs)). + 1: intuition. + apply iff_ex; intro. apply and_iff_compat_l. symmetry. + etransitivity. 1: symmetry; apply UCS.elements_spec1. + etransitivity. 1: eapply SetoidList.InA_alt. + split; intro; eauto. + now destruct H as [? [[] ?]]. +Qed. + Lemma In_subst_instance_cstrs' u c ctrs : UCS.In c ctrs -> UCS.In (subst_instance_univ_cstr u c) (subst_instance_cstrs u ctrs). @@ -1007,28 +1047,9 @@ Lemma subst_instance_univ_super l u : subst_instance_sort u (Sort.super l) = Sort.super (subst_instance u l). Proof. destruct l; cbnr. - 3:{ cbn. } - f_equal. - apply eq_univ'. - intros x. - rewrite In_subst_instance. - rewrite spec_map_succ. split. - * intros [x' [hin eq]]. - subst. - apply spec_map_succ in hin as [y [int eq]]. - subst x'. exists (subst_instance u y). - split; auto. - - rewrite In_subst_instance. exists y; split; auto. - - destruct y as [[] ?]; simpl; cbn; auto. - now destruct nth_error. - * intros [x' [hin eq]]. subst x. - apply In_subst_instance in hin as [y [hin eq]]. - subst x'. - exists (LevelExpr.succ y); cbn. - rewrite spec_map_succ. split. - - exists y; auto. - - destruct y as [[] ?]; cbn; auto. - now destruct nth_error. + - rewrite closedu_subst_instance_level_expr //=. + - rewrite closedu_subst_instance_level_expr //=. + - now rewrite [_@[u]](subst_instance_universe_plus _ 1). Qed. Lemma monomorphic_level_notin_levels_of_udecl s udecl : @@ -1039,21 +1060,36 @@ Proof. - apply monomorphic_level_notin_AUContext. Qed. +Lemma levels_zero : levels Universe.zero =_lset LevelSet.singleton Level.lzero. +Proof. + now intros l; rewrite levels_singleton. +Qed. + +Lemma subset_singleton x s : LevelSet.Subset (LevelSet.singleton x) s <-> LevelSet.In x s. +Proof. + rewrite /LevelSet.Subset. setoid_rewrite LevelSet.singleton_spec. + now firstorder subst. +Qed. + Lemma LevelIn_subst_instance {cf : checker_flags} Σ l u univs : LS.In l (global_ext_levels Σ) -> consistent_instance_ext (Σ.1, univs) Σ.2 u -> - LS.In (subst_instance_level u l) (global_ext_levels (Σ.1, univs)). + LS.Subset (levels (subst_instance_level u l)) (global_ext_levels (Σ.1, univs)). Proof. - intros H H'. destruct l; simpl. - - apply global_ext_levels_InSet. - - apply LS.union_spec in H; destruct H as [H|H]; simpl in *. + intros H H'. destruct l. + - cbn -[levels]. rewrite levels_zero subset_singleton. + apply global_ext_levels_InSet. + - move=> l; rewrite levels_singleton LevelSet.singleton_spec => ->. + apply LS.union_spec in H; destruct H as [H|H]; simpl in *. + now apply monomorphic_level_notin_levels_of_udecl in H. + apply LS.union_spec; now right. - apply consistent_instance_declared in H'. - apply (forallb_nth' n Level.lzero) in H'. - destruct H' as [[? [eq ?]]|eq]; rewrite eq. - + now apply LS.mem_spec. - + apply global_ext_levels_InSet. + cbn. + destruct nth_error eqn:hnth. + + solve_all. eapply nth_error_all in hnth; tea. + now apply LevelSet.subset_spec in hnth. + + rewrite levels_zero subset_singleton. + apply global_ext_levels_InSet. Qed. @@ -1696,7 +1732,7 @@ Proof. rewrite app_context_nil_l in decomp. injection decomp; intros -> ->; clear decomp. simpl. - destruct (decompose_app t) eqn:Happ. + destruct (decompose_app t0) eqn:Happ. rewrite <- subst_instance_decompose_app, Happ. simpl. rewrite destInd_subst_instance. destruct destInd as [[i u']|]; simpl; auto. @@ -1744,33 +1780,95 @@ Proof. - apply hin. Qed. +Lemma add_make l n : LevelExpr.add n (LevelExpr.make l) = (l, n). +Proof. + rewrite /LevelExpr.add //=; lia_f_equal. +Qed. + +Lemma subst_instance_level_spec x i l : + LevelExprSet.In x (subst_instance_level i l) <-> + (~ Level.is_var l /\ x = LevelExpr.make l) \/ exists n, l = Level.lvar n /\ + if nth_error i n is (Some u) then LevelExprSet.In x u + else x = (Level.lzero, 0). +Proof. + destruct l. + - cbn. setoid_rewrite LevelExprSet.singleton_spec. firstorder. + congruence. + - cbn; rewrite LevelExprSet.singleton_spec. firstorder congruence. + - cbn. destruct nth_error eqn:hnth => //. + * firstorder subst; auto => //. + + right. exists n; split => //. now rewrite hnth. + + now noconf H; rewrite hnth in H0. + * rewrite LevelExprSet.singleton_spec. firstorder subst. + + right. exists n. split => //; rewrite hnth. reflexivity. + + now elim H. + + noconf H. rewrite hnth in H0. subst. reflexivity. +Qed. + +Lemma subst_instance_level_expr_spec x i le : + LevelExprSet.In x (subst_instance_level_expr i le) <-> + (~ Level.is_var le.1 /\ x = le) \/ exists n k, le = (Level.lvar n, k) /\ + if nth_error i n is (Some u) then LevelExprSet.In x (Universe.plus k u) + else x = (Level.lzero, k). +Proof. + destruct le as [l k]. + cbn -[subst_instance_level]. + rewrite Universe.map_spec. + setoid_rewrite subst_instance_level_spec. + split. + - move=> -[] e. + firstorder subst. + * left. now rewrite add_make. + * right. exists x0, k. split => //. destruct nth_error => //. + + rewrite Universe.map_spec. exists e; split => //. + + subst. now rewrite add_make. + - move=> -[] h. + * destruct h as []. subst x. exists (l, 0). rewrite add_make; split => //. + left. split => //. + * destruct h as [n [k' [heq hnth]]]. + destruct nth_error eqn:hnth'. + + noconf heq. + apply Universe.map_spec in hnth as [? []]. subst x. + exists x0; split => //. + right. exists n; split => //. + now rewrite hnth'. + + noconf heq. subst x. exists (LevelExpr.make Level.lzero). + rewrite add_make. split => //. right. eexists; split; trea. + now rewrite hnth'. +Qed. + Lemma wf_universe_subst_instance {cf : checker_flags} (Σ : global_env_ext) univs ui u : wf Σ -> wf_universe Σ u -> consistent_instance_ext (Σ.1, univs) Σ.2 ui -> wf_universe (Σ.1, univs) (subst_instance ui u). Proof. - intros wfΣ Hl Hu e [[l n] [inl ->]]%In_subst_instance. - destruct l as [|s|n']; simpl; auto. - - apply global_ext_levels_InSet. - - specialize (Hl (Level.level s, n) inl). - simpl in Hl. apply monomorphic_level_in_global_ext in Hl. - eapply LS.union_spec. now right. - - specialize (Hl (Level.lvar n', n) inl). - eapply LS.union_spec in Hl as [Hl|Hl]. - + red in Hu. - unfold levels_of_udecl in Hl. - destruct Σ.2. - * simpl in Hu. - destruct u; try discriminate. lsets. - * destruct Hu as [declu [us vc]]. - unfold subst_instance. simpl. - destruct (nth_error ui n') eqn:hnth. - 2: simpl; apply global_ext_levels_InSet. - eapply forallb_Forall in declu. - eapply nth_error_forall in declu; eauto. - simpl in declu. now eapply LS.mem_spec in declu. - + now apply not_var_global_levels in Hl. + intros wfΣ Hl Hu e [[l n] [inl eq]]%In_subst_instance. + apply subst_instance_level_expr_spec in eq as [H|H]. + - cbn in H. destruct H as [nvar ->]. + specialize (Hl (l, n) inl). + destruct l => //. + + cbn. eapply global_ext_levels_InSet. + + cbn. apply monomorphic_level_in_global_ext in Hl. + now eapply LS.union_spec. + - destruct H as [n' [k [heq hnth]]]. + noconf heq. + destruct nth_error eqn:hnth'. + * eapply Universe.map_spec in hnth as [? []]; subst e. + cbn. + specialize (Hl (Level.lvar n', n) inl). + eapply LS.union_spec in Hl as [Hl|Hl]. + + red in Hu. unfold levels_of_udecl in Hl. + destruct Σ.2. + { simpl in Hu. apply nth_error_Some_length in hnth'. + destruct ui; try discriminate. lsets. } + { destruct Hu as [declu [us vc]]. + eapply forallb_Forall in declu. + eapply nth_error_forall in declu; eauto. + simpl in declu. now eapply LS.subset_spec, subset_levels in declu. } + + now apply not_var_global_levels in Hl. + * subst e. + now apply global_ext_levels_InSet. Qed. Lemma wf_sort_subst_instance {cf : checker_flags} (Σ : global_env_ext) univs ui s : @@ -1793,7 +1891,7 @@ Proof. unfold global_levels. intros x hin. apply LevelSet.union_spec; right. now apply LevelSet.union_spec; left. - - apply ConstraintSetProp.union_subset_2. + - apply UnivConstraintSetProp.union_subset_2. Qed. Definition wf_global_ext {cf : checker_flags} Σ ext := wf_ext_wk (Σ, ext). @@ -1802,12 +1900,39 @@ From Stdlib Require Import Morphisms. From Stdlib Require Import ssreflect. Set SimplIsCbn. +Infix "$" := Basics.compose (at level 20). +Infix "@@" := Basics.apply (at level 20). + +Lemma unfold_eq {A} (f : nat -> A) n x : + (#|x| = n /\ forall i, i < n -> nth_error x i = Some (f i)) -> + unfold n f = x. +Proof. + intros hf. + induction n in x, hf |- *; cbn. + - destruct hf as [hl hf]. destruct x => //. + - destruct x using rev_ind; destruct hf as [hl hf] => //. + have he : #|x0| = n. + { rewrite length_app //= in hl. lia. } + f_equal. + + eapply IHn. + split => //. + move=> i hlt; rewrite -hf; try lia. + rewrite nth_error_app. + destruct (Nat.ltb_spec i #|x0|) => //. lia. + + f_equal. move: (hf n) => /fwd //. + rewrite nth_error_app. + destruct (Nat.ltb_spec n #|x0|) => //. + * lia. + * subst n. rewrite Nat.sub_diag nth_error_0 //=. + now intros [= ->]. +Qed. + Section SubstIdentity. Context `{cf:checker_flags}. Lemma subst_instance_id_mdecl Σ u mdecl : consistent_instance_ext Σ (ind_universes mdecl) u -> - subst_instance u (abstract_instance (ind_universes mdecl)) = u. + subst_instance u (Instance.of_level_instance @@ abstract_instance (ind_universes mdecl)) = u. Proof using Type. intros cu. red in cu. red in cu. @@ -1815,9 +1940,15 @@ Section SubstIdentity. - destruct u; simpl in cu; try discriminate. reflexivity. - simpl. destruct cst as [univs csts]. simpl. - rewrite map_mapi. simpl. simpl in cu. + rewrite map_map map_mapi. simpl. simpl in cu. destruct cu as [Hu [sizeu vu]]. - now rewrite mapi_nth. + rewrite mapi_unfold. + set (f := fun i : nat => _). + apply unfold_eq. split => //. + move=> i h. + subst f. cbn. + rewrite subst_instance_level_expr_make //=. + rewrite plus_0. elim: nth_error_spec => //. lia. Qed. Lemma declared_inductive_wf_ext_wk Σ mdecl mind : @@ -1849,7 +1980,7 @@ Section SubstIdentity. LevelSet.In l (LevelSet.union (fold_right LevelSet.add LevelSet.empty (unfold n Level.lvar)) (global_levels Σ)) -> - subst_instance_level (unfold n Level.lvar) l = l. + subst_level_instance_level (unfold n Level.lvar) l = l. Proof using Type. intros wfΣ lin. eapply LevelSet.union_spec in lin. @@ -1864,6 +1995,123 @@ Section SubstIdentity. destruct l => //. Qed. + Lemma subst_instance_universe_abs (l : Universe.t) n Σ : + wf Σ -> + LevelSet.Subset (Universe.levels l) (LevelSet.union + (fold_right LevelSet.add LevelSet.empty + (unfold n Level.lvar)) (global_levels Σ)) -> + l@@[unfold n Level.lvar] = l. + Proof using Type. + intros wfΣ lin. + apply equal_exprsets => l'. + rewrite /subst_level_instance_universe. + rewrite Universe.map_spec. + rewrite /subst_level_instance_level_expr. + split. + - move=> -[e [hin hs]]. subst l'. rewrite subst_instance_level_abs. + * apply lin. apply levels_spec. exists e.2. now destruct e. + * destruct e => //. + - move=> hin. exists l'. split => //. rewrite subst_instance_level_abs. + * apply lin, levels_spec. exists l'.2; now destruct l'. + * destruct l' => //. + Qed. + + Lemma map_singleton f le : Universe.map f (singleton le) = singleton (f le). + Proof. + apply equal_exprsets=> l; rewrite Universe.map_spec. firstorder subst. + * apply LevelExprSet.singleton_spec. now apply LevelExprSet.singleton_spec in H; subst. + * apply LevelExprSet.singleton_spec in H. subst l. exists le. split => //. now apply LevelExprSet.singleton_spec. + Qed. + + Lemma map_add f le u : Universe.map f (add le u) = add (f le) (Universe.map f u). + Proof using Type. + clear cf. + apply equal_exprsets=> l; rewrite Universe.map_spec. firstorder subst. + * apply LevelExprSet.add_spec. apply LevelExprSet.add_spec in H as [H|H]; subst; auto. + right. apply map_spec. now exists x. + * setoid_rewrite LevelExprSet.add_spec. apply LevelExprSet.add_spec in H as [H|H]. + + subst l. now exists le; split. + + apply map_spec in H as [e []]. exists e. split => //. now right. + Qed. + + Lemma subst_level_instance_level_instance_level {i} {l : Level.t} : + Universe.of_level (subst_level_instance_level i l) = subst_instance_level i l. + Proof. + destruct l => //=. + rewrite (nth_nth_error n i). + rewrite nth_error_map. + destruct nth_error => //=. + Qed. + + Lemma plus_of_level n l : Universe.plus n (Universe.of_level l) = Universe.make (l, n). + Proof using Type. + clear cf. + apply equal_exprsets => lk. + rewrite Universe.map_spec /Universe.make singleton_spec /Universe.of_level. + setoid_rewrite singleton_spec. firstorder subst. + - now rewrite add_make. + - exists (l, 0). split => //; rewrite /LevelExpr.add //= Nat.add_0_r //. + Qed. + + Lemma subst_level_instance_singleton {i le} : + (singleton le)@@[i] = Universe.singleton (subst_level_instance_level_expr i le). + Proof. rewrite /subst_level_instance /subst_instance_level_expr; cbn. + rewrite /subst_level_instance_universe map_singleton. + rewrite /subst_level_instance_level_expr. destruct le as [l k]; cbn. + reflexivity. + Qed. + + Lemma subst_level_instance_singleton_level_expr {i le} : + (singleton le)@@[i] = subst_instance_level_expr i le. + Proof. rewrite /subst_level_instance /subst_instance_level_expr; cbn. + rewrite /subst_level_instance_universe map_singleton. + rewrite /subst_level_instance_level_expr. destruct le as [l k]; cbn. + now rewrite -subst_level_instance_level_instance_level plus_of_level. + Qed. + + Lemma subst_level_instance_add {i le u} : + (add le u)@@[i] = (subst_instance_level_expr i le ∪ u@@[i])%nes. + Proof. rewrite /subst_level_instance; cbn. + rewrite [subst_level_instance_universe _ _]map_add. + rewrite -subst_level_instance_singleton_level_expr. + rewrite -Universe.union_add_singleton union_comm. + now rewrite subst_level_instance_singleton. + Qed. + + Lemma subst_level_instance_subst_instance_univ {u : Universe.t} {i} : + u@@[i] = u@[i]. + Proof. + apply equal_exprsets => l. + move: u; apply elim. + - move=> le. now rewrite subst_level_instance_singleton_level_expr. + - move=> le x ih hnin. + now rewrite subst_level_instance_add add_subst !LevelExprSet.union_spec ih. + Qed. + + Lemma subst_level_instance_subst_instance_instance {u i} : + u@@[i] = u@[i]. + Proof. + apply map_ext. + intros x. + apply subst_level_instance_subst_instance_univ. + Qed. + + Lemma subst_level_instance_instance_cstr {u cstr} : + subst_level_instance_univ_cstr u cstr = subst_instance_univ_cstr u cstr. + Proof. + destruct cstr as [[l d] r]; cbn. + rewrite /subst_level_instance_univ_cstr /subst_instance_univ_cstr //=. + now rewrite !subst_level_instance_subst_instance_univ. + Qed. + + Lemma subst_level_instance_instance_cstrs {u cstrs} : + subst_level_instance_cstrs u cstrs =_ucset subst_instance_cstrs u cstrs. + Proof. + intros c. + rewrite In_subst_instance_cstrs In_subst_level_instance_cstrs. + split => -[cstr [-> hin]]; exists cstr; now rewrite subst_level_instance_instance_cstr. + Qed. + Lemma consistent_instance_ext_abstract_instance Σ udecl : wf Σ -> wf_global_ext Σ udecl -> @@ -1875,9 +2123,11 @@ Section SubstIdentity. { simpl. reflexivity. } split; [|split]. - simpl abstract_instance. + rewrite forallb_map. eapply forallb_mapi => //. intros i Hi. unfold global_ext_levels. - apply LevelSet.mem_spec, LevelSet.union_spec. left. + apply LevelSet.subset_spec. rewrite levels_singleton subset_singleton //=. + apply LevelSet.union_spec. left. unfold levels_of_udecl. simpl. rewrite (mapi_unfold Level.lvar). eapply LevelSet_In_fold_right_add. @@ -1885,11 +2135,11 @@ Section SubstIdentity. simpl. eapply in_or_app. destruct (eq_dec i n). * subst. right; simpl; auto. * left; apply IHn; lia. - - now rewrite mapi_length. + - now rewrite length_map mapi_length. - simpl. rewrite (mapi_unfold Level.lvar). - assert(UCS.Equal (subst_instance_cstrs (unfold #|univs| Level.lvar) cst) cst). + assert(UCS.Equal (subst_level_instance_cstrs (unfold #|univs| Level.lvar) cst) cst). { unfold UCS.Equal; intros a. - unfold subst_instance_cstrs. + unfold subst_level_instance_cstrs. red in wf_glob_ext. destruct wf_glob_ext as [_ wfext]. unfold on_udecl_prop in wfext. @@ -1899,7 +2149,7 @@ Section SubstIdentity. clear indu. simpl fst in wfext. revert wfext. - eapply ConstraintSetProp.fold_rec_weak; auto. + eapply UnivConstraintSetProp.fold_rec_weak; auto. 2:reflexivity. * intros s s' a' eqs H. intros Hf. @@ -1909,16 +2159,18 @@ Section SubstIdentity. eapply CS_For_all_add in cadd as [cadd Ps]. specialize (equiv Ps). clear Ps. destruct x as [[l c] r]. destruct cadd as [inl inr]. - unfold subst_instance_cstr. simpl. - eapply subst_instance_level_abs in inl; auto. - eapply subst_instance_level_abs in inr; auto. - rewrite inl inr. + unfold subst_level_instance_univ_cstr. simpl. + eapply subst_instance_universe_abs in inl; auto. + + eapply subst_instance_universe_abs in inr; auto. + rewrite inl inr. rewrite !UCS.add_spec. intuition auto. } unfold valid_constraints. destruct check_univs; auto. unfold valid_constraints0. simpl. unfold satisfies. - intros v. rewrite H. + intros v. + rewrite subst_level_instance_instance_cstrs in H. + rewrite H. eapply CS_For_all_union. Qed. @@ -1930,73 +2182,69 @@ Section SubstIdentity. simpl in lin, onu. lsets. Qed. + Lemma subst_abs_level Σ u : + wf_ext_wk Σ -> + LevelSet.In u (global_ext_levels Σ) -> + subst_instance_level (abstract_instance Σ.2) u = Universe.of_level u. + Proof using Type. + intros [wfΣ onu] decl'. + destruct u; simpl; auto. cbn -[LevelSet.subset global_ext_levels] in decl'. + eapply in_var_global_ext in decl'; auto. + destruct (udecl_prop_in_var_poly onu decl') as [[univs csts] eq]. + rewrite eq in decl' |- *. simpl in *. + rewrite mapi_unfold in decl' |- *. + eapply LevelSet_In_fold_right_add in decl'. + eapply In_unfold_inj in decl'; try congruence. + eapply (nth_error_unfold Level.lvar) in decl'. + rewrite nth_error_map decl' //=. + Qed. - Lemma consistent_instance_ext_subst_abs_level Σ decl u : + Lemma subst_abs_level_expr Σ (u : LevelExpr.t) : wf_ext_wk Σ -> - consistent_instance_ext Σ decl [u] -> - subst_instance_level (abstract_instance Σ.2) u = u. + LevelSet.In u.1 (global_ext_levels Σ) -> + subst_instance_level_expr (abstract_instance Σ.2) u = Universe.make u. Proof using Type. - intros [wfΣ onu] cu. - destruct decl. - - simpl in cu. destruct u; simpl in *; try discriminate; auto. - - destruct cu as [decl' [sizeu vc]]. - clear sizeu vc. - destruct u; simpl; auto. cbn -[global_ext_levels] in decl'. - rewrite andb_true_r in decl'. - eapply LevelSet.mem_spec in decl'. - eapply in_var_global_ext in decl'; auto. - destruct (udecl_prop_in_var_poly onu decl') as [[univs csts] eq]. - rewrite eq in decl' |- *. simpl in *. - rewrite mapi_unfold in decl' |- *. - eapply LevelSet_In_fold_right_add in decl'. - eapply In_unfold_inj in decl'; try congruence. - eapply (nth_error_unfold Level.lvar) in decl'. - now rewrite (nth_error_nth _ _ _ decl'). + intros [wfΣ onu] decl'. + destruct u; simpl; auto. cbn -[LevelSet.subset global_ext_levels] in decl'. + rewrite /subst_instance_level_expr subst_abs_level //=. + now rewrite plus_of_level. + Qed. + + Lemma subst_abs_universe Σ u : + wf_ext_wk Σ -> + LevelSet.Subset (levels u) (global_ext_levels Σ) -> + subst_instance (abstract_instance Σ.2) u = u. + Proof using Type. + intros [wfΣ onu] decl'. + apply equal_exprsets => l. + rewrite In_subst_instance. + split. + + intros [x' [hin hin']]. + rewrite subst_abs_level_expr in hin' => //. + * apply decl', levels_spec. exists x'.2; now destruct x'. + * apply LevelExprSet.singleton_spec in hin'. now subst. + + intros hin. exists l. split => //. + rewrite subst_abs_level_expr //. + * apply decl', levels_spec. now exists l.2; destruct l. + * now apply LevelExprSet.singleton_spec. Qed. + Lemma consistent_instance_ext_subst_abs Σ decl u : wf_ext_wk Σ -> consistent_instance_ext Σ decl u -> subst_instance (abstract_instance Σ.2) u = u. - Proof using Type. + Proof. intros [wfΣ onu] cu. destruct decl. - simpl in cu. destruct u; simpl in *; try discriminate; auto. - destruct cu as [decl' [sizeu vc]]. clear sizeu vc. - induction u; simpl; auto. + induction u; simpl; auto. cbn in decl'. move/andb_and: decl' => [ina au]. specialize (IHu au). - rewrite [List.map _ u]IHu. f_equal. clear au. - destruct a; simpl; auto. - eapply LevelSet.mem_spec in ina. - eapply in_var_global_ext in ina; auto. - destruct (udecl_prop_in_var_poly onu ina) as [[univs csts] eq]. - rewrite eq in IHu, ina |- *. simpl in *. - rewrite mapi_unfold in IHu, ina |- *. - eapply LevelSet_In_fold_right_add in ina. - eapply In_unfold_inj in ina; try congruence. - eapply (nth_error_unfold Level.lvar) in ina. - now rewrite (nth_error_nth _ _ _ ina). - Qed. - - Lemma in_global_ext_subst_abs_level Σ l : - wf_ext_wk Σ -> - LevelSet.In (LevelExpr.get_level l) (global_ext_levels Σ) -> - subst_instance (abstract_instance Σ.2) l = l. - Proof using Type. - intros [wfΣ onu] cu. - destruct l; auto. - destruct t; auto. - eapply in_var_global_ext in cu; eauto. - eapply udecl_prop_in_var_poly in onu as [[ctx cstrs] eq]; eauto. - rewrite eq. simpl. - rewrite eq in cu. simpl in cu. - apply LevelSet_In_fold_right_add in cu. - unfold AUContext.repr in *. rewrite (mapi_unfold Level.lvar) in cu |- *. - destruct nth_error eqn:hnth. - * apply nth_error_unfold_inv in hnth. subst; auto. - * apply nth_error_None in hnth. rewrite unfold_length in hnth. - apply In_unfold_inj in cu; try lia. congruence. + rewrite [subst_instance_universe _ _]subst_abs_universe //. + * now apply LevelSet.subset_spec in ina. + * now rewrite [ListDef.map _ _]IHu. Qed. Lemma consistent_instance_ext_subst_abs_univ Σ u : @@ -2006,19 +2254,8 @@ Section SubstIdentity. Proof using Type. intros wf cu. destruct u; simpl; auto. f_equal. - apply eq_univ'. - simpl in cu. - intros l. - rewrite In_subst_instance. - split. - - intros [x [inx ->]]. - specialize (cu _ inx). - unfold subst_instance. - apply in_global_ext_subst_abs_level in cu; eauto. - unfold subst_instance in cu. now rewrite cu. - - intros inl. - specialize (cu _ inl). exists l; split; auto. - now rewrite in_global_ext_subst_abs_level. + rewrite subst_abs_universe //. cbn in cu. + move=> l /levels_spec -[] k; apply cu. Qed. Lemma consistent_instance_ext_subst_abs_inds Σ decl ind u bodies : @@ -2030,6 +2267,7 @@ Section SubstIdentity. intros wf cu. unfold inds. generalize #|bodies|. induction n; simpl; auto. rewrite IHn; f_equal. + f_equal. now rewrite [subst_instance_instance _ _](consistent_instance_ext_subst_abs _ _ _ wf cu). Qed. @@ -2156,14 +2394,14 @@ Section SubstIdentity. depelim X0. specialize (hty X1); specialize (hdef X1). unfold mapu_array_model; destruct a; cbn -[Universe.of_level] in *. f_equal; intuition eauto. - * rewrite /subst_instance subst_instance_universe_make in b. - now injection b as e. + * rewrite [subst_instance_universe _ _]subst_abs_universe //. + eapply subset_levels, wfl. * solve_all. - depelim X0; cbn => //=. depelim X. simp prim_type. cbn. f_equal; intuition eauto. do 2 f_equal. cbn -[Universe.of_level] in b. - rewrite /subst_instance subst_instance_universe_make in b. - now injection b as e. + rewrite [subst_instance_universe _ _]subst_abs_universe //. + apply subset_levels, wfl. Qed. Lemma typed_subst_abstract_instance Σ Γ t T : diff --git a/utils/theories/NonEmptyLevelExprSet.v b/utils/theories/NonEmptyLevelExprSet.v index 1ffddb54c..e1f146bba 100644 --- a/utils/theories/NonEmptyLevelExprSet.v +++ b/utils/theories/NonEmptyLevelExprSet.v @@ -106,7 +106,7 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) Definition level : LevelExpr.t -> Level.t := fst. - Definition levels (e : t) := + Definition leset_levels (e : t) := fold (fun le => LevelSet.add (level le)) e LevelSet.empty. Lemma In_elements {x} {s : LevelExprSet.t} : LevelExprSet.In x s <-> List.In x (LevelExprSet.elements s). @@ -119,6 +119,8 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) { t_set :> LevelExprSet.t ; t_ne : is_empty t_set = false }. + Definition levels (e : t) := leset_levels e. + Declare Scope nes_scope. Bind Scope nes_scope with t. Delimit Scope nes_scope with nes. @@ -465,12 +467,17 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) + right. intuition auto. Qed. - Lemma levels_spec l (e : LevelExprSet.t) : - LevelSet.In l (levels e) <-> exists k, LevelExprSet.In (l, k) e. + Lemma leset_levels_spec l (e : LevelExprSet.t) : + LevelSet.In l (leset_levels e) <-> exists k, LevelExprSet.In (l, k) e. Proof. rewrite levels_spec_aux. intuition auto. lsets. Qed. + Lemma levels_spec l (e : t) : + LevelSet.In l (levels e) <-> exists k, LevelExprSet.In (l, k) e. + Proof. + rewrite levels_spec_aux. intuition auto. lsets. + Qed. Lemma levelexprset_singleton {l le} : (exists k : Q.t, LevelExprSet.In (l, k) (singleton le)) <-> (l, le.2) = le. Proof. @@ -479,13 +486,16 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) - intros <-. now exists le.2; apply LevelExprSet.singleton_spec. Qed. - Lemma levels_singleton le : levels (LevelExprSet.singleton le) =_lset LevelSet.singleton le.1. + Lemma leset_levels_singleton le : leset_levels (LevelExprSet.singleton le) =_lset LevelSet.singleton le.1. Proof. - intros l; rewrite levels_spec. + intros l; rewrite leset_levels_spec. rewrite LevelSet.singleton_spec; setoid_rewrite LevelExprSet.singleton_spec. rewrite /E.eq /LevelSet.E.eq. firstorder. now subst. subst. exists le.2; now destruct le. Qed. + Lemma levels_singleton le : levels (singleton le) =_lset LevelSet.singleton le.1. + Proof. apply leset_levels_singleton. Qed. + Lemma levels_union {u u'} : levels (u ∪ u') =_lset LevelSet.union (levels u) (levels u'). Proof. intros l; rewrite levels_spec; setoid_rewrite LevelExprSet.union_spec. @@ -497,11 +507,11 @@ Module NonEmptyLevelExprSet (Level : OrderedTypeWithLeibniz) (Q : Quantity) rewrite -union_add_singleton levels_union levels_singleton; lsets. Qed. - #[export] Instance proper_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) - levels. + #[export] Instance proper_leset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) + leset_levels. Proof. intros s s' eq l. - rewrite !levels_spec. + rewrite !leset_levels_spec. firstorder eauto. Qed. From 37cc26eab09ff467debafa1358a33ddd31238b21 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 5 Nov 2025 16:10:09 +0100 Subject: [PATCH 123/164] Ported WfUniverses --- .../Conversion/PCUICUnivSubstitutionConv.v | 5 +- pcuic/theories/PCUICWfUniverses.v | 282 ++++++++---------- pcuic/theories/Syntax/PCUICUnivSubst.v | 21 +- pcuic/theories/Typing/PCUICClosedTyp.v | 5 +- .../Typing/PCUICUnivSubstitutionTyp.v | 12 +- 5 files changed, 150 insertions(+), 175 deletions(-) diff --git a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v index e16f58132..6ce542cdd 100644 --- a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v +++ b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v @@ -1073,7 +1073,7 @@ Qed. Lemma LevelIn_subst_instance {cf : checker_flags} Σ l u univs : LS.In l (global_ext_levels Σ) -> - consistent_instance_ext (Σ.1, univs) Σ.2 u -> + forallb (fun l : Universe.t => LS.subset (Universe.levels l) (global_ext_levels (Σ.1, univs))) u -> LS.Subset (levels (subst_instance_level u l)) (global_ext_levels (Σ.1, univs)). Proof. intros H H'. destruct l. @@ -1083,8 +1083,7 @@ Proof. apply LS.union_spec in H; destruct H as [H|H]; simpl in *. + now apply monomorphic_level_notin_levels_of_udecl in H. + apply LS.union_spec; now right. - - apply consistent_instance_declared in H'. - cbn. + - cbn. destruct nth_error eqn:hnth. + solve_all. eapply nth_error_all in hnth; tea. now apply LevelSet.subset_spec in hnth. diff --git a/pcuic/theories/PCUICWfUniverses.v b/pcuic/theories/PCUICWfUniverses.v index e7f553966..167ac8378 100644 --- a/pcuic/theories/PCUICWfUniverses.v +++ b/pcuic/theories/PCUICWfUniverses.v @@ -89,12 +89,31 @@ Section CheckerFlags. Definition wf_level Σ l := LevelSet.In l (global_ext_levels Σ). - Definition wf_instance Σ u := + Definition wf_universeb Σ (u : Universe.t) : bool := + LevelExprSet.for_all (fun l => LevelSet.mem (LevelExpr.get_level l) (global_ext_levels Σ)) u. + + Definition wf_level_instance Σ u := Forall (wf_level Σ) u. - Definition wf_instanceb Σ u := + Definition wf_level_instanceb Σ u := forallb (wf_levelb Σ) u. + Definition wf_instance Σ (u : Instance.t) := + Forall (wf_universe Σ) u. + + Definition wf_instanceb Σ (u : Instance.t) := + forallb (wf_universeb Σ) u. + + + Lemma declared_instance_univs_equiv Σ u : + forallb (fun l : Universe.t => LS.subset (Universe.levels l) (global_ext_levels Σ)) u <-> + wf_instance Σ u. + Proof. + rewrite -forallb_Forall /wf_instance. solve_all. + move/LevelSet.subset_spec/subset_levels: H => //. + now apply LevelSet.subset_spec, subset_levels. + Qed. + Lemma wf_levelP {Σ l} : reflect (wf_level Σ l) (wf_levelb Σ l). Proof using Type. unfold wf_level, wf_levelb. @@ -104,42 +123,41 @@ Section CheckerFlags. now apply LevelSet.mem_spec in hin. Qed. - Lemma wf_instanceP {Σ u} : reflect (wf_instance Σ u) (wf_instanceb Σ u). + Lemma wf_universeP Σ {u : Universe.t} : + reflect (wf_universe Σ u) (wf_universeb Σ u). + Proof using Type. + eapply iff_reflect. + rewrite LevelExprSet.for_all_spec. + split; intros. + - intros l Hl; specialize (H l Hl). + now eapply LS.mem_spec. + - intros l Hl. specialize (H l Hl). + now eapply LS.mem_spec in H. + Qed. + + Lemma wf_level_instanceP {Σ u} : reflect (wf_level_instance Σ u) (wf_level_instanceb Σ u). Proof using Type. unfold wf_instance, wf_instanceb. apply forallbP. intros x; apply wf_levelP. Qed. + Lemma wf_instanceP {Σ u} : reflect (wf_instance Σ u) (wf_instanceb Σ u). + Proof using Type. + unfold wf_instance, wf_instanceb. + apply forallbP. intros x; apply wf_universeP. + Qed. + Lemma wf_universe_subst_instance_univ (Σ : global_env_ext) univs ui u : wf Σ -> wf_universe Σ u -> wf_instance (Σ.1, univs) ui -> wf_universe (Σ.1, univs) (subst_instance ui u). Proof using Type. - intros wfΣ Hl Hu e [[l n] [inl ->]]%In_subst_instance. - destruct l as [|s|n']; simpl; auto. - - apply global_ext_levels_InSet. - - specialize (Hl (Level.level s, n) inl). - simpl in Hl. - apply monomorphic_level_in_global_ext in Hl. - eapply LS.union_spec. now right. - - specialize (Hl (Level.lvar n', n) inl). - eapply LS.union_spec in Hl as [Hl|Hl]. - + red in Hu. - unfold levels_of_udecl in Hl. - destruct Σ.2. - * simpl in Hu. simpl in *. - unfold subst_instance; simpl. - destruct nth_error eqn:hnth; simpl. - eapply nth_error_forall in Hu; eauto. - apply global_ext_levels_InSet. - * unfold subst_instance. simpl. - destruct (nth_error ui n') eqn:hnth. - 2:{ simpl. rewrite hnth. apply global_ext_levels_InSet. } - eapply nth_error_forall in Hu. 2:eauto. - change (nth_error ui n') with (nth_error ui n') in *. - rewrite -> hnth. simpl. apply Hu. - + now apply not_var_global_levels in Hl. + intros wfΣ Hl Hu e [[l n] [inl eq]]%In_subst_instance. + apply Universe.map_spec in eq as [e' [hin ->]]. cbn in *. + eapply declared_instance_univs_equiv in Hu. + eapply LevelIn_subst_instance, subset_levels in Hu; tea. + now apply (Hl (l, n)). Qed. Lemma wf_sort_subst_instance_sort (Σ : global_env_ext) univs u s : @@ -162,18 +180,18 @@ Section CheckerFlags. apply (wf_sort_subst_instance_sort (Σ, univs) φ); auto. Qed. - Lemma subst_instance_empty u : + Lemma subst_level_instance_empty u : forallb (fun x => ~~ Level.is_var x) u -> - subst_instance [] u = u. + subst_level_instance [] u = u. Proof using Type. induction u; simpl; intros Hu; auto. - rewrite subst_instance_cons. + rewrite subst_level_instance_cons. move/andP: Hu => [] isv Hf. rewrite IHu //. now destruct a => /= //; auto. Qed. - Lemma wf_level_mono Σ u : + Lemma wf_level_mono_level Σ u : wf Σ -> on_udecl_prop Σ (Monomorphic_ctx) -> Forall (wf_level (Σ, Monomorphic_ctx)) u -> @@ -188,6 +206,14 @@ Section CheckerFlags. now pose proof (not_var_global_levels wf _ H). Qed. + Lemma wf_level_mono Σ u : + wf Σ -> + on_udecl_prop Σ (Monomorphic_ctx) -> + Forall (wf_universe (Σ, Monomorphic_ctx)) u -> + forallb (fun x => LevelSet.for_all (negb $ Level.is_var) (Universe.levels x)) u. + Proof using Type. + Admitted. + Lemma wf_level_sub Σ univs u : wf_level (Σ, Monomorphic_ctx) u -> wf_level (Σ, univs) u. @@ -199,6 +225,15 @@ Section CheckerFlags. eapply LevelSet.union_spec. now right. Qed. + Lemma wf_universe_sub Σ univs u : + wf_universe (Σ, Monomorphic_ctx) u -> + wf_universe (Σ, univs) u. + Proof using cf. + intros wfx. + red in wfx |- *. + move=> l /wfx /wf_level_sub. apply. + Qed. + Lemma wf_instance_sub Σ univs u : wf_instance (Σ, Monomorphic_ctx) u -> wf_instance (Σ, univs) u. @@ -206,7 +241,7 @@ Section CheckerFlags. intros wfu. red in wfu |- *. eapply Forall_impl; eauto. - intros. red in H. cbn in H. eapply wf_level_sub; eauto. + intros. red in H. cbn in H. eapply wf_universe_sub; eauto. Qed. Lemma In_Level_global_ext_poly s Σ cst : @@ -226,25 +261,6 @@ Section CheckerFlags. intros x' [->|inx]; auto. Qed. - Lemma wf_instance_In {Σ u} : wf_instance Σ u <-> - (forall l, In l u -> LS.In l (global_ext_levels Σ)). - Proof using Type. - unfold wf_instance. - split; intros. eapply Forall_In in H; eauto. - apply In_Forall. auto. - Qed. - - Lemma in_subst_instance l u u' : - In l (subst_instance u u') -> - In l u \/ In l u' \/ l = Level.lzero. - Proof using Type. - induction u'; simpl; auto. - intros []. - destruct a; simpl in *; subst; auto. - destruct (nth_in_or_default n u Level.lzero); auto. - specialize (IHu' H). intuition auto. - Qed. - Lemma wf_instance_subst_instance Σ univs u u' φ : wf Σ -> on_udecl_prop Σ univs -> @@ -257,47 +273,18 @@ Section CheckerFlags. - red in Hs |- *. unshelve epose proof (wf_level_mono _ _ _ _ Hs); eauto. eapply forallb_Forall in H. apply Forall_map. - solve_all. destruct x; simpl => //. - red. apply global_ext_levels_InSet. - eapply wf_level_sub; eauto. + solve_all. + apply (wf_universe_subst_instance_univ (Σ, Monomorphic_ctx)); auto. - clear onup. red in Hs |- *. eapply Forall_map, Forall_impl; eauto. intros x wfx. - red in wfx. destruct x => /= //. - { red. apply global_ext_levels_InSet. } - eapply In_Level_global_ext_poly in wfx. - apply LS.union_spec; now right. - eapply in_var_global_ext in wfx; simpl in wfx; auto. - unfold AUContext.levels, AUContext.repr in wfx. - destruct cst as [? cst]. - rewrite mapi_unfold in wfx. - eapply (proj1 (LevelSetProp.of_list_1 _ _)) in wfx. - apply SetoidList.InA_alt in wfx as [? [<- wfx]]. simpl in wfx. - eapply In_unfold_inj in wfx; [|congruence]. - destruct (nth_in_or_default n u (Level.lzero)). - red in cu. eapply Forall_In in cu; eauto. rewrite e. - red. apply global_ext_levels_InSet. + eapply (wf_universe_subst_instance_univ (Σ, _)); eauto. Qed. Section WfUniverses. Context (Σ : global_env_ext). - Definition wf_universeb (u : Universe.t) : bool := - LevelExprSet.for_all (fun l => LevelSet.mem (LevelExpr.get_level l) (global_ext_levels Σ)) u. - - Lemma wf_universe_reflect {u : Universe.t} : - reflect (wf_universe Σ u) (wf_universeb u). - Proof using Type. - eapply iff_reflect. - rewrite LevelExprSet.for_all_spec. - split; intros. - - intros l Hl; specialize (H l Hl). - now eapply LS.mem_spec. - - intros l Hl. specialize (H l Hl). - now eapply LS.mem_spec in H. - Qed. - Fixpoint on_universes fu fc t := match t with | tSort s => Sort.on_sort fu true s @@ -306,7 +293,7 @@ Section CheckerFlags. | tLambda _ t u => on_universes fu fc t && on_universes fu fc u | tCase _ p c brs => [&& - forallb fu (map Universe.of_level p.(puinst)) , + forallb fu p.(puinst), forallb (on_universes fu fc) p.(pparams) , test_context (fc #|p.(puinst)|) p.(pcontext) , on_universes fu fc p.(preturn) , @@ -317,31 +304,26 @@ Section CheckerFlags. | tProj _ t => on_universes fu fc t | tFix mfix _ | tCoFix mfix _ => forallb (fun d => on_universes fu fc d.(dtype) && on_universes fu fc d.(dbody)) mfix - | tConst _ u | tInd _ u | tConstruct _ _ u => - forallb fu (map Universe.of_level u) + | tConst _ u | tInd _ u | tConstruct _ _ u => forallb fu u | tEvar _ args => forallb (on_universes fu fc) args - | tPrim p => test_primu (fun x => fu (Universe.of_level x)) (on_universes fu fc) p + | tPrim p => test_primu (fun x => fu x) (on_universes fu fc) p | _ => true end. - Definition wf_universes t := on_universes wf_universeb closedu t. - Definition wf_sortb s := Sort.on_sort wf_universeb true s. + Definition wf_universes t := on_universes (wf_universeb Σ) closedu t. + Definition wf_sortb s := Sort.on_sort (wf_universeb Σ) true s. Lemma wf_sort_reflect {s : sort} : reflect (wf_sort Σ s) (wf_sortb s). Proof using Type. destruct s => //=; repeat constructor. - apply wf_universe_reflect. + apply wf_universeP. Qed. Lemma wf_universeb_instance_forall u : - forallb wf_universeb (map Universe.of_level u) = wf_instanceb Σ u. + forallb (wf_universeb Σ) u = wf_instanceb Σ u. Proof using Type. induction u => //=. - rewrite IHu. - f_equal. - cbn. - now rewrite if_true_false. Qed. (* Lemma All_forallb {A} (P : A -> Type) l (H : All P l) p p' : (forall x, P x -> p x = p' x) -> forallb p l = forallb p' l. @@ -351,19 +333,19 @@ Section CheckerFlags. Qed. *) Lemma test_context_mapi (p : term -> bool) f (ctx : context) k : - test_context p (mapi_context (shiftf f k) ctx) = test_context_k (fun k => p ∘ f k) k ctx. -Proof using Type. - induction ctx; simpl; auto. - rewrite IHctx. f_equal. - now rewrite test_decl_map_decl. -Qed. -Hint Rewrite test_context_mapi : map. + test_context p (mapi_context (shiftf f k) ctx) = test_context_k (fun k => p ∘ f k) k ctx. + Proof using Type. + induction ctx; simpl; auto. + rewrite IHctx. f_equal. + now rewrite test_decl_map_decl. + Qed. + Hint Rewrite test_context_mapi : map. -Lemma test_context_k_ctx (p : term -> bool) (ctx : context) k : - test_context p ctx = test_context_k (fun k => p) k ctx. -Proof using Type. - induction ctx; simpl; auto. -Qed. + Lemma test_context_k_ctx (p : term -> bool) (ctx : context) k : + test_context p ctx = test_context_k (fun k => p) k ctx. + Proof using Type. + induction ctx; simpl; auto. + Qed. Lemma on_universes_lift pu pc n k t : on_universes pu pc (lift n k t) = on_universes pu pc t. Proof using Type. @@ -431,7 +413,7 @@ Qed. Qed. End WfUniverses. - Arguments wf_universe_reflect {Σ u}. + Arguments wf_universeP {Σ u}. Ltac to_prop := repeat match goal with @@ -441,8 +423,8 @@ Qed. Ltac to_wfu := repeat match goal with - | [ H: is_true (wf_universeb _ ?x) |- _ ] => apply (elimT (@wf_universe_reflect _ x)) in H - | [ |- is_true (wf_universeb _ ?x) ] => apply (introT (@wf_universe_reflect _ x)) + | [ H: is_true (wf_universeb _ ?x) |- _ ] => apply (elimT (@wf_universeP _ x)) in H + | [ |- is_true (wf_universeb _ ?x) ] => apply (introT (@wf_universeP _ x)) | [ H: is_true (Sort.on_sort (wf_universeb _) _ ?x) |- _ ] => apply (elimT (@wf_sort_reflect _ x)) in H | [ |- is_true (Sort.on_sort (wf_universeb _) _ ?x) ] => apply (introT (@wf_sort_reflect _ x)) | [ H: is_true (wf_sortb _ ?x) |- _ ] => apply (elimT (@wf_sort_reflect _ x)) in H @@ -465,46 +447,25 @@ Qed. - destruct Σ as [Σ univs']. simpl in *. eapply (wf_sort_subst_instance_sort (Σ, univs)); auto. - - apply forallb_All. - rewrite -forallb_map wf_universeb_instance_forall. - apply All_forallb in wft. - rewrite -forallb_map wf_universeb_instance_forall in wft. - apply/wf_instanceP. - eapply wf_instance_subst_instance; eauto. + - apply forallb_All. apply/wf_instanceP. eapply wf_instance_subst_instance; eauto. destruct Σ; simpl in *. - now move/wf_instanceP: wft. - - apply forallb_All. - rewrite -forallb_map wf_universeb_instance_forall. - apply All_forallb in wft. - rewrite -forallb_map wf_universeb_instance_forall in wft. - apply/wf_instanceP. - eapply wf_instance_subst_instance; eauto. + now move/All_forallb/wf_instanceP: wft. + - apply forallb_All. apply/wf_instanceP. eapply wf_instance_subst_instance; eauto. destruct Σ; simpl in *. - now move/wf_instanceP: wft. - - apply forallb_All. - rewrite -forallb_map wf_universeb_instance_forall. - apply All_forallb in wft. - rewrite -forallb_map wf_universeb_instance_forall in wft. - apply/wf_instanceP. - eapply wf_instance_subst_instance; eauto. + now move/All_forallb/wf_instanceP: wft. + - apply forallb_All. apply/wf_instanceP. eapply wf_instance_subst_instance; eauto. destruct Σ; simpl in *. - now move/wf_instanceP: wft. - - - apply forallb_All. - rewrite -forallb_map wf_universeb_instance_forall. - apply All_forallb in H. - rewrite -forallb_map wf_universeb_instance_forall in H. - apply/wf_instanceP. - eapply wf_instance_subst_instance; eauto. - destruct Σ ; simpl in *. - now move/wf_instanceP: H. + now move/All_forallb/wf_instanceP: wft. + - apply forallb_All. apply/wf_instanceP. eapply wf_instance_subst_instance; eauto. + destruct Σ; simpl in *. + now move/All_forallb/wf_instanceP: H. - now len. - rewrite /test_branch. rtoProp. move/andP: a => [] tctx wfu. split; auto. simpl. solve_all. now len. - - rewrite -subst_instance_universe_make. to_wfu. + - to_wfu. eapply (wf_universe_subst_instance_univ (Σ.1, univs)) => //. Qed. @@ -541,11 +502,11 @@ Qed. intros wfΣ wfΣ' ext. unfold wf_instance. intros H; eapply Forall_impl; eauto. - intros. now eapply weaken_wf_level. + intros. now eapply weaken_wf_universe. Qed. Arguments Universe.of_level : simpl never. - Lemma test_primu_test_primu_tPrimProp {P : term -> Type} {pu put} {pu' : Level.t -> bool} {put' : term -> bool} p : + Lemma test_primu_test_primu_tPrimProp {P : term -> Type} {pu put} {pu' : Universe.t -> bool} {put' : term -> bool} p : tPrimProp P p -> test_primu pu put p -> (forall u, pu u -> pu' u) -> (forall t, P t -> put t -> put' t) -> @@ -571,13 +532,13 @@ Qed. - move: H. destruct s => //=. now apply weaken_wf_universe. - eapply forallb_impl ; tea. - now move => ? _ /wf_universe_reflect /weaken_wf_universe /wf_universe_reflect. + now move => ? _ /wf_universeP /weaken_wf_universe /wf_universeP. - eapply forallb_impl ; tea. - now move => ? _ /wf_universe_reflect /weaken_wf_universe /wf_universe_reflect. + now move => ? _ /wf_universeP /weaken_wf_universe /wf_universeP. - eapply forallb_impl ; tea. - now move => ? _ /wf_universe_reflect /weaken_wf_universe /wf_universe_reflect. + now move => ? _ /wf_universeP /weaken_wf_universe /wf_universeP. - eapply forallb_impl ; tea. - now move => ? _ /wf_universe_reflect /weaken_wf_universe /wf_universe_reflect. + now move => ? _ /wf_universeP /weaken_wf_universe /wf_universeP. - red in X. solve_all. rewrite /test_branch in b |- *. @@ -645,7 +606,7 @@ Qed. intros _. constructor. - intros [H%forallb_Forall [H' H'']]. eapply Forall_impl; eauto. - simpl; intros. now eapply LS.mem_spec in H0. + simpl; intros. eapply LS.subset_spec in H0. now move/subset_levels: H0. Qed. Ltac specIH := @@ -718,8 +679,10 @@ Qed. rewrite /UContext.instance /AUContext.repr /=. rewrite mapi_unfold. red. eapply In_Forall. - intros x hin. eapply In_unfold_var in hin as [k [lt eq]]. - subst x. red. + intros x hin. rewrite in_map_iff in hin. destruct hin as [x' [<- hin]]. + eapply In_unfold_var in hin as [k [lt eq]]. + subst x'. red. cbn. + intros l; rewrite LevelExprSet.singleton_spec => -> //=. eapply LS.union_spec; left. simpl. rewrite /AUContext.levels /= mapi_unfold. eapply (proj2 (LevelSetProp.of_list_1 _ _)). @@ -795,8 +758,10 @@ Qed. Proof using Type. destruct univs as [|[l csts]] => // /=. rewrite /UContext.instance /AUContext.repr. - rewrite /closedu_instance forallb_mapi //. - intros i hi. cbn; len. now eapply Nat.ltb_lt. + rewrite /closedu_instance //= /closedu_universe forallb_map forallb_mapi //. + intros i hi. cbn; len. apply LevelExprSet.for_all_spec; tc. + move=> l' /LevelExprSet.singleton_spec => -> //=. + rewrite /closedu_level_expr //=. now eapply Nat.ltb_lt. Qed. Notation closedu_ctx k := (test_context (closedu k)). @@ -958,7 +923,7 @@ Qed. Proof using Type. intros ond Ht. red in Ht. unfold closedu_instance. solve_all. - now eapply wf_level_closed. + now eapply wf_universe_closed. Qed. Lemma wf_universe_make Σ u : wf_universe Σ (Universe.of_level u) -> wf_level Σ u. @@ -974,30 +939,25 @@ Qed. intros ond. induction t using term_forall_list_ind; cbn => //; solve_all. - apply wf_sort_closed => //. destruct s => //=. - now move/wf_universe_reflect: H. + now move/wf_universeP: H. - eapply wf_instance_closed => //. apply All_forallb in H. - rewrite -forallb_map wf_universeb_instance_forall in H. now move/wf_instanceP: H. - eapply wf_instance_closed => //. apply All_forallb in H. - rewrite -forallb_map wf_universeb_instance_forall in H. now move/wf_instanceP: H. - eapply wf_instance_closed => //. apply All_forallb in H. - rewrite -forallb_map wf_universeb_instance_forall in H. now move/wf_instanceP: H. - unfold test_predicate_ku in *; solve_all. eapply wf_instance_closed => //. apply All_forallb in H0. - rewrite -forallb_map wf_universeb_instance_forall in H0. now move/wf_instanceP: H0. - unfold test_branch in *; solve_all. - unfold test_def in *; solve_all. - unfold test_def in *; solve_all. - eapply test_primu_test_primu_tPrimProp; tea; cbn; eauto. - intros. to_wfu. eapply wf_level_closed; tea. - now apply wf_universe_make. + intros. to_wfu. eapply wf_universe_closed; tea. Qed. Lemma wf_ctx_universes_closed {Σ} {wfΣ : wf Σ} {univs ctx} : @@ -1259,7 +1219,7 @@ Qed. End CheckerFlags. -Arguments wf_universe_reflect {Σ u}. +Arguments wf_universeP {Σ u}. #[global] Hint Resolve wf_sort_type1 wf_sort_super wf_sort_sup wf_sort_product : pcuic. #[global] diff --git a/pcuic/theories/Syntax/PCUICUnivSubst.v b/pcuic/theories/Syntax/PCUICUnivSubst.v index 8bef36261..74016bd1e 100644 --- a/pcuic/theories/Syntax/PCUICUnivSubst.v +++ b/pcuic/theories/Syntax/PCUICUnivSubst.v @@ -3,10 +3,21 @@ From Stdlib Require Import ssreflect. From MetaRocq.Utils Require Import utils. From MetaRocq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICInduction. +#[global] +Instance subst_level_instance_list A `{UnivLevelSubst A} : UnivLevelSubst (list A) := + fun u => List.map (subst_level_instance u). + #[global] Instance subst_instance_list A `{UnivSubst A} : UnivSubst (list A) := fun u => List.map (subst_instance u). +Lemma subst_level_instance_length (u1 : LevelInstance.t) u2 : + #|subst_level_instance u2 u1| = #|u1|. +Proof. + unfold subst_level_instance. + now rewrite length_map. +Qed. + Lemma subst_instance_instance_length (u1 : Instance.t) u2 : #|subst_instance u2 u1| = #|u1|. Proof. @@ -14,7 +25,15 @@ Proof. now rewrite length_map. Qed. #[global] -Hint Rewrite subst_instance_instance_length : len. +Hint Rewrite subst_level_instance_length subst_instance_instance_length : len. + +Lemma subst_level_instance_nil {A} {ua : UnivSubst A} u (xs : list A) : + subst_level_instance u [] = []. +Proof. reflexivity. Qed. + +Lemma subst_level_instance_cons {A} {ua : UnivLevelSubst A} u x (xs : list A) : + subst_level_instance u (x :: xs) = subst_level_instance u x :: subst_level_instance u xs. +Proof. reflexivity. Qed. Lemma subst_instance_nil {A} {ua : UnivSubst A} u (xs : list A) : subst_instance u [] = []. diff --git a/pcuic/theories/Typing/PCUICClosedTyp.v b/pcuic/theories/Typing/PCUICClosedTyp.v index c09dc4411..a14521a33 100644 --- a/pcuic/theories/Typing/PCUICClosedTyp.v +++ b/pcuic/theories/Typing/PCUICClosedTyp.v @@ -145,7 +145,7 @@ Proof. now eapply declared_projection_closed_ind in H. Qed. - +Arguments Nat.ltb : simpl never. Lemma typecheck_closed `{cf : checker_flags} : env_prop (fun Σ Γ t T => @@ -167,7 +167,8 @@ Proof. - pose proof (nth_error_Some_length H). elim (Nat.ltb_spec n #|Γ|); intuition auto. all: try lia. clear H1. - induction Γ in n, H, H0, H2 |- *. rewrite nth_error_nil in H. discriminate. + induction Γ in n, H, H0, H2 |- *. + { rewrite nth_error_nil in H. cbn in *. discriminate. } destruct n. simpl in H. noconf H. simpl. rewrite -Nat.add_1_r. apply closedn_lift. diff --git a/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v b/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v index 2a2debca5..7135c638c 100644 --- a/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v +++ b/pcuic/theories/Typing/PCUICUnivSubstitutionTyp.v @@ -121,8 +121,7 @@ Proof. cbn; intros; intuition eauto. rewrite -> subst_instance_app, fix_context_subst_instance in *; eauto. - eapply cumul_Prim. depelim e0; depelim X; cbn in H; cbn; noconf H; cbn in H; constructor; cbn -[Universe.make]; eauto. - + rewrite -!subst_instance_universe_make. - eapply eq_universe_subst_instance; tea. + + eapply eq_universe_subst_instance; tea. + solve_all. - repeat rewrite subst_instance_mkApps. eapply cumul_Ind. * apply precompose_subst_instance_global. @@ -195,13 +194,13 @@ Proof using Type. now eapply cumul_decls_subst_instance. Qed. -Lemma subst_instance_prim_type p prim_ty u : (prim_type p prim_ty)@[u] = prim_type (mapu_prim (subst_instance_level u) (subst_instance u) p) prim_ty. +Lemma subst_instance_prim_type p prim_ty u : (prim_type p prim_ty)@[u] = prim_type (mapu_prim (subst_instance_universe u) (subst_instance u) p) prim_ty. Proof. destruct p as [? []]; simp prim_type => //=. Qed. Lemma subst_instance_prim_val_tag (p : PCUICPrimitive.prim_val term) u : - prim_val_tag (mapu_prim (subst_instance_level u) (subst_instance u) p) = + prim_val_tag (mapu_prim (subst_instance_universe u) (subst_instance u) p) = prim_val_tag p. Proof. destruct p as [? []] => //=. @@ -397,10 +396,7 @@ Proof using Type. + exact H0. + now rewrite subst_instance_prim_val_tag. + destruct p as [? []]; depelim X1; constructor; eauto. - * rewrite -subst_instance_universe_make. eapply wf_universe_subst_instance => //. - * cbn -[Universe.of_level] in hty. - specialize (hty u univs). - rewrite /subst_instance subst_instance_universe_make in hty. now eapply hty. + * eapply wf_universe_subst_instance => //. * cbn. solve_all. - intros t0 A B X X0 X1 X2 X3 X4 cum u univs wfΣ' H. From f72ebb07d1dd98cf30e5659c4c975634b94fc8fa Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Wed, 5 Nov 2025 16:36:06 +0100 Subject: [PATCH 124/164] Validity ported --- pcuic/theories/Conversion/PCUICNamelessConv.v | 2 +- pcuic/theories/PCUICConfluence.v | 4 +--- pcuic/theories/PCUICConversion.v | 3 +-- pcuic/theories/PCUICParallelReductionConfluence.v | 1 - pcuic/theories/PCUICSpine.v | 4 +++- pcuic/theories/PCUICValidity.v | 14 ++++++++++---- 6 files changed, 16 insertions(+), 12 deletions(-) diff --git a/pcuic/theories/Conversion/PCUICNamelessConv.v b/pcuic/theories/Conversion/PCUICNamelessConv.v index 62ac47893..57a015bf6 100644 --- a/pcuic/theories/Conversion/PCUICNamelessConv.v +++ b/pcuic/theories/Conversion/PCUICNamelessConv.v @@ -136,7 +136,7 @@ Proof. - f_equal. destruct o; auto. f_equal. f_equal. cbn in X, hu, hv. rtoProp. - destruct X as (hty & hdef & harr). eapply Universe.of_level_inj in e. + destruct X as (hty & hdef & harr). destruct a, a'; cbn in *. f_equal; intuition eauto. apply All2_eq. solve_all. Qed. diff --git a/pcuic/theories/PCUICConfluence.v b/pcuic/theories/PCUICConfluence.v index b6915b002..ad274fbfa 100644 --- a/pcuic/theories/PCUICConfluence.v +++ b/pcuic/theories/PCUICConfluence.v @@ -2202,9 +2202,7 @@ Section PredRed. - eapply red_evar; eauto with fvs. solve_all. - depelim X1; try solve [repeat constructor]; eauto. depelim X2; cbn in H0; rtoProp. - eapply red_primArray_congr; eauto. - + now eapply Universe.of_level_inj in e. - + solve_all. + eapply red_primArray_congr; eauto. solve_all. Qed. Lemma pred1_red_r_gen P Γ Γ' Δ Δ' : forall M N, diff --git a/pcuic/theories/PCUICConversion.v b/pcuic/theories/PCUICConversion.v index f292cd85f..2affc8f2c 100644 --- a/pcuic/theories/PCUICConversion.v +++ b/pcuic/theories/PCUICConversion.v @@ -404,8 +404,7 @@ Section ConvCongruences. eapply on_free_vars_impl. 2:eapply on_free_vars_subst_gen; tea. intros i. - rewrite /substP /shiftnP !orb_false_r. - repeat nat_compare_specs => //. cbn. + rewrite /substP /shiftnP /strengthenP !orb_false_r. repeat nat_compare_specs => //. Qed. diff --git a/pcuic/theories/PCUICParallelReductionConfluence.v b/pcuic/theories/PCUICParallelReductionConfluence.v index 844d354ab..bdce09bf4 100644 --- a/pcuic/theories/PCUICParallelReductionConfluence.v +++ b/pcuic/theories/PCUICParallelReductionConfluence.v @@ -1177,7 +1177,6 @@ Section Rho. destruct H as [b' [Hb Heq']]. exists b'; intuition auto. rewrite -ren_shiftn. autorewrite with sigma in Heq' |- *. - rewrite Nat.sub_0_r. rewrite -?subst_compose_assoc -inst_assoc. rewrite -[b.[_]]inst_assoc. rewrite Heq'. now sigma. diff --git a/pcuic/theories/PCUICSpine.v b/pcuic/theories/PCUICSpine.v index 9c0d28285..a529bde64 100644 --- a/pcuic/theories/PCUICSpine.v +++ b/pcuic/theories/PCUICSpine.v @@ -1772,6 +1772,8 @@ Section WfEnv. eapply (PCUICSubstitution.substitution (Δ := [])) in Hs; tea. Qed. + Arguments Nat.leb : simpl never. + Lemma lift_to_extended_list_k n Γ : map (lift n #|Γ|) (to_extended_list_k Γ 0) = to_extended_list_k Γ 0. Proof using Type. @@ -1788,7 +1790,7 @@ Section WfEnv. now rewrite Nat.add_1_r IHΓ. specialize (IHΓ (tRel n' :: l) (S n')). rewrite Nat.add_succ_r in IHΓ. - rewrite Nat.add_1_r IHΓ. simpl. + rewrite Nat.add_1_r IHΓ. cbn -[leb]. destruct (leb_spec_Set (S (#|Γ| + n')) n'). lia. reflexivity. Qed. diff --git a/pcuic/theories/PCUICValidity.v b/pcuic/theories/PCUICValidity.v index 4d85d307a..6c44c43c8 100644 --- a/pcuic/theories/PCUICValidity.v +++ b/pcuic/theories/PCUICValidity.v @@ -158,6 +158,11 @@ Section Validity. exists xs; cbn. split; auto. Qed. + Lemma subst_instance_level_expr_0 u : subst_instance_level_expr [u] (LevelExpr.make (Level.lvar 0)) = u. + Proof. + now rewrite /subst_instance_level_expr //= plus_0. + Qed. + Import PCUICOnFreeVars. Theorem validity_env : @@ -335,13 +340,14 @@ Section Validity. depelim X0; depelim X1; simp prim_type; cbn in *. 1-3:destruct H1 as [hty hbod huniv]; eapply has_sort_isType with (s := _@[[]]); change (tSort ?s@[[]]) with (tSort s)@[[]]; rewrite <- hty; refine (type_Const _ _ _ [] _ wfΓ H0 _); rewrite huniv //. - set (s := sType (Universe.of_level (array_universe a))). + set (s := sType (array_universe a)). destruct H1 as [hty' hbod huniv]. eapply has_sort_isType with s. eapply (type_App _ _ _ _ (tSort s) (tSort s)); tea; cycle 1. - + eapply (type_Const _ _ _ [array_universe a]) in H0; tea. rewrite hty' in H0. cbn in H0. exact H0. - red. rewrite huniv. simpl. rtoProp; intuition eauto. eapply LevelSet.mem_spec. eapply (wfl (array_universe a, 0)). cbn. lsets. - cbn. red. destruct check_univs => //. red. red. intros v H c. csets. + + eapply (type_Const _ _ _ [array_universe a]) in H0; tea. rewrite hty' in H0. cbn in H0. + rewrite subst_instance_level_expr_0 in H0. exact H0. + red. rewrite huniv. simpl. rtoProp; intuition eauto. eapply LevelSet.subset_spec, subset_levels. eapply wfl. + cbn. red. destruct check_univs => //. red. red. intros v H c. ucsets. + econstructor. 2: econstructor; eauto. 2: constructor; tas. all: repeat (eexists; tea; cbn). 1,3: econstructor; eauto. From 7d9772c1e236129fd76ef47ad836ac95e0da0067 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 6 Nov 2025 07:41:32 +0100 Subject: [PATCH 125/164] Ported PCUICInductiveInversion (variance stuff lifted from levels to universes) --- common/theories/EnvironmentTyping.v | 14 +- .../Conversion/PCUICUnivSubstitutionConv.v | 4 +- pcuic/theories/PCUICInductiveInversion.v | 175 +++++++++++++----- 3 files changed, 134 insertions(+), 59 deletions(-) diff --git a/common/theories/EnvironmentTyping.v b/common/theories/EnvironmentTyping.v index 7a2a09962..e65f22e2e 100644 --- a/common/theories/EnvironmentTyping.v +++ b/common/theories/EnvironmentTyping.v @@ -1423,7 +1423,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Universe.map (on_fst (lift_level n)) u. Definition lift_instance n l := - map (lift_level n) l. + map (lift_universe n) l. Definition lift_constraint n (c : Universe.t * ConstraintType.t * Universe.t) := let '((l, r), l') := c in @@ -1433,17 +1433,17 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT UnivConstraintSet.fold (fun elt acc => UnivConstraintSet.add (lift_constraint n elt) acc) cstrs UnivConstraintSet.empty. - Definition level_var_instance n (inst : list name) := + Definition level_var_instance n (inst : list name) : LevelInstance.t := mapi_rec (fun i _ => Level.lvar i) inst n. - Fixpoint variance_cstrs (v : list Variance.t) (u u' : LevelInstance.t) := + Fixpoint variance_cstrs (v : list Variance.t) (u u' : Instance.t) := match v, u, u' with | _, [], [] => UnivConstraintSet.empty | v :: vs, u :: us, u' :: us' => match v with | Variance.Irrelevant => variance_cstrs vs us us' - | Variance.Covariant => UnivConstraintSet.add (Universe.of_level u, ConstraintType.Le, Universe.of_level u') (variance_cstrs vs us us') - | Variance.Invariant => UnivConstraintSet.add (Universe.of_level u, ConstraintType.Eq, Universe.of_level u') (variance_cstrs vs us us') + | Variance.Covariant => UnivConstraintSet.add (u, ConstraintType.Le, u') (variance_cstrs vs us us') + | Variance.Invariant => UnivConstraintSet.add (u, ConstraintType.Eq, u') (variance_cstrs vs us us') end | _, _, _ => (* Impossible due to on_variance invariant *) UnivConstraintSet.empty end. @@ -1457,12 +1457,12 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT | Monomorphic_ctx => None | Polymorphic_ctx auctx => let (inst, cstrs) := auctx in - let u' := level_var_instance 0 inst in + let u' : Instance.t := level_var_instance 0 inst in let u := lift_instance #|inst| u' in let cstrs := UnivConstraintSet.union cstrs (lift_constraints #|inst| cstrs) in let cstrv := variance_cstrs v u u' in let auctx' := (inst ++ inst, UnivConstraintSet.union cstrs cstrv) in - Some (Polymorphic_ctx auctx', Instance.of_level_instance u, Instance.of_level_instance u') + Some (Polymorphic_ctx auctx', u, u') end. (** A constructor type respects the given variance [v] if each constructor diff --git a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v index 6ce542cdd..64895aca4 100644 --- a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v +++ b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v @@ -1041,7 +1041,9 @@ Lemma In_subst_instance x u (l : Universe.t) : Proof. unfold subst_instance; cbn. unfold subst_instance_universe. -Admitted. + rewrite Universe.fold_union_spec. + firstorder. +Qed. Lemma subst_instance_univ_super l u : subst_instance_sort u (Sort.super l) = Sort.super (subst_instance u l). diff --git a/pcuic/theories/PCUICInductiveInversion.v b/pcuic/theories/PCUICInductiveInversion.v index 237cadfdd..072470043 100644 --- a/pcuic/theories/PCUICInductiveInversion.v +++ b/pcuic/theories/PCUICInductiveInversion.v @@ -1728,7 +1728,7 @@ Section Betweenu. end. Definition betweenu_instance (u : Instance.t) := - forallb betweenu_level u. + forallb betweenu_universe u. End Betweenu. @@ -1739,7 +1739,27 @@ Section UniverseClosedSubst. Proof. destruct l; cbnr. intros Hn % Nat.ltb_lt. - rewrite app_nth1 //. + rewrite nth_error_app_lt //. + Qed. + + Lemma closedu_subst_instance_level_expr_app u u' e + : closedu_level_expr #|u'| e -> subst_instance_level_expr (u' ++ u) e = subst_instance_level_expr u' e. + Proof. + destruct e as [l b]; unfold subst_instance_level_expr; cbn. + move/(@closedu_subst_instance_level_app u u' l) => -> //. + Qed. + + Lemma closedu_subst_instance_universe_app u u' (e : Universe.t) + : closedu_universe #|u'| e -> subst_instance (u' ++ u) e = subst_instance u' e. + Proof. + rewrite /subst_instance //= => hc. + apply Universe.equal_exprsets => l. + rewrite !In_subst_instance. firstorder. exists x; split => //. + - rewrite closedu_subst_instance_level_expr_app in H0 => //. + now move/LevelExprSet.for_all_spec: hc => /(_ x H). + - exists x; split => //. + rewrite closedu_subst_instance_level_expr_app //. + now move/LevelExprSet.for_all_spec: hc => /(_ x H). Qed. Lemma closedu_subst_instance_level_lift u u' l @@ -1747,32 +1767,60 @@ Section UniverseClosedSubst. Proof. destruct l; cbnr. intros Hn % Nat.ltb_lt. - rewrite app_nth2; try lia. - lia_f_equal. + rewrite nth_error_app_ge. lia. + now have -> : #|u'| + n - #|u'| = n by lia. Qed. - Lemma closedu_subst_instance_level_expr_app u u' e - : closedu_level_expr #|u'| e -> subst_instance_level_expr (u' ++ u) e = subst_instance_level_expr u' e. + Notation lift_level_expr n e := (lift_level n e.1, e.2). + + Lemma closedu_subst_instance_level_expr_lift u u' e + : closedu_level_expr #|u| e -> subst_instance_level_expr (u' ++ u) (lift_level_expr #|u'| e) = subst_instance_level_expr u e. Proof. - destruct e as [[] b]; cbnr. - intros Hn % Nat.ltb_lt. - rewrite nth_error_app_lt //. + destruct e as [l b]; cbnr. + move/closedu_subst_instance_level_lift => /(_ u'). + rewrite /subst_instance_level_expr //= => -> //. + Qed. + + Lemma subst_instance_universe_eq i (u v : Universe.t) : + (forall le, LevelExprSet.In le u -> LevelExprSet.Subset (subst_instance_level_expr i le) v) -> + (forall le, LevelExprSet.In le v -> exists le', LevelExprSet.In le' u /\ LevelExprSet.In le (subst_instance_level_expr i le')) -> + u@[i] = v. + Proof. + intros h h'. + apply Universe.equal_exprsets => l. + split. + - move/In_subst_instance => -[] x' [] hin heq. + eapply h; tea. + - move/h' => -[] le' [] hin hs. + apply In_subst_instance. exists le'. split => //. Qed. + Lemma In_lift_universe le n u : LevelExprSet.In le (lift_universe n u) <-> + exists le', LevelExprSet.In le' u /\ le = lift_level_expr n le'. + Proof. + rewrite Universe.map_spec. firstorder. + Qed. - (* Lemma closedu_subst_instance_level_expr_lilft u u' e - : closedu_level_expr #|u| e -> subst_instance_level_expr (u' ++ u) (lift_expr e = subst_instance_level_expr u' e. + Lemma closedu_subst_instance_universe_lift u u' e + : closedu_universe #|u| e -> subst_instance_universe (u' ++ u) (lift_universe #|u'| e) = subst_instance_universe u e. Proof. - destruct e as [|[[] b]]; cbnr. - intros Hn % Nat.ltb_lt. - rewrite nth_error_app_lt //. - Qed. *) + move/LevelExprSet.for_all_spec => hf. + apply subst_instance_universe_eq. + - move=> le /In_lift_universe -[] lel [] hin eq inl. subst le. + rewrite closedu_subst_instance_level_expr_lift. now apply hf. + move=> hin'; apply In_subst_instance. exists lel => //. + - move=> le /In_subst_instance -[] x' [] hin. + erewrite <- (closedu_subst_instance_level_expr_lift _ u'). 2:{ now apply hf. } + destruct x'. cbn -[subst_instance_level_expr]. + exists (lift_level #|u'| t, n). split => //. + eapply Universe.map_spec. eexists; split; trea. unfold on_fst. cbn. reflexivity. + Qed. Lemma closedu_subst_instance_app u u' t : closedu_instance #|u'| t -> subst_instance (u' ++ u) t = subst_instance u' t. Proof. intro H. eapply forallb_All in H. apply All_map_eq. - solve_all. now eapply closedu_subst_instance_level_app. + solve_all. now eapply closedu_subst_instance_universe_app. Qed. Lemma closedu_subst_instance_lift u u' t @@ -1780,7 +1828,7 @@ Section UniverseClosedSubst. Proof. intro H. eapply forallb_All in H. rewrite /subst_instance /subst_instance_instance /lift_instance map_map_compose. apply All_map_eq. - solve_all. now eapply closedu_subst_instance_level_lift. + solve_all. now eapply closedu_subst_instance_universe_lift. Qed. End UniverseClosedSubst. @@ -1821,8 +1869,8 @@ Proof. do 3 eexists; split. trea. all:eauto. 1-3:len. repeat match goal with H : _ |- _ => progress len in H end. len. - rewrite /closedu_instance /level_var_instance forallb_mapi //. - intros i hi. simpl. now eapply Nat.ltb_lt. + rewrite /closedu_instance /level_var_instance forallb_map forallb_mapi //. + intros i hi. simpl. now elim: Nat.ltb_spec. now len. Qed. @@ -1842,9 +1890,9 @@ Proof. rewrite /consistent_instance_ext /=; intros [_ [_ v]] cu. red in v. now rewrite cu in v. Qed. -Definition closedu_cstr k (cstr : (Level.t * ConstraintType.t * Level.t)) := +Definition closedu_cstr k (cstr : UnivConstraint.t) := let '(l1, p, l2) := cstr in - closedu_level k l1 && closedu_level k l2. + closedu_universe k l1 && closedu_universe k l2. Definition closedu_cstrs k (cstrs : UCS.t) := UCS.For_all (closedu_cstr k) cstrs. @@ -1864,6 +1912,14 @@ Proof. specialize (IHinst _ H). now rewrite Nat.add_succ_r. Qed. +Lemma bounded_poly_levels ls inst cstrs : LevelSet.Subset (Universe.levels ls) (levels_of_udecl (Polymorphic_ctx (inst, cstrs))) -> + closedu_universe #|inst| ls. +Proof. + move=> /subset_levels hs. + apply LevelExprSet.for_all_spec; tc. + move=> [l k] /hs. apply LSet_in_poly_bounded. +Qed. + Lemma LSet_in_global_bounded {cf:checker_flags} {Σ : global_env} {l} k : wf Σ -> LevelSet.In l (global_levels Σ) -> closedu_level k l. @@ -1874,6 +1930,29 @@ Proof. destruct l; simpl in *; congruence. Qed. +Lemma bounded_global_levels {cf:checker_flags} {Σ : global_env} {ls} k : + wf Σ -> LevelSet.Subset (Universe.levels ls) (global_levels Σ) -> + closedu_universe k ls. +Proof. + move=> wf /subset_levels hs. + apply LevelExprSet.for_all_spec; tc. + move=> [l k'] /hs. now apply LSet_in_global_bounded. +Qed. + +Lemma bounded_poly_global_levels {cf:checker_flags} {Σ : global_env} {ls} inst cstrs : + wf Σ -> LevelSet.Subset (Universe.levels ls) (LevelSet.union (levels_of_udecl (Polymorphic_ctx (inst, cstrs))) (global_levels Σ)) -> + closedu_universe #|inst| ls. +Proof. + move=> wf. + move=> /subset_levels hs. + apply LevelExprSet.for_all_spec; tc. + move=> [l k'] /hs. + rewrite LevelSet.union_spec => -[H|H]. + - rewrite /closedu_level_expr //=. + eapply LSet_in_poly_bounded; tea. + - eapply LSet_in_global_bounded; tea. +Qed. + Lemma on_udecl_prop_poly_bounded {cf:checker_flags} Σ inst cstrs : wf Σ -> on_udecl_prop Σ (Polymorphic_ctx (inst, cstrs)) -> @@ -1887,16 +1966,8 @@ Proof. specialize (nlevs x incstrs). destruct x as [[l1 p] l2]. destruct nlevs. - apply LevelSetProp.Dec.F.union_1 in H. - apply LevelSetProp.Dec.F.union_1 in H0. - destruct H. eapply LSet_in_poly_bounded in H. - destruct H0. eapply LSet_in_poly_bounded in H0. simpl. now rewrite H H0. - eapply (LSet_in_global_bounded #|inst|) in H0 => //. simpl. - now rewrite H H0. - eapply (LSet_in_global_bounded #|inst|) in H => //. simpl. - destruct H0. eapply LSet_in_poly_bounded in H0. simpl. now rewrite H H0. - eapply (LSet_in_global_bounded #|inst|) in H0 => //. simpl. - now rewrite H H0. + unfold closedu_cstr. toProp; + eapply bounded_poly_global_levels; tea. Qed. Lemma closedu_subst_instance_cstrs_app u u' cstrs : @@ -1910,16 +1981,16 @@ Proof. subst c; exists x; split; auto. specialize (clcstra _ H0). simpl in *. - destruct x as [[l c] r]; rewrite /subst_instance_cstr; simpl. + destruct x as [[l c] r]; rewrite /subst_instance_univ_cstr; simpl. move/andb_and: clcstra => [cll clr]. - rewrite !closedu_subst_instance_level_app //. + rewrite !closedu_subst_instance_universe_app //. subst c; exists x; split; auto. specialize (clcstra _ H0). simpl in *. - destruct x as [[l c] r]; rewrite /subst_instance_cstr; simpl. + destruct x as [[l c] r]; rewrite /subst_instance_univ_cstr; simpl. move/andb_and: clcstra => [cll clr]. - rewrite !closedu_subst_instance_level_app //. + rewrite !closedu_subst_instance_universe_app //. Qed. @@ -1947,7 +2018,7 @@ Proof. -- left. destruct c' as [[l1 c'] l2]; apply UCS.add_spec; now left. -- right. exists c'. intuition. - - rewrite ConstraintSetFact.empty_iff. + - rewrite UnivConstraintSetFact.empty_iff. transitivity (exists c', c = lift_constraint u c' /\ In c' (UCS.elements ctrs)). 1: intuition. @@ -1973,9 +2044,9 @@ Proof. exists c'. split; auto. specialize (clcstra _ inc'). simpl in *. - destruct c' as [[l c] r]; rewrite /subst_instance_cstr; simpl. + destruct c' as [[l c] r]; rewrite /subst_instance_univ_cstr; simpl. move/andb_and: clcstra => [cll clr]. - rewrite !closedu_subst_instance_level_lift //. + rewrite ![_@[_ ++ _]]closedu_subst_instance_universe_lift //. - subst c. exists (lift_constraint #|u| x). @@ -1983,29 +2054,29 @@ Proof. pcuicfo eauto. specialize (clcstra _ H0). simpl in *. - destruct x as [[l c] r]; rewrite /subst_instance_cstr; simpl. + destruct x as [[l c] r]; rewrite /subst_instance_univ_cstr; simpl. move/andb_and: clcstra => [cll clr]. - rewrite !closedu_subst_instance_level_lift //. + rewrite ![_@[_ ++ _]]closedu_subst_instance_universe_lift //. Qed. Lemma subst_instance_cstrs_add u x c : UCS.Equal (subst_instance_cstrs u (UnivConstraintSet.add x c)) - (UnivConstraintSet.add (subst_instance_cstr u x) (subst_instance_cstrs u c)). + (UnivConstraintSet.add (subst_instance_univ_cstr u x) (subst_instance_cstrs u c)). Proof. intros cc. - rewrite ConstraintSetFact.add_iff. + rewrite UnivConstraintSetFact.add_iff. rewrite !In_subst_instance_cstrs. intuition auto. destruct H as [c' [-> inc']]. - rewrite -> ConstraintSetFact.add_iff in inc'. + rewrite -> UnivConstraintSetFact.add_iff in inc'. destruct inc'; subst; intuition auto. right. eexists; intuition eauto. subst. exists x; intuition eauto. - now rewrite ConstraintSetFact.add_iff. + now rewrite UnivConstraintSetFact.add_iff. destruct H0 as [c' [-> ?]]. eexists c'; split; firstorder eauto. - now rewrite ConstraintSetFact.add_iff. + now rewrite UnivConstraintSetFact.add_iff. Qed. Lemma subst_instance_variance_cstrs l u i i' : @@ -2053,7 +2124,9 @@ Proof. subst i. pose proof (consistent_instance_length cu). pose proof (consistent_instance_length cu'). - rewrite -eqi' in H, H0. + have he : #|abstract_instance (ind_universes mdecl)| = #|i'|. + { len. subst i'. len. } + rewrite he in H H0. rewrite -H0 in cum. assert (subst_instance (u' ++ u) (lift_instance #|u'| i') = u) as subsu. { rewrite closedu_subst_instance_lift //. @@ -2106,18 +2179,18 @@ Proof. assert (#|l| = #|u|) as lenlu. now rewrite len1 H. clear -checku Ru sat lenu lenlu. induction l in u, u', Ru, lenu, lenlu |- *. simpl in *. destruct u, u'; - intro; rewrite ConstraintSetFact.empty_iff //. + intro; rewrite UnivConstraintSetFact.empty_iff //. destruct u, u' => //; simpl in *. depelim Ru. rename H into Ra. specialize (IHl u u' Ru). do 2 forward IHl by lia. - destruct a => //; intros x; rewrite ConstraintSetFact.add_iff; + destruct a => //; intros x; rewrite UnivConstraintSetFact.add_iff; intros [<-|inx]; auto. - + do 5 red in Ra; rewrite checku in Ra; + + do 3 red in Ra. rewrite checku in Ra; specialize (Ra _ sat); simpl in Ra. constructor. lia. - + do 4 red in Ra. rewrite checku in Ra. + + do 3 red in Ra. rewrite checku in Ra. specialize (Ra _ sat). - constructor. now rewrite !Universes.Universe.val_make in Ra. + now constructor. Qed. Lemma All2_fold_inst {cf} {le} {Σ} {wfΣ : wf Σ} mdecl l v i i' u u' Γ' Γ : From bbb09292bddabf34fd7c699de1df9ff3b7c9b2d7 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 6 Nov 2025 16:02:11 +0100 Subject: [PATCH 126/164] Ported the safe type checker --- common/theories/uGraph.v | 27 ++ pcuic/theories/PCUICAlpha.v | 2 +- pcuic/theories/PCUICCumulProp.v | 28 +- pcuic/theories/PCUICExpandLetsCorrectness.v | 5 +- pcuic/theories/PCUICFirstorder.v | 3 + pcuic/theories/PCUICNormal.v | 3 +- quotation/theories/CommonUtils.v | 3 +- safechecker/theories/PCUICEqualityDec.v | 417 +++++++++++------- safechecker/theories/PCUICErrors.v | 11 +- safechecker/theories/PCUICSafeConversion.v | 38 +- safechecker/theories/PCUICTypeChecker.v | 224 +++++----- safechecker/theories/PCUICWfEnv.v | 79 ++-- safechecker/theories/PCUICWfEnvImpl.v | 55 ++- .../theories/TemplateToPCUICCorrectness.v | 4 +- 14 files changed, 489 insertions(+), 410 deletions(-) diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index 81d6f3f65..c56904f1f 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -590,6 +590,33 @@ Section CheckLeq. move=> hv v /hv. now constructor. Qed. + + Lemma check_leqb_sort_spec_gen check + (leqb_correct : check_spec check) + (u1 u2 : Sort.t) + (Hu1 : levels_declared_sort u1) + (Hu2 : levels_declared_sort u2) + : check_leqb_sort_gen check u1 u2 <-> leq_sort uctx.2 u1 u2. + Proof. + unfold check_leqb_sort_gen, leq_sort. + destruct u1, u2; cbnr; split; intuition auto. + - toProp. destruct H. + apply (@elimP _ _ (eqb_spec _ _)) in H. noconf H. + reflexivity. + apply (check_leqb_universe_spec_gen _ leqb_correct) in H. + unfold valid_cstr, valid0_cstr in H. + unfold Universes.leq_universe, Universes.leq0_universe; + destruct check_univs => //. + now move=> v /H; intros s; depelim s. + all:split; now apply levels_declared_uctx. + - toProp; right. + apply/(check_leqb_universe_spec_gen _ leqb_correct). + * split; now apply levels_declared_uctx. + * move: H; rewrite /Universes.leq_universe /Universes.leq0_universe. + unfold valid_cstr, valid0_cstr. destruct check_univs => //. + move=> hv v /hv. now constructor. + Qed. + Definition check_eqb_sort_spec := check_eqb_sort_spec_gen _ checkb_spec. Lemma check_constraints_spec_gen checkb diff --git a/pcuic/theories/PCUICAlpha.v b/pcuic/theories/PCUICAlpha.v index 9e4ebc414..344ad4064 100644 --- a/pcuic/theories/PCUICAlpha.v +++ b/pcuic/theories/PCUICAlpha.v @@ -883,7 +883,7 @@ Section Alpha. eapply eq_term_upto_univ_cumulSpec. eapply eq_term_leq_term. eapply e1. * eapply eq_context_conversion in Hs; eauto. - * simp prim_type. eapply Universe.of_level_inj in e. rewrite e. + * simp prim_type. rewrite e. eapply eq_term_upto_univ_cumulSpec. eapply upto_names_impl_leq_term. constructor. constructor. reflexivity. now symmetry. diff --git a/pcuic/theories/PCUICCumulProp.v b/pcuic/theories/PCUICCumulProp.v index 6df8e454c..cd33c97b0 100644 --- a/pcuic/theories/PCUICCumulProp.v +++ b/pcuic/theories/PCUICCumulProp.v @@ -353,11 +353,13 @@ Lemma LevelExprSet_For_all (P : LevelExpr.t -> Prop) (u : Universe.t) : LevelExprSet.For_all P u <-> Forall P (LevelExprSet.elements u). Proof using Type. - rewrite NonEmptySetFacts.LevelExprSet_For_all_exprs. - pose proof (NonEmptySetFacts.to_nonempty_list_spec u). - destruct (NonEmptySetFacts.to_nonempty_list u). rewrite -H. simpl. - split. constructor; intuition. - intros H'; inv H'; intuition. + pose proof (Universe.to_nonempty_list_spec u). + pose proof (Universe.to_nonempty_list_spec' u). + rewrite (Universe.For_all_exprs P u). + destruct (Universe.to_nonempty_list u). rewrite -H. simpl. + split. + - constructor; intuition. + - intros H'; inv H'; intuition. Qed. Lemma univ_expr_set_in_elements e s : @@ -368,16 +370,12 @@ Proof using Type. Qed. Lemma univ_epxrs_elements_map g s : - forall e, In e (LevelExprSet.elements (NonEmptySetFacts.map g s)) <-> + forall e, In e (LevelExprSet.elements (Universe.map g s)) <-> In e (map g (LevelExprSet.elements s)). Proof using Type. intros e. - unfold NonEmptySetFacts.map. - pose proof (NonEmptySetFacts.to_nonempty_list_spec s). - destruct (NonEmptySetFacts.to_nonempty_list s) as [e' l] eqn:eq. - rewrite -univ_expr_set_in_elements NonEmptySetFacts.add_list_spec. - rewrite -H. simpl. rewrite LevelExprSet.singleton_spec. - intuition auto. + rewrite -Universe.In_elements Universe.map_spec in_map_iff; setoid_rewrite <- Universe.In_elements. + firstorder. Qed. Lemma Forall_elements_in P s : Forall P (LevelExprSet.elements s) <-> @@ -394,18 +392,18 @@ Proof using Type. Qed. Lemma univ_exprs_map_all P g s : - Forall P (LevelExprSet.elements (NonEmptySetFacts.map g s)) <-> + Forall P (LevelExprSet.elements (Universe.map g s)) <-> Forall (fun x => P (g x)) (LevelExprSet.elements s). Proof using Type. rewrite !Forall_elements_in. - setoid_rewrite NonEmptySetFacts.map_spec. + setoid_rewrite Universe.map_spec. intuition auto. eapply H. now exists x. destruct H0 as [e' [ins ->]]. apply H; auto. Qed. Lemma expr_set_forall_map f g s : - LevelExprSet.for_all f (NonEmptySetFacts.map g s) <-> + LevelExprSet.for_all f (Universe.map g s) <-> LevelExprSet.for_all (fun e => f (g e)) s. Proof using Type. rewrite /is_true !LevelExprSet.for_all_spec !LevelExprSet_For_all. diff --git a/pcuic/theories/PCUICExpandLetsCorrectness.v b/pcuic/theories/PCUICExpandLetsCorrectness.v index 16f424cde..17efab243 100644 --- a/pcuic/theories/PCUICExpandLetsCorrectness.v +++ b/pcuic/theories/PCUICExpandLetsCorrectness.v @@ -2903,9 +2903,8 @@ Lemma on_free_vars_subst_k s k t : Proof. intros ons ont. eapply on_free_vars_impl; [|eapply on_free_vars_subst_gen]; tea. - intros i. rewrite /substP /shiftnP. + intros i. rewrite /substP /shiftnP /strengthenP. repeat nat_compare_specs; cbn; auto. - nat_compare_specs => //. Qed. Lemma on_free_vars_expand_lets_k P Γ k t : @@ -4614,7 +4613,7 @@ Lemma sub_context_set_empty s : sub_context_set ContextSet.empty s. Proof. red. split. intros x hin. cbn in hin. now eapply LevelSetFact.empty_iff in hin. - intros x hin. cbn in hin. now eapply ConstraintSetFact.empty_iff in hin. + intros x hin. cbn in hin. now eapply UnivConstraintSetFact.empty_iff in hin. Qed. Lemma wt_subst_instance {cf} {Σ : global_env} {ϕ : universes_decl} {Γ T u univs} : diff --git a/pcuic/theories/PCUICFirstorder.v b/pcuic/theories/PCUICFirstorder.v index 924979465..f26e7c25a 100644 --- a/pcuic/theories/PCUICFirstorder.v +++ b/pcuic/theories/PCUICFirstorder.v @@ -437,6 +437,9 @@ Proof using Type. all: destruct l; eauto. Qed. +Arguments Nat.leb : simpl never. +Arguments Nat.ltb : simpl never. + Lemma firstorder_args {Σ : global_env_ext} {wfΣ : wf Σ} { mind cbody i n ui args u pandi oind} : declared_constructor Σ (i, n) mind oind cbody -> PCUICArities.typing_spine Σ [] (type_of_constructor mind cbody (i, n) ui) args (mkApps (tInd i u) pandi) -> diff --git a/pcuic/theories/PCUICNormal.v b/pcuic/theories/PCUICNormal.v index 8a37ca532..931c5ba7c 100644 --- a/pcuic/theories/PCUICNormal.v +++ b/pcuic/theories/PCUICNormal.v @@ -1049,7 +1049,6 @@ Proof. eauto. - depelim o. 1-3: reflexivity. eapply red_primArray_congr; eauto. - now eapply Universe.of_level_inj in e. Qed. #[global] @@ -1407,7 +1406,7 @@ Proof. apply fix_context_pres_let_bodies. now apply All2_length in a. - constructor. depelim o; depelim o0; constructor; eauto. - * rewrite -x //. + * etransitivity; tea. * etransitivity; tea. * etransitivity; tea. * eapply All2_trans; eauto. diff --git a/quotation/theories/CommonUtils.v b/quotation/theories/CommonUtils.v index 21572dbff..475021d7f 100644 --- a/quotation/theories/CommonUtils.v +++ b/quotation/theories/CommonUtils.v @@ -298,7 +298,8 @@ Module WithTemplate. End LevelExprSet. Module nonEmptyLevelExprSet. - Definition prefix_with (prefix : string) (l : nonEmptyLevelExprSet) : nonEmptyLevelExprSet + Import Universe.NES. + Definition prefix_with (prefix : string) (l : Universe.t) : Universe.t := {| t_set := LevelExprSet.prefix_with prefix l.(t_set) ; t_ne := eq_trans LevelExprSet.is_empty_prefix_with l.(t_ne) |}. End nonEmptyLevelExprSet. diff --git a/safechecker/theories/PCUICEqualityDec.v b/safechecker/theories/PCUICEqualityDec.v index 6a86b4a1d..491211056 100644 --- a/safechecker/theories/PCUICEqualityDec.v +++ b/safechecker/theories/PCUICEqualityDec.v @@ -18,13 +18,13 @@ Set Default Goal Selector "!". Lemma consistent_instance_wf_sort `{checker_flags} Σ uctx u : consistent_instance_ext Σ uctx u -> - Forall (wf_universe Σ) (map Universe.of_level u). + Forall (wf_universe Σ) u. Proof. move => /consistent_instance_ext_wf /wf_instanceP. rewrite -wf_universeb_instance_forall. move => /forallb_Forall ?. eapply Forall_impl ; tea. - move => ? /wf_universe_reflect //. + move => ? /wf_universeP //. Qed. Lemma ctx_inst_on_universes Σ Γ ts Ts : @@ -42,12 +42,12 @@ Qed. Definition compare_universe_variance (cmpu : conv_pb -> Universe.t -> Universe.t -> bool) pb v u u' := match v with | Variance.Irrelevant => true - | Variance.Covariant => cmpu pb (Universe.of_level u) (Universe.of_level u') - | Variance.Invariant => cmpu Conv (Universe.of_level u) (Universe.of_level u') + | Variance.Covariant => cmpu pb u u' + | Variance.Invariant => cmpu Conv u u' end. -Definition compare_universe_instance equ u u' := - forallb2 (fun u u' => equ (Universe.of_level u) (Universe.of_level u')) u u'. +Definition compare_universe_instance equ (u u' : Instance.t) := + forallb2 equ u u'. Definition compare_universe_instance_variance cmpu pb v u u' := forallb3 (compare_universe_variance cmpu pb) v u u'. @@ -190,8 +190,8 @@ Qed. Lemma reflect_cmp_universe_instance (p : Universe.t -> bool) cmpu cmp_universe ui ui' : (forall u u', p u -> p u' -> reflect (cmp_universe u u') (cmpu u u')) -> - forallb p (map Universe.of_level ui) -> - forallb p (map Universe.of_level ui') -> + forallb p ui -> + forallb p ui' -> reflect (cmp_universe_instance cmp_universe ui ui') (compare_universe_instance cmpu ui ui'). Proof. intros he hui hui'. @@ -205,8 +205,8 @@ Qed. Lemma reflect_cmp_universe_instance_variance (p : Universe.t -> bool) cmpu cmp_universe pb v ui ui' : (forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) -> (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> - forallb p (map Universe.of_level ui) -> - forallb p (map Universe.of_level ui') -> + forallb p ui -> + forallb p ui' -> reflect (cmp_universe_instance_variance cmp_universe pb v ui ui') (compare_universe_instance_variance cmpu pb v ui ui'). Proof. intros he hle hui hui'. @@ -230,8 +230,8 @@ Qed. Lemma reflect_cmp_global_instance' lookup (p : Universe.t -> bool) cmpu cmp_universe pb gr napp ui ui' : (forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) -> (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> - forallb p (map Universe.of_level ui) -> - forallb p (map Universe.of_level ui') -> + forallb p ui -> + forallb p ui' -> reflect (cmp_global_instance_gen lookup cmp_universe pb gr napp ui ui') (compare_global_instance lookup cmpu pb gr napp ui ui'). Proof. @@ -253,8 +253,8 @@ Lemma reflect_cmp_global_instance Σ lookup (p : Universe.t -> bool) cmpu cmp_un (forall u u', p u -> p u' -> reflect (cmp_universe Conv u u') (cmpu Conv u u')) -> (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> (forall kn, lookup_env Σ kn = lookup kn) -> - forallb p (map Universe.of_level ui) -> - forallb p (map Universe.of_level ui') -> + forallb p ui -> + forallb p ui' -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (compare_global_instance lookup cmpu pb gr napp ui ui'). Proof. @@ -456,8 +456,8 @@ Lemma reflect_eq_term_upto_univ Σ (p : Universe.t -> bool) (q : nat -> term -> (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> (forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort Conv s s') (cmps Conv s s')) -> (forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort pb s s') (cmps pb s s')) -> - (forall gr napp ui ui', forallb p (map Universe.of_level ui) -> forallb p (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> - (forall gr napp ui ui', forallb p (map Universe.of_level ui) -> forallb p (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> + (forall gr napp ui ui', forallb p ui -> forallb p ui' -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> + (forall gr napp ui ui', forallb p ui -> forallb p ui' -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> forall t t', on_universes p q t -> on_universes p q t' -> @@ -537,8 +537,8 @@ Lemma eqb_term_upto_univ_impl Σ (p : Universe.t -> bool) (q : nat -> term -> bo (forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) -> (forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort Conv s s') (cmps Conv s s')) -> (forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort pb s s') (cmps pb s s')) -> - (forall gr napp ui ui', forallb p (map Universe.of_level ui) -> forallb p (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> - (forall gr napp ui ui', forallb p (map Universe.of_level ui) -> forallb p (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> + (forall gr napp ui ui', forallb p ui -> forallb p ui' -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> + (forall gr napp ui ui', forallb p ui -> forallb p ui' -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> forall t t', on_universes p q t -> on_universes p q t' -> eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance pb napp t t' -> eq_term_upto_univ_napp Σ cmp_universe cmp_sort pb napp t t'. @@ -588,7 +588,7 @@ Proof. 1-4: apply idP. 1-2: rewrite -Hcompare; eapply reflect_cmp_global_instance; intros; eauto using idP. 1-2: rewrite Hequ; eauto using idP. - 1-4: now apply/wf_universe_reflect. + 1-4: now apply/wf_universeP. 1-2: rewrite Heqs; eauto using idP. 1-4: now apply/wf_sort_reflect. 1-2: rewrite -Hgen_compare -Hcompare; eapply reflect_cmp_global_instance; intros; eauto using idP. @@ -624,18 +624,18 @@ Qed. Lemma cmp_universe_instance_refl_wf Σ (cmp_universe : Universe.t -> Universe.t -> Prop) l : (forall u, wf_universe Σ u -> cmp_universe u u) -> - forallb (wf_universeb Σ) (map Universe.of_level l) -> + forallb (wf_universeb Σ) l -> cmp_universe_instance cmp_universe l l. Proof. intros rRE Hl. unfold cmp_universe_instance. solve_all. eapply All_All2; tea. intros. apply rRE. - now apply/wf_universe_reflect. + now apply/wf_universeP. Qed. Lemma cmp_global_instance_refl_wf Σ (cmp_universe : conv_pb -> Universe.t -> Universe.t -> Prop) gr pb napp l : (forall u, wf_universe Σ u -> cmp_universe Conv u u) -> - forallb (wf_universeb Σ) (map Universe.of_level l) -> + forallb (wf_universeb Σ) l -> cmp_global_instance Σ cmp_universe pb gr napp l l. Proof. intros rRE Hl. @@ -676,7 +676,7 @@ Proof. eapply All_All2; eauto; simpl; intuition eauto; apply andb_and in a as [? ?]; eauto. - destruct p as [? []]; cbn -[Universe.of_level] in X, wt; rtoProp; intuition eauto; constructor; eauto. - + eapply hU. now move/wf_universe_reflect: H. + + eapply hU. now move/wf_universeP: H. + solve_all. eapply All_All2; eauto; simpl; intuition eauto. Defined. @@ -684,8 +684,8 @@ Lemma eqb_term_upto_univ_refl Σ (cmpu : forall _ _ _, bool) (cmps : forall _ _ (forall u, wf_universe Σ u -> cmpu Conv u u) -> (forall s, wf_sort Σ s -> cmps Conv s s) -> (forall s, wf_sort Σ s -> cmps pb s s) -> - (forall gr napp ui ui', forallb (wf_universeb Σ) (map Universe.of_level ui) -> forallb (wf_universeb Σ) (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmpu Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> - (forall gr napp ui ui', forallb (wf_universeb Σ) (map Universe.of_level ui) -> forallb (wf_universeb Σ) (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmpu pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> + (forall gr napp ui ui', forallb (wf_universeb Σ) ui -> forallb (wf_universeb Σ) ui' -> reflect (cmp_global_instance Σ cmpu Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) -> + (forall gr napp ui ui', forallb (wf_universeb Σ) ui -> forallb (wf_universeb Σ) ui' -> reflect (cmp_global_instance Σ cmpu pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')) -> wf_universes Σ t -> eqb_term_upto_univ_napp cmpu cmps gen_compare_global_instance pb napp t t. Proof. @@ -726,8 +726,8 @@ Section reflectContext. (hu' : forall u u', p u -> p u' -> reflect (cmp_universe pb u u') (cmpu pb u u')) (hs : forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort Conv s s') (cmps Conv s s')) (hs' : forall s s', Sort.on_sort p true s -> Sort.on_sort p true s' -> reflect (cmp_sort pb s s') (cmps pb s s')) - (hglobal : forall gr napp ui ui', forallb p (map Universe.of_level ui) -> forallb p (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) - (hglobal' : forall gr napp ui ui', forallb p (map Universe.of_level ui) -> forallb p (map Universe.of_level ui') -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')). + (hglobal : forall gr napp ui ui', forallb p ui -> forallb p ui' -> reflect (cmp_global_instance Σ cmp_universe Conv gr napp ui ui') (gen_compare_global_instance Conv gr napp ui ui')) + (hglobal' : forall gr napp ui ui', forallb p ui -> forallb p ui' -> reflect (cmp_global_instance Σ cmp_universe pb gr napp ui ui') (gen_compare_global_instance pb gr napp ui ui')). Lemma reflect_eqb_decl_gen : forall d d', @@ -787,9 +787,9 @@ Proof. Defined. (** Checking equality *) - +(* Lemma wf_gc_of_uctx {cf:checker_flags} {Σ : global_env} (HΣ : ∥ wf Σ ∥) -: ∑ uctx', gc_of_uctx (global_uctx Σ) = Some uctx'. +: ∑ uctx', push_uctx (global_uctx Σ) = Some uctx'. Proof. assert (consistent (global_uctx Σ).2) as HC. { sq; apply (wf_consistent _ HΣ). } @@ -798,48 +798,66 @@ apply gc_consistent_iff in HC. destruct (gc_of_constraints (global_constraints Σ)). - eexists; reflexivity. - contradiction HC. -Defined. +Defined. *) -Lemma graph_of_wf {cf:checker_flags} {Σ : global_env} (HΣ : ∥ wf Σ ∥) -: ∑ G, is_graph_of_uctx G (global_uctx Σ). +Import UnivLoopChecking.UnivLoopChecking. + +Lemma init_constraints_of_clean_uctx uctx : init_constraints_of_levels (uctx.1) =_ucset init_constraints_of_levels (clean_uctx uctx).1. Proof. -destruct (wf_gc_of_uctx HΣ) as [uctx Huctx]. -exists (make_graph uctx). unfold is_graph_of_uctx. now rewrite Huctx. -Defined. + destruct uctx; cbn -[init_constraints_of_levels]. + intros cl. + split. + - move/init_constraints_of_levels_spec_inv => [l [hin heq]]. + eapply init_constraints_of_levels_spec; tea. + apply LevelSet.remove_spec. split => //. + destruct l; noconf heq; intros eq; congruence. + - move/init_constraints_of_levels_spec_inv => [l [hin heq]]. + eapply init_constraints_of_levels_spec; tea. + now apply LevelSet.remove_spec in hin as []. +Qed. -Lemma wf_ext_gc_of_uctx {cf:checker_flags} {Σ : global_env_ext} (HΣ : ∥ wf_ext Σ ∥) -: ∑ uctx', gc_of_uctx (global_ext_uctx Σ) = Some uctx'. +Lemma model_of_clean_uctx m uctx : model_of_uctx m (clean_uctx uctx) <-> model_of_uctx m uctx. Proof. -assert (consistent (global_ext_uctx Σ).2) as HC. - { sq; apply (global_ext_uctx_consistent _ HΣ). } -destruct Σ as [Σ φ]. -simpl in HC. -unfold gc_of_uctx; simpl in *. -apply gc_consistent_iff in HC. -destruct (gc_of_constraints (global_ext_constraints (Σ, φ))). -- eexists; reflexivity. -- contradiction HC. -Defined. + unfold model_of_uctx. cbn -[init_constraints_of_levels]. + rewrite [LevelSet.union (LevelSet.remove _ _) _]LevelSetProp.union_sym. + rewrite -LevelSetProp.add_union_singleton levelset_add_remove LevelSetProp.add_union_singleton + LevelSetProp.union_sym. + rewrite -init_constraints_of_clean_uctx. reflexivity. +Qed. -Lemma wf_ext_gc_of_uctx_irr {cf:checker_flags} {Σ : global_env_ext} (HΣ HΣ' : ∥ wf_ext Σ ∥) : - wf_ext_gc_of_uctx HΣ = wf_ext_gc_of_uctx HΣ'. +Lemma graph_of_wf {cf:checker_flags} {Σ : global_env} (HΣ : ∥ wf Σ ∥) +: ∑ G, model_of_uctx G (global_uctx Σ). Proof. - unfold wf_ext_gc_of_uctx. Opaque gc_of_constraints. - destruct Σ; cbn. - match goal with | |- _ ?X = _ ?Y => set (prf := X) ; set (prf' := Y) end. - clearbody prf prf'. cbn in *. revert prf prf'. - set (gc_of_constraints ((g, u):global_env_ext)) in *. - now destruct o. + destruct (push_uctx init_model (clean_uctx (global_uctx Σ))) eqn:hp. + - exists u. apply push_uctx_init_model_sat in hp. + now apply model_of_clean_uctx. + - apply push_uctx_init_model_unsat in hp; tea. + * exfalso. destruct HΣ. apply hp. + assert (consistent (global_uctx Σ).2) as HC. + { sq; apply (wf_consistent _ X). } + destruct HC as [v sat]. + exists v. apply satisfies_union. split => //. + apply satisfies_init. + * destruct HΣ. eapply wf_global_uctx_invariants. exact X. Qed. Lemma graph_of_wf_ext {cf:checker_flags} {Σ : global_env_ext} (HΣ : ∥ wf_ext Σ ∥) -: ∑ G, is_graph_of_uctx G (global_ext_uctx Σ). +: ∑ G, model_of_uctx G (global_ext_uctx Σ). Proof. -destruct (wf_ext_gc_of_uctx HΣ) as [uctx Huctx]. -exists (make_graph uctx). unfold is_graph_of_uctx. now rewrite Huctx. -Defined. + destruct (push_uctx init_model (clean_uctx (global_ext_uctx Σ))) eqn:hp. + - exists u. apply push_uctx_init_model_sat in hp. + now apply model_of_clean_uctx. + - apply push_uctx_init_model_unsat in hp; tea. + * exfalso. destruct HΣ. apply hp. + assert (consistent (global_ext_uctx Σ).2) as HC. + { sq. now apply (wf_ext_consistent _ X). } + destruct HC as [v sat]. + exists v. apply satisfies_union. split => //. + apply satisfies_init. + * destruct HΣ. eapply wf_ext_global_uctx_invariants. exact X. +Qed. -Lemma uctx'_eq {cf:checker_flags} {Σ} (wfΣ : ∥ wf_ext Σ ∥) : +(* Lemma uctx'_eq {cf:checker_flags} {Σ} (wfΣ : ∥ wf_ext Σ ∥) : let G := graph_of_wf_ext wfΣ in (wf_ext_gc_of_uctx wfΣ).π1 = uctx' G.π1 (global_ext_uctx Σ) G.π2. Proof. @@ -852,6 +870,65 @@ Proof. Transparent gc_of_constraints. set (gc_of_constraints ((g, u):global_env_ext)) in *. now destruct o. +Qed. *) + +Lemma valid_cstr_eq {cf : config.checker_flags} cstrs u v : valid_cstr cstrs (u, UnivConstraintType.ConstraintType.Eq, v) <-> eq_universe cstrs u v. +Proof. + unfold valid_cstr, eq_universe. + cbn; split. + - destruct check_univs => //=. + move=> val hval /val he; now depelim he. + - destruct check_univs => //=. + move=> val hval /val he; now constructor. +Qed. + +Lemma valid_cstr_le {cf : config.checker_flags} cstrs u v : valid_cstr cstrs (u, UnivConstraintType.ConstraintType.Le, v) <-> leq_universe cstrs u v. +Proof. + unfold valid_cstr, leq_universe. + cbn; split. + - destruct check_univs => //=. + move=> val hval /val he; now depelim he. + - destruct check_univs => //=. + move=> val hval /val he; now constructor. +Qed. + +Lemma wf_universe_declared {cf : checker_flags} Σ u : + wf_universe Σ u -> + levels_declared (clean_uctx (global_ext_uctx Σ)) u. +Proof. + move=> wf l /wf. + rewrite /expr_declared //= levelset_add_remove. + destruct l; cbn. lsets. +Qed. + +Lemma wf_universe_subset {cf : checker_flags} Σ u : + wf_universe Σ u -> + LevelSet.Subset (Universe.levels u) (LevelSet.add Level.lzero (clean_uctx (global_ext_uctx Σ)).1). +Proof. + move=> wf. now apply levels_declared_uctx, wf_universe_declared. +Qed. + +Lemma wf_sort_declared {cf : checker_flags} Σ u : + wf_sort Σ u -> + levels_declared_sort (clean_uctx (global_ext_uctx Σ)) u. +Proof. + destruct u; cbn => //. + move/wf_universe_declared. + move=> le hin le'. red. + now apply le in le'. +Qed. + +Lemma check_spec_clean uctx check : check_spec (clean_uctx uctx) check <-> check_spec uctx check. +Proof. + split. + - unfold check_spec. + intros. apply H. + rewrite /clean_uctx //=. red. destruct c as [[l d] r]. rewrite levelset_add_remove. + apply H0. + - unfold check_spec. + intros. apply H. + rewrite /clean_uctx //=. red. destruct c as [[l d] r]. cbn in H0. rewrite levelset_add_remove in H0. + apply H0. Qed. Section EqualityDecGen. @@ -865,146 +942,144 @@ Section EqualityDecGen. Let HG := (graph_of_wf_ext hΣ).π2. - Let uctx' : VSet.t × GoodUnivConstraintSet.t. - fold G uctx in HG. clearbody G HG. cbn in *. - unfold is_graph_of_uctx, gc_of_uctx in HG. - destruct (gc_of_constraints uctx.2) as [ctrs|]. - - exact (uctx.1, ctrs). - - contradiction HG. - Defined. - - Lemma eq_universeP_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) + Lemma eq_universeP_gen checkb + (check_correct : check_spec uctx checkb) u u' : wf_universe Σ u -> wf_universe Σ u' -> - reflect (eq_universe Σ u u') (check_eqb_universe_gen leqb_level_n_gen u u'). + reflect (eq_universe Σ u u') (check_eqb_universe_gen checkb u u'). Proof using hΣ. intros. destruct Σ as [Σ' φ]. - apply (equivP idP); split; sq. - all: pose proof hΣ as hΣ' ; sq. - - intros e. - eapply check_eqb_universe_spec_gen' - with (uctx := global_ext_uctx (Σ', φ)) in e ; eauto. - + now eapply wf_ext_global_uctx_invariants. - + now eapply global_ext_uctx_consistent. - - intros e. - eapply check_eqb_universe_complete_gen - with (uctx := global_ext_uctx (Σ', φ)); eauto. - + now eapply wf_ext_global_uctx_invariants. - + now eapply global_ext_uctx_consistent. + apply (equivP idP). + rewrite -valid_cstr_eq. + pose proof hΣ as hΣ' ; sq. + eapply check_eqb_universe_spec_gen + with (uctx := clean_uctx (global_ext_uctx (Σ', φ))) ; eauto. + + now eapply wf_ext_global_uctx_invariants. + + eapply model_of_clean_uctx. apply HG. + + now apply check_spec_clean. + + split; eapply wf_universe_subset; tea. Qed. - Lemma leq_universeP_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) u u' : + Lemma leq_universeP_gen checkb + (check_correct : check_spec uctx checkb) + u u' : wf_universe Σ u -> wf_universe Σ u' -> - reflect (leq_universe Σ u u') (check_leqb_universe_gen leqb_level_n_gen u u'). + reflect (leq_universe Σ u u') (check_leqb_universe_gen checkb u u'). Proof using hΣ. - intros. - apply (equivP idP) ; split. - all: pose proof hΣ as hΣ' ; sq. - - intros e. - eapply check_leqb_universe_spec_gen' - with (uctx := global_ext_uctx Σ) in e ; eauto. - + now eapply wf_ext_global_uctx_invariants. - + now eapply global_ext_uctx_consistent. - - intros e. - eapply check_leqb_universe_complete_gen - with (uctx := global_ext_uctx Σ); eauto. - + now eapply wf_ext_global_uctx_invariants. - + now eapply global_ext_uctx_consistent. + intros. destruct Σ as [Σ' φ]. + apply (equivP idP). + rewrite -valid_cstr_le. + pose proof hΣ as hΣ' ; sq. + eapply check_leqb_universe_spec_gen + with (uctx := clean_uctx (global_ext_uctx (Σ', φ))) ; eauto. + + now eapply wf_ext_global_uctx_invariants. + + eapply model_of_clean_uctx. apply HG. + + now apply check_spec_clean. + + split; eapply wf_universe_subset; tea. Qed. - Definition check_cmpb_universe_gen leqb_level_n_gen := - (conv_pb_relb_gen (check_eqb_universe_gen leqb_level_n_gen) (check_leqb_universe_gen leqb_level_n_gen)). + Definition check_cmpb_universe_gen checkb := + (conv_pb_relb_gen (check_eqb_universe_gen checkb) (check_leqb_universe_gen checkb)). - Lemma compare_universeP_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) pb u u' : + Lemma compare_universeP_gen checkb + (check_correct : check_spec uctx checkb) pb u u' : wf_universe Σ u -> wf_universe Σ u' -> - reflect (compare_universe Σ pb u u') (check_cmpb_universe_gen leqb_level_n_gen pb u u'). + reflect (compare_universe Σ pb u u') (check_cmpb_universe_gen checkb pb u u'). Proof. destruct pb. - now apply eq_universeP_gen. - now apply leq_universeP_gen. Qed. - Lemma eq_sortP_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) + Lemma eq_sortP_gen checkb + (check_correct : check_spec uctx checkb) s s' : wf_sort Σ s -> wf_sort Σ s' -> - reflect (eq_sort Σ s s') (check_eqb_sort_gen leqb_level_n_gen s s'). + reflect (eq_sort Σ s s') (check_eqb_sort_gen checkb s s'). Proof using hΣ. + apply check_spec_clean in check_correct. intros. destruct Σ as [Σ' φ]. apply (equivP idP); split; sq. all: pose proof hΣ as hΣ' ; sq. - intros e. - eapply check_eqb_sort_spec_gen' - with (uctx := global_ext_uctx (Σ', φ)) in e ; eauto. + eapply check_eqb_sort_spec_gen + with (uctx := clean_uctx (global_ext_uctx (Σ', φ))) in e ; eauto. + now eapply wf_ext_global_uctx_invariants. - + now eapply global_ext_uctx_consistent. + + eapply model_of_clean_uctx. apply HG. + + now apply wf_sort_declared in H. + + now apply wf_sort_declared in H0. - intros e. - eapply check_eqb_sort_complete_gen - with (uctx := global_ext_uctx (Σ', φ)); eauto. + eapply check_eqb_sort_spec_gen + with (uctx := clean_uctx (global_ext_uctx (Σ', φ))); eauto. + now eapply wf_ext_global_uctx_invariants. - + now eapply global_ext_uctx_consistent. + + eapply model_of_clean_uctx. apply HG. + + now apply wf_sort_declared in H. + + now apply wf_sort_declared in H0. Qed. - Lemma leq_sortP_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) s s' : + Lemma leq_sortP_gen checkb + (check_correct : check_spec uctx checkb) + s s' : wf_sort Σ s -> wf_sort Σ s' -> - reflect (leq_sort Σ s s') (check_leqb_sort_gen leqb_level_n_gen s s'). + reflect (leq_sort Σ s s') (check_leqb_sort_gen checkb s s'). Proof using hΣ. - intros. - apply (equivP idP) ; split. + apply check_spec_clean in check_correct. + intros. destruct Σ as [Σ' φ]. + apply (equivP idP); split; sq. all: pose proof hΣ as hΣ' ; sq. - intros e. - eapply check_leqb_sort_spec_gen' - with (uctx := global_ext_uctx Σ) in e ; eauto. + eapply check_leqb_sort_spec_gen + with (uctx := clean_uctx (global_ext_uctx (Σ', φ))) in e ; eauto. + now eapply wf_ext_global_uctx_invariants. - + now eapply global_ext_uctx_consistent. + + eapply model_of_clean_uctx. apply HG. + + now apply wf_sort_declared in H. + + now apply wf_sort_declared in H0. - intros e. - eapply check_leqb_sort_complete_gen - with (uctx := global_ext_uctx Σ); eauto. + eapply check_leqb_sort_spec_gen + with (uctx := clean_uctx (global_ext_uctx (Σ', φ))); eauto. + now eapply wf_ext_global_uctx_invariants. - + now eapply global_ext_uctx_consistent. + + eapply model_of_clean_uctx. apply HG. + + now apply wf_sort_declared in H. + + now apply wf_sort_declared in H0. Qed. - Definition check_cmpb_sort_gen leqb_level_n_gen := - (conv_pb_relb_gen (check_eqb_sort_gen leqb_level_n_gen) (check_leqb_sort_gen leqb_level_n_gen)). + Definition check_cmpb_sort_gen checkb := + (conv_pb_relb_gen (check_eqb_sort_gen checkb) (check_leqb_sort_gen checkb)). - Lemma compare_sortP_gen leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) pb s s' : + Lemma compare_sortP_gen checkb + (check_correct : check_spec uctx checkb) pb s s' : wf_sort Σ s -> wf_sort Σ s' -> - reflect (compare_sort Σ pb s s') (check_cmpb_sort_gen leqb_level_n_gen pb s s'). + reflect (compare_sort Σ pb s s') (check_cmpb_sort_gen checkb pb s s'). Proof. destruct pb. - now apply eq_sortP_gen. - now apply leq_sortP_gen. Qed. - Definition eqb_ctx leqb_level_n_gen := - eqb_ctx_upto (check_cmpb_universe_gen leqb_level_n_gen) (check_cmpb_sort_gen leqb_level_n_gen) - (compare_global_instance (lookup_env Σ) (check_cmpb_universe_gen leqb_level_n_gen)). + Definition eqb_ctx checkb := + eqb_ctx_upto (check_cmpb_universe_gen checkb) (check_cmpb_sort_gen checkb) + (compare_global_instance (lookup_env Σ) (check_cmpb_universe_gen checkb)). - Definition eqb_termp_napp leqb_level_n_gen := - eqb_term_upto_univ_napp (check_cmpb_universe_gen leqb_level_n_gen) (check_cmpb_sort_gen leqb_level_n_gen) - (compare_global_instance (lookup_env Σ) (check_cmpb_universe_gen leqb_level_n_gen)). + Definition eqb_termp_napp checkb := + eqb_term_upto_univ_napp (check_cmpb_universe_gen checkb) (check_cmpb_sort_gen checkb) + (compare_global_instance (lookup_env Σ) (check_cmpb_universe_gen checkb)). - Lemma reflect_eqb_termp_napp pb leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) napp t u : + Lemma reflect_eqb_termp_napp pb checkb + (check_correct : check_spec uctx checkb) napp t u : wf_universes Σ t -> wf_universes Σ u -> - reflectT (eq_termp_napp Σ pb napp t u) (eqb_termp_napp leqb_level_n_gen pb napp t u). + reflectT (eq_termp_napp Σ pb napp t u) (eqb_termp_napp checkb pb napp t u). Proof using hΣ. apply reflect_eq_term_upto_univ. - - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + - move => ? ? /wf_universeP ? - /wf_universeP ?. now apply compare_universeP_gen. - - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + - move => ? ? /wf_universeP ? - /wf_universeP ?. now apply compare_universeP_gen. - move => ? ? /wf_sort_reflect ? - /wf_sort_reflect ?. now apply compare_sortP_gen. @@ -1012,23 +1087,23 @@ Section EqualityDecGen. now apply compare_sortP_gen. - intros. eapply reflect_cmp_global_instance; eauto. - + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + + move => ? ? /wf_universeP ? - /wf_universeP ?. now apply compare_universeP_gen. - + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + + move => ? ? /wf_universeP ? - /wf_universeP ?. now apply compare_universeP_gen. - intros. eapply reflect_cmp_global_instance; eauto. - + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + + move => ? ? /wf_universeP ? - /wf_universeP ?. now apply compare_universeP_gen. - + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + + move => ? ? /wf_universeP ? - /wf_universeP ?. now apply compare_universeP_gen. Qed. - Lemma eqb_termp_napp_spec pb leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) napp t u : + Lemma eqb_termp_napp_spec pb checkb + (check_correct : check_spec uctx checkb) napp t u : wf_universes Σ t -> wf_universes Σ u -> - eqb_termp_napp leqb_level_n_gen pb napp t u -> + eqb_termp_napp checkb pb napp t u -> eq_termp_napp Σ pb napp t u. Proof using hΣ. intros. @@ -1040,32 +1115,32 @@ Section EqualityDecGen. Definition eqb_term := (eqb_termp Conv). Definition leqb_term := (eqb_termp Cumul). - Lemma eqb_term_spec leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) t u : + Lemma eqb_term_spec checkb + (check_correct : check_spec uctx checkb) t u : wf_universes Σ t -> wf_universes Σ u -> - eqb_term leqb_level_n_gen t u -> + eqb_term checkb t u -> eq_term Σ Σ t u. Proof using hΣ. intros. eapply (eqb_termp_napp_spec Conv) ; tea. Qed. - Lemma leqb_term_spec leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) + Lemma leqb_term_spec checkb + (check_correct : check_spec uctx checkb) t u : wf_universes Σ t -> wf_universes Σ u -> - leqb_term leqb_level_n_gen t u -> + leqb_term checkb t u -> leq_term Σ Σ t u. Proof using hΣ. intros. eapply (eqb_termp_napp_spec Cumul) ; tea. Qed. - Lemma reflect_leq_term leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) t u : + Lemma reflect_leq_term checkb + (check_correct : check_spec uctx checkb) t u : wf_universes Σ t -> wf_universes Σ u -> - reflectT (leq_term Σ Σ t u) (leqb_term leqb_level_n_gen t u). + reflectT (leq_term Σ Σ t u) (leqb_term checkb t u). Proof using hΣ. intros. now eapply (reflect_eqb_termp_napp Cumul). @@ -1073,19 +1148,19 @@ Section EqualityDecGen. Notation eq_term Σ t u := (eq_term Σ Σ t u). - Lemma reflect_eq_term leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) t u : + Lemma reflect_eq_term checkb + (check_correct : check_spec uctx checkb) t u : wf_universes Σ t -> wf_universes Σ u -> - reflectT (eq_term Σ t u) (eqb_term leqb_level_n_gen t u). + reflectT (eq_term Σ t u) (eqb_term checkb t u). Proof using hΣ. intros. now eapply (reflect_eqb_termp_napp Conv). Qed. - Lemma eqb_term_refl leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) : - forall t, wf_universes Σ t -> eqb_term leqb_level_n_gen t t. + Lemma eqb_term_refl checkb + (check_correct : check_spec uctx checkb) : + forall t, wf_universes Σ t -> eqb_term checkb t t. Proof using hΣ. intro t. eapply eqb_term_upto_univ_refl. 4,5: intros; eapply reflect_cmp_global_instance; tea; intros; cbnr; try apply idP. @@ -1094,18 +1169,18 @@ Section EqualityDecGen. - intros. eapply check_eqb_sort_refl_gen; eauto. Qed. - Lemma eqb_ctx_spec leqb_level_n_gen - (leqb_correct : leqb_level_n_spec_gen uctx' leqb_level_n_gen) : + Lemma eqb_ctx_spec checkb + (check_correct : check_spec uctx checkb) : forall pb Γ Δ, wf_ctx_universes Σ Γ -> wf_ctx_universes Σ Δ -> - eqb_ctx leqb_level_n_gen pb Γ Δ -> + eqb_ctx checkb pb Γ Δ -> eq_context_upto Σ (compare_universe Σ) (compare_sort Σ) pb Γ Δ. Proof using hΣ. intros pb Γ Δ hΓ hΔ h. eapply elimT. 1: eapply reflect_eqb_ctx_gen; eauto. 7: tea. - - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + - move => ? ? /wf_universeP ? - /wf_universeP ?. now apply compare_universeP_gen. - - move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + - move => ? ? /wf_universeP ? - /wf_universeP ?. now apply compare_universeP_gen. - move => ? ? /wf_sort_reflect ? - /wf_sort_reflect ?. now apply compare_sortP_gen. @@ -1113,15 +1188,15 @@ Section EqualityDecGen. now apply compare_sortP_gen. - intros. eapply reflect_cmp_global_instance; eauto. - + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + + move => ? ? /wf_universeP ? - /wf_universeP ?. now apply compare_universeP_gen. - + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + + move => ? ? /wf_universeP ? - /wf_universeP ?. now apply compare_universeP_gen. - intros. eapply reflect_cmp_global_instance; eauto. - + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + + move => ? ? /wf_universeP ? - /wf_universeP ?. now apply compare_universeP_gen. - + move => ? ? /wf_universe_reflect ? - /wf_universe_reflect ?. + + move => ? ? /wf_universeP ? - /wf_universeP ?. now apply compare_universeP_gen. Qed. diff --git a/safechecker/theories/PCUICErrors.v b/safechecker/theories/PCUICErrors.v index 3835ab166..0e0bc1583 100644 --- a/safechecker/theories/PCUICErrors.v +++ b/safechecker/theories/PCUICErrors.v @@ -165,15 +165,10 @@ Definition print_level := string_of_level. Definition string_of_Z z := if (z <=? 0)%Z then "-" ^ string_of_nat (Z.to_nat (- z)) else string_of_nat (Z.to_nat z). -Definition print_edge '(l1, n, l2) - := "(" ^ print_level l1 ^ ", " ^ string_of_Z n ^ ", " - ^ print_level l2 ^ ")". - -Definition print_universes_graph (G : universes_graph) := - let levels := LevelSet.elements G.1.1 in - let edges := wGraph.EdgeSet.elements G.1.2 in +Definition print_universes_graph (G : universe_model) := + let levels := LevelSet.elements (UnivLoopChecking.UnivLoopChecking.levels G) in string_of_list print_level levels - ^ nl ^ string_of_list print_edge edges. + ^ nl ^ print_univ_constraint_set G.(UnivLoopChecking.UnivLoopChecking.constraints). Definition string_of_conv_pb (c : conv_pb) : string := match c with diff --git a/safechecker/theories/PCUICSafeConversion.v b/safechecker/theories/PCUICSafeConversion.v index b09a9ba52..1fdab07fd 100644 --- a/safechecker/theories/PCUICSafeConversion.v +++ b/safechecker/theories/PCUICSafeConversion.v @@ -546,7 +546,7 @@ Section Conversion. Definition wf_universe_iff Σ u : wf_universeb Σ u <-> wf_universe Σ u. Proof using Type. - symmetry; apply reflect_iff. eapply wf_universe_reflect. + symmetry; apply reflect_iff. eapply wf_universeP. Qed. Definition wf_sort_iff Σ s : @@ -1351,8 +1351,8 @@ Section Conversion. Lemma eqb_universe_instance_spec : forall u v Σ (wfΣ : abstract_env_ext_rel X Σ), - forallb (wf_universeb Σ) (map Universe.of_level u) -> - forallb (wf_universeb Σ) (map Universe.of_level v) -> + forallb (wf_universeb Σ) u -> + forallb (wf_universeb Σ) v -> eqb_universe_instance u v -> cmp_universe_instance (eq_universe (global_ext_constraints Σ)) u v. Proof using Type. @@ -1383,15 +1383,13 @@ Qed. Proof using Type. now destruct l. Qed. Lemma compare_universeb_make_complete Σ (wfΣ : abstract_env_ext_rel X Σ) pb x y : - wf_level Σ x -> - wf_level Σ y -> - compare_universe (global_ext_constraints Σ) pb (Universe.of_level x) (Universe.of_level y) -> - abstract_env_compare_universe X pb (Universe.of_level x) (Universe.of_level y). + wf_universe Σ x -> + wf_universe Σ y -> + compare_universe (global_ext_constraints Σ) pb x y -> + abstract_env_compare_universe X pb x y. Proof using Type. intros wfx wfy r. eapply compare_universeb_complete; eauto. - - intros ? ->%LevelExprSet.singleton_spec; auto. - - intros ? ->%LevelExprSet.singleton_spec; auto. Qed. Lemma eqb_universe_instance_complete Σ (wfΣ : abstract_env_ext_rel X Σ) u u' : @@ -1406,12 +1404,12 @@ Qed. eapply reflect_reflectT, reflect_cmp_universe_instance with (p := wf_universeb Σ); tea. 1: intros ????; eapply iff_reflect, abstract_env_compare_universe_correct with (conv_pb := Conv); tea. 1,2: now eapply wf_universe_iff. - all: solve_all; eapply wf_universe_iff; intros ? ->%LevelExprSet.singleton_spec; auto. + all: solve_all; eapply wf_universe_iff => //. Qed. Lemma compare_universe_variance_complete Σ (wfΣ : abstract_env_ext_rel X Σ) pb v u u' : - wf_level Σ u -> - wf_level Σ u' -> + wf_universe Σ u -> + wf_universe Σ u' -> cmp_universe_variance (compare_universe Σ) pb v u u' -> compare_universe_variance (abstract_env_compare_universe X) pb v u u'. Proof using Type. @@ -1451,7 +1449,7 @@ Qed. apply forallb_Forall in mems. eapply Forall_impl; eauto. cbn. - intros ? ?%LevelSet.mem_spec; auto. + now move=> x /LevelSet.subset_spec /PCUICUnivSubstitutionConv.subset_levels. Qed. Lemma welltyped_zipc_tConst_inv Σ (wfΣ : abstract_env_ext_rel X Σ) Γ c u π : @@ -3040,8 +3038,8 @@ Qed. (hp : ∥ ws_cumul_pb_terms Σ (Γ,,, stack_context π) (pparams p) (pparams p') ∥) : ∥ ∑ mdecl idecl, [× declared_inductive Σ ci mdecl idecl, - forallb (wf_universeb Σ) (map Universe.of_level (puinst p)), - forallb (wf_universeb Σ) (map Universe.of_level (puinst p')), + forallb (wf_universeb Σ) (puinst p), + forallb (wf_universeb Σ) (puinst p'), #|pparams p| = ind_npars mdecl, #|pparams p'| = ind_npars mdecl, eq_context_upto_names p.(pcontext) p'.(pcontext), @@ -3590,7 +3588,7 @@ Equations (noeqns) isconv_array_values_aux { | @exist true eqf := yes | @exist false neqf := no (DistinctPrimValues (Γ ,,, stack_context π1) p (Γ ,,, stack_context π2) p') } | (primArray; primArrayModel a) | (primArray; primArrayModel a') - with inspect (abstract_env_compare_universe X Conv (Universe.of_level (array_universe a)) (Universe.of_level (array_universe a'))) := + with inspect (abstract_env_compare_universe X Conv (array_universe a) (array_universe a')) := { | @exist false neql := no (ArrayNotConvertibleLevels (Γ ,,, stack_context π1) a (Γ ,,, stack_context π2) a') | @exist true eql with isconv_red_raw Conv (array_type a) (PrimArray_ty a.(array_universe) a.(array_value) a.(array_default) :: π1) (array_type a') (PrimArray_ty a'.(array_universe) a'.(array_value) a'.(array_default) :: π2) aux := { @@ -4862,11 +4860,11 @@ Qed. 2:{ destruct h1 as [? ty]; eapply typing_wf_universes in ty; eauto. move/andP: ty => []. rewrite H0 /=. cbn -[wf_universeb]. rtoProp; intuition auto. - now move/wf_universe_reflect: H3. } + now move/wf_universeP: H3. } 2:{ destruct h2 as [? ty]; eapply typing_wf_universes in ty; eauto. move/andP: ty => []. rewrite H1 /=. cbn -[wf_universeb]. rtoProp; intuition auto. - now move/wf_universe_reflect: H3. } + now move/wf_universeP: H3. } constructor. eapply ws_cumul_pb_Prim; eauto; fvs. constructor; eauto. Qed. @@ -4948,11 +4946,11 @@ Qed. - rewrite H0 in h1. destruct h1 as [? wt]. eapply typing_wf_universes in wt; eauto. move/andP: wt => []. cbn -[wf_universeb wf_universe]. rtoProp; intuition auto. - now move/wf_universe_reflect: H2. + now move/wf_universeP: H2. - rewrite H1 in h2. destruct h2 as [? wt]. eapply typing_wf_universes in wt; eauto. move/andP: wt => []. cbn -[wf_universeb wf_universe]. rtoProp; intuition auto. - now move/wf_universe_reflect: H2. + now move/wf_universeP: H2. Qed. Next Obligation. diff --git a/safechecker/theories/PCUICTypeChecker.v b/safechecker/theories/PCUICTypeChecker.v index 0a733177e..3cdd8e5a4 100644 --- a/safechecker/theories/PCUICTypeChecker.v +++ b/safechecker/theories/PCUICTypeChecker.v @@ -24,7 +24,7 @@ From MetaRocq.SafeChecker Require Import PCUICEqualityDec PCUICSafeReduce PCUICE PCUICSafeConversion PCUICWfReduction PCUICWfEnv. From Equations Require Import Equations. -From Stdlib Require Import ssreflect ssrbool. +From Stdlib Require Import ssreflect ssrbool ssrfun. From Stdlib Require Import Program. Local Set Keyed Unification. @@ -47,81 +47,50 @@ Proof. Qed. +Lemma subst_univ_scope Σ t u inst cstrs : + Forall (fun l : Universe.t => LevelSet.subset (Universe.levels l) (global_ext_levels Σ)) u -> + LevelSet.Subset (Universe.levels t) (LevelSet.add Level.lzero (LevelSet.union (AUContext.levels (inst, cstrs)) (global_levels Σ))) -> + LevelSet.Subset (Universe.levels t@[u]) (LevelSet.add Level.lzero (global_ext_levels Σ)). +Proof. + move=> hf hs l /Universe.levels_spec; case=> k /In_subst_instance; case=> x [] hin' /subst_instance_level_expr_spec. + case=> [[hv eq]|[n [k' [heq hnth]]]]. + + subst x. cbn in hv. + move/subset_levels: hs => /(_ _ hin') //=. + rewrite LS.add_spec => -[->|] //; try lsets. + move/LS.union_spec => -[|]. + { destruct l => //. + + lsets. + + intros h; by apply monomorphic_level_notin_AUContext in h. } + rewrite /global_ext_levels; lsets. + + subst x. + destruct nth_error eqn:hnth'. + eapply Forall_All in hf. + eapply All_nth_error in hf; tea. + apply Universe.map_spec in hnth as [? []]. + destruct x; noconf H0. cbn. apply LevelSet.subset_spec in hf. + move/subset_levels: hf => /(_ _ H) //=. lsets. noconf hnth. lsets. +Qed. + Lemma subst_global_uctx_invariants {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf_ext Σ} {inst cstrs} {u : Instance.t} : - global_uctx_invariants (global_ext_uctx (Σ,Polymorphic_ctx (inst, cstrs))) -> - Forall (fun l => LevelSet.mem l (global_ext_levels Σ)) u -> - global_uctx_invariants ((global_ext_uctx Σ).1,subst_instance_cstrs u cstrs). + global_uctx_invariants (clean_uctx (global_ext_uctx (Σ,Polymorphic_ctx (inst, cstrs)))) -> + Forall (fun l => LevelSet.subset (Universe.levels l) (global_ext_levels Σ)) u -> + global_uctx_invariants (clean_uctx ((global_ext_uctx Σ).1,subst_instance_cstrs u cstrs)). Proof. - intros [_ Hcs] Hu. split. - - apply global_ext_levels_InSet. + intros [he Hcs] Hu. split. + - cbn in he |- *. intros hin; apply he. + now rewrite LevelSet.remove_spec in hin. - pose proof Σ as [Σ' φ]. pose proof wfΣ as [HΣ' Hφ]. rewrite /uctx_invariants /= in Hcs |- *. intros [[l ct] l'] Hctr. - rewrite /subst_instance_cstrs /= in Hctr. - rewrite ConstraintSetProp.fold_spec_right in Hctr. - set cstrs' := (List.rev (UCS.elements cstrs)) in Hctr. - set Σ'' := (Σ.1,Polymorphic_ctx (inst, cstrs)) in Hcs. - assert ((exists ct' l'', SetoidList.InA eq (l,ct',l'') cstrs') -> - declared l (global_ext_levels Σ'')) as Hcs'. - { - intros [ct' [l'' in']]. - specialize (Hcs (l,ct',l'')). - apply Hcs. - eapply UnivConstraintSet.union_spec. left. - now apply ConstraintSetFact.elements_2, SetoidList.InA_rev. - } - assert ((exists ct' l'', SetoidList.InA eq (l'',ct',l') cstrs') -> - declared l' (global_ext_levels Σ'')) as Hcs''. - { - intros [ct' [l'' in']]. - specialize (Hcs (l'',ct',l')). - apply Hcs. - eapply UnivConstraintSet.union_spec. left. - now apply ConstraintSetFact.elements_2, SetoidList.InA_rev. - } - clear Hcs. - induction cstrs' ; cbn in Hctr. - + now apply ConstraintSetFact.empty_iff in Hctr. - + apply UCS.add_spec in Hctr as []. - 2:{ - apply IHcstrs' ; tea. - all: intros [? []]. - 1: apply Hcs'. - 2: apply Hcs''. - all: do 2 eexists. - all: now constructor 2. - } - clear IHcstrs'. - rewrite /subst_instance_cstr in H. - inversion H ; subst ; clear H. - destruct a as [[l t] l'] ; cbn -[global_ext_levels] in *. - rewrite /subst_instance_level. - split. - * destruct l. - -- now eapply wf_ext_global_uctx_invariants. - -- cbn in Hcs'. - forward Hcs'. - do 2 eexists. - constructor. - reflexivity. - eapply In_Level_global_ext_poly in Hcs'. - red. eapply LevelSet.union_spec. now right. - -- apply LevelSetFact.mem_2. - pattern (nth n u Level.lzero). - apply Forall_nth_def ; tea. - now eapply LevelSetFact.mem_1, wf_ext_global_uctx_invariants. - * destruct l'. - -- now eapply wf_ext_global_uctx_invariants. - -- forward Hcs''. - do 2 eexists. - constructor. - reflexivity. - eapply In_Level_global_ext_poly in Hcs''. - eapply LevelSet.union_spec. now right. - -- apply LevelSetFact.mem_2. - pattern (nth n u Level.lzero). - apply Forall_nth_def ; tea. - now eapply LevelSetFact.mem_1, wf_ext_global_uctx_invariants. + apply In_subst_instance_cstrs in Hctr as [c' [heq hin]]. + destruct c' as [[? ?] ?]; noconf heq. cbn. + red in Hcs. move: (Hcs (t, t0, t1)) => /fwd. + unfold global_ext_constraints. cbn. ucsets. + intros [hl hr]. cbn in hl, hr. + rewrite /global_ext_levels //= in hl, hr. + rewrite levelset_add_remove in hl, hr |- *. + rewrite levelset_add_remove. + split; eapply subst_univ_scope; tea. Qed. (** It otherwise tries [auto with *], very bad idea. *) @@ -136,8 +105,8 @@ Ltac Corelib.Program.Tactics.program_solve_wf ::= Implicit Types (cf : checker_flags) (Σ : global_env_ext). Lemma declared_global_uctx_global_ext_uctx {l} {Σ : global_env} {univs} : - declared l (global_uctx Σ).1 -> - declared l (global_ext_uctx (Σ, univs)).1. + LevelSet.In l (global_uctx Σ).1 -> + LevelSet.In l (global_ext_uctx (Σ, univs)).1. Proof. intros hd. eapply LevelSet.union_spec. now right. @@ -145,20 +114,31 @@ Qed. Lemma global_uctx_invariants_ext {cf} {Σ : global_env} {wfΣ : wf Σ} {univs} : on_udecl_prop Σ univs -> - global_uctx_invariants (global_ext_uctx (Σ, univs)). + global_uctx_invariants (clean_uctx (global_ext_uctx (Σ, univs))). Proof. intros ond. pose proof (wf_global_uctx_invariants _ wfΣ) as [Hs Hc]. split. - - eapply LevelSet.union_spec. right. apply Hs. + - cbn. rewrite LevelSet.remove_spec. intros []; congruence. - intros x hx. cbn in hx. unfold global_ext_constraints in hx. eapply UnivConstraintSet.union_spec in hx. - destruct hx. cbn in H. - * now apply ond. - * specialize (Hc x H). - destruct x as ((l'&d')&r'). - now destruct Hc; split; eapply declared_global_uctx_global_ext_uctx. + destruct hx. + + cbn in H. + specialize (ond x H). + destruct x as [[l d] r]; cbn. + cbn in ond. rewrite levelset_add_remove. + rewrite /global_ext_levels //=. split; lsets. + + cbn in H. + specialize (Hc x). + destruct x as [[l d] r]; cbn. + cbn in ond. rewrite levelset_add_remove. + rewrite /global_ext_levels //=. forward Hc. + now cbn. destruct Hc. split. + * rewrite H0. rewrite /clean_uctx. + rewrite levelset_add_remove. lsets. + * rewrite H1. rewrite /clean_uctx. + rewrite levelset_add_remove. lsets. Qed. Lemma spine_subst_smash_inv {cf : checker_flags} {Σ : global_env_ext} {wfΣ : wf Σ} @@ -1027,19 +1007,35 @@ Section Typecheck. Qed. Definition abstract_env_level_mem_forallb {Σ} (wfΣ : abstract_env_ext_rel X Σ) u : - forallb (level_mem Σ) u = forallb (abstract_env_level_mem X) u. + forallb (LevelSet.for_all (level_mem Σ) $ Universe.levels) u = forallb (LevelSet.for_all (abstract_env_level_mem X) $ Universe.levels) u. Proof using Type. induction u; eauto; cbn. - set (b := LevelSet.Raw.mem _ _). set (b' := abstract_env_level_mem _ _). - assert (Hbb' : b = b'). - { unfold b'. apply eq_true_iff_eq. split; intro. - eapply (abstract_env_level_mem_correct X wfΣ a); apply (LevelSet.Raw.mem_spec _ a); eauto. - apply (LevelSet.Raw.mem_spec _ a); eapply (abstract_env_level_mem_correct X wfΣ a); eauto. - } - now destruct Hbb'. + rewrite IHu. f_equal. unfold compose. apply eqb_iff. + rewrite ![_ = true]LevelSet.for_all_spec. + change (fun x => abstract_env_level_mem X x = true) with (fun x => is_true (abstract_env_level_mem X x)). + split => ha l /ha h. + - rewrite -[is_true _](abstract_env_level_mem_correct X wfΣ). + unfold level_mem in h. now apply LevelSet.mem_spec in h. + - apply LevelSet.mem_spec. + now rewrite -[is_true _](abstract_env_level_mem_correct X wfΣ) in h. + Qed. + + Definition levels_subset Σ (ls : LevelSet.t) := LevelSet.subset ls (global_ext_levels Σ). + + Lemma forall_mem_subset Σ u : + forallb (LevelSet.for_all (level_mem Σ) ∘ Universe.levels) u = + forallb (fun u0 : Universe.t => LevelSet.subset (Universe.levels u0) (global_ext_levels Σ)) u. + Proof. + apply forallb_ext => x. + apply eqb_iff. rewrite LevelSet.subset_spec LS.for_all_spec. + rewrite subset_levels. + rewrite /LS.For_all. setoid_rewrite Universe.levels_spec; rewrite /level_mem. + setoid_rewrite LevelSet.mem_spec. split. + * clear. intros h lk hin. apply h. exists lk.2; now destruct lk. + * clear. intros h l [k h']. move/h: h' => //=. Qed. - Equations check_consistent_instance uctx (wfg : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ global_uctx_invariants (global_ext_uctx (Σ.1, uctx)) ∥) + Equations check_consistent_instance uctx (wfg : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ global_uctx_invariants (clean_uctx (global_ext_uctx (Σ.1, uctx))) ∥) u : typing_result_comp (forall Σ (wfΣ : abstract_env_ext_rel X Σ), consistent_instance_ext Σ uctx u) := check_consistent_instance (Monomorphic_ctx) wfg u @@ -1051,7 +1047,7 @@ Section Typecheck. with inspect (AUContext.repr (inst, cstrs)) := { | exist inst' _ with (Nat.eq_dec #|u| #|inst'.1|) := { | right e1 := raise (Msg "instance does not have the right length") ; - | left e1 with inspect (forallb (abstract_env_level_mem X) u) := { + | left e1 with inspect (forallb (LevelSet.for_all (abstract_env_level_mem X) $ Universe.levels) u) := { | exist false e2 := raise (Msg "undeclared level in instance") ; | exist true e2 with inspect (abstract_env_check_constraints X (subst_instance_cstrs u cstrs)) := { | exist false e3 := raise (Msg "ctrs not satisfiable") ; @@ -1062,13 +1058,15 @@ Section Typecheck. Qed. Next Obligation. pose proof (heΣ _ wfΣ) as [[_wfΣ s]]. specialize_Σ wfΣ. - assert (forallb (fun l : LevelSet.elt => LevelSet.mem l (global_ext_levels Σ)) u). - { symmetry in e2. rewrite abstract_env_level_mem_forallb; eauto. } + assert (forallb (fun u : Universe.t => LevelSet.subset (Universe.levels u) (global_ext_levels Σ)) u). + { symmetry in e2. erewrite <- abstract_env_level_mem_forallb in e2; eauto. + now rewrite -forall_mem_subset. } repeat split; eauto. - - sq. unshelve eapply (abstract_env_check_constraints_correct X); eauto. - now apply nor_check_univs. pose proof (abstract_env_ext_wf _ wfΣ) as [HΣ]. - eapply (subst_global_uctx_invariants (u := u)) in wfg; eauto. apply wfg. - solve_all. + sq. unshelve eapply (abstract_env_check_constraints_correct X); eauto. + now apply nor_check_univs. pose proof (abstract_env_ext_wf _ wfΣ) as [HΣ]. + eapply (subst_global_uctx_invariants (u := u)) in wfg; eauto. + apply wfg. + solve_all. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; @@ -1080,17 +1078,15 @@ Section Typecheck. now clear -H. now apply nor_check_univs. pose proof (abstract_env_ext_wf _ wfΣ) as [HΣ]. - eapply (subst_global_uctx_invariants (u := u)) in wfg; eauto. apply wfg. - assert (forallb (fun l : LevelSet.elt => LevelSet.mem l (global_ext_levels Σ)) u). - { rewrite abstract_env_level_mem_forallb; eauto. } - solve_all. + eapply (subst_global_uctx_invariants (u := u)) in wfg; eauto. + apply wfg. destruct H. solve_all. Qed. Next Obligation. destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; pose proof (heΣ _ wfΣ) as [heΣ]. sq. clear -e2 H heΣ wfΣ. - erewrite <- abstract_env_level_mem_forallb in e2; eauto. - now rewrite <- e2 in H. + erewrite <-abstract_env_level_mem_forallb in e2; eauto. + now rewrite forall_mem_subset in e2. Qed. Next Obligation. now destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ. @@ -1400,6 +1396,7 @@ Section Typecheck. all:try apply eqb_eq in i0. all:try apply eqb_eq in i1 => //. all:destruct H as []; apply absurd; rewrite ?H ?H0 ?H1; eauto. + all:apply eqb_refl. Qed. Section make_All. @@ -1427,8 +1424,8 @@ Section Typecheck. | (primFloat; primFloatModel f) := ret _ | (primString; primStringModel f) := ret _ | (primArray; primArrayModel a) := - check_eq_true (abstract_env_ext_wf_universeb X (Universe.of_level a.(array_universe))) (Msg "primitive array level is not well-formed") ;; - check_type <- bdcheck infer Γ wfΓ a.(array_type) (tSort (sType (Universe.of_level a.(array_universe)))) _ ;; + check_eq_true (abstract_env_ext_wf_universeb X a.(array_universe)) (Msg "primitive array level is not well-formed") ;; + check_type <- bdcheck infer Γ wfΓ a.(array_type) (tSort (sType a.(array_universe))) _ ;; check_default <- bdcheck infer Γ wfΓ a.(array_default) a.(array_type) _ ;; check_values <- make_All (fun x => bdcheck infer Γ wfΓ x a.(array_type) _) a.(array_value) ;; ret _. @@ -1440,23 +1437,24 @@ Section Typecheck. - eauto. - sq. erewrite <- abstract_env_ext_wf_universeb_correct in i; tea. eapply has_sort_isType; eapply type_Sort; eauto. - now move/@wf_universe_reflect: i. + now move/@wf_universeP: i. - specialize (check_type _ wfΣ) as []. sq; eapply checking_typing in X0; eauto. now eapply has_sort_isType. erewrite <- abstract_env_ext_wf_universeb_correct in i; tea. eapply has_sort_isType; eapply type_Sort; eauto. - now move/@wf_universe_reflect: i. + now move/@wf_universeP: i. - specialize (check_type _ wfΣ) as []. sq; eapply checking_typing in X0; eauto. now eapply has_sort_isType. erewrite <- abstract_env_ext_wf_universeb_correct in i; tea. eapply has_sort_isType; eapply type_Sort; eauto. - now move/@wf_universe_reflect: i. + now move/@wf_universeP: i. - specialize (check_type _ wfΣ) as []. specialize (check_default _ wfΣ) as []. - assert (∥ Σ;;; Γ |- array_type a : tSort (sType (Universe.of_level (array_universe a))) ∥) as []. + assert (∥ Σ;;; Γ |- array_type a : tSort (sType (array_universe a)) ∥) as []. { sq. eapply checking_typing in X0; eauto. erewrite <- abstract_env_ext_wf_universeb_correct in i; tea. - eapply has_sort_isType; eapply type_Sort; eauto. now move/@wf_universe_reflect: i. } + eexists; cbn. exact tt. eexists; split => //. + eapply type_Sort; eauto. now move/@wf_universeP: i. } assert (∥ All (fun x : term => Σ;;; Γ |- x ◃ array_type a) (array_value a) ∥). { induction check_values. - repeat constructor. @@ -1465,7 +1463,7 @@ Section Typecheck. constructor. constructor; eauto. } sq; constructor; eauto. erewrite <- abstract_env_ext_wf_universeb_correct in i; tea. - now move/@wf_universe_reflect: i. + now move/@wf_universeP: i. - destruct (abstract_env_ext_exists X) as [[Σ hΣ]]. specialize (H _ hΣ) as [tyh]. depelim tyh. eapply absurd. solve_all. @@ -1483,7 +1481,7 @@ Section Typecheck. specialize (H _ hΣ) as [tyh]. erewrite <- abstract_env_ext_wf_universeb_correct in absurd; tea. eapply absurd. depelim tyh. - now move/wf_universe_reflect: wfl. + now move/wf_universeP: wfl. Qed. End check_primitive. @@ -1846,9 +1844,9 @@ Section Typecheck. (* tConst *) Next Obligation. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. - eapply global_uctx_invariants_ext. symmetry in HH. erewrite <- abstract_env_lookup_correct' in HH; eauto. - now apply (weaken_lookup_on_global_env' _ _ _ (heΣ : wf _) HH). + have h := (weaken_lookup_on_global_env' _ _ _ (heΣ : wf _) HH). + now eapply global_uctx_invariants_ext in h. Qed. Next Obligation. pose proof (heΣ _ wfΣ) as [heΣ]. specialize_Σ wfΣ ; sq. diff --git a/safechecker/theories/PCUICWfEnv.v b/safechecker/theories/PCUICWfEnv.v index c9b54ad8a..e2f7a343f 100644 --- a/safechecker/theories/PCUICWfEnv.v +++ b/safechecker/theories/PCUICWfEnv.v @@ -36,9 +36,9 @@ Class abstract_env_struct {cf:checker_flags} (abstract_env_impl abstract_env_ext (* Primitive decision procedures *) abstract_env_level_mem : abstract_env_ext_impl -> Level.t -> bool; - abstract_env_leqb_level_n : abstract_env_ext_impl -> Z -> Level.t -> Level.t -> bool; + abstract_env_check : abstract_env_ext_impl -> UnivConstraint.t -> bool; abstract_env_guard : abstract_env_ext_impl -> FixCoFix -> context -> mfixpoint term -> bool; - abstract_env_is_consistent : abstract_env_impl -> LevelSet.t * GoodUnivConstraintSet.t -> bool ; + abstract_env_is_consistent : abstract_env_impl -> LevelSet.t * UnivConstraintSet.t -> bool ; }. @@ -50,15 +50,15 @@ Definition abstract_env_cofixguard {cf:checker_flags} {abstract_env_impl abstra Definition abstract_env_compare_universe {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} (X:abstract_env_ext_impl) : conv_pb -> Universe.t -> Universe.t -> bool := - check_cmpb_universe_gen (abstract_env_leqb_level_n X). + check_cmpb_universe_gen (abstract_env_check X). Definition abstract_env_compare_sort {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} (X:abstract_env_ext_impl) : conv_pb -> sort -> sort -> bool := - check_cmpb_sort_gen (abstract_env_leqb_level_n X). + check_cmpb_sort_gen (abstract_env_check X). Definition abstract_env_check_constraints {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} (X:abstract_env_ext_impl) : UnivConstraintSet.t -> bool := - check_constraints_gen (abstract_env_leqb_level_n X). + check_constraints_gen (abstract_env_check X). Definition abstract_env_ext_wf_universeb {cf:checker_flags} {abstract_env_impl abstract_env_ext_impl : Type} `{!abstract_env_struct abstract_env_impl abstract_env_ext_impl} (X:abstract_env_ext_impl) : Universe.t -> bool := @@ -103,16 +103,14 @@ Class abstract_env_prop {cf:checker_flags} (abstract_env_impl abstract_env_ext_i abstract_env_lookup_correct X {Σ} kn decl : abstract_env_ext_rel X Σ -> In (kn, decl) (declarations Σ) <-> abstract_env_lookup X kn = Some decl ; - abstract_env_leqb_level_n_correct X {Σ} (wfΣ : abstract_env_ext_rel X Σ): - let uctx := (wf_ext_gc_of_uctx (abstract_env_ext_wf X wfΣ)).π1 in - leqb_level_n_spec_gen uctx (abstract_env_leqb_level_n X); + abstract_env_check_correct X {Σ} (wfΣ : abstract_env_ext_rel X Σ): + check_spec (global_ext_uctx Σ) (abstract_env_check X); abstract_env_level_mem_correct X {Σ} (wfΣ : abstract_env_ext_rel X Σ) l: LevelSet.In l (global_ext_levels Σ) <-> abstract_env_level_mem X l; - abstract_env_is_consistent_correct X Σ uctx udecl : + abstract_env_is_consistent_correct X Σ udecl : abstract_env_rel X Σ -> UnivConstraintSet.For_all (declared_univ_cstr_levels (LevelSet.union udecl.1 (global_levels Σ))) udecl.2 -> - gc_of_uctx udecl = Some uctx -> - consistent_extension_on (global_uctx Σ) udecl.2 <-> abstract_env_is_consistent X uctx ; + consistent_extension_on (global_uctx Σ) udecl.2 <-> abstract_env_is_consistent X (global_uctx Σ); abstract_env_guard_correct X {Σ} (wfΣ : abstract_env_ext_rel X Σ) fix_cofix Γ mfix : guard fix_cofix Σ Γ mfix <-> abstract_env_guard X fix_cofix Γ mfix; @@ -176,7 +174,7 @@ Lemma on_udecl_mono {cf:checker_flags} {Σ : global_env} {wfΣ : wf Σ} : on_ude Proof. repeat split; cbn. - intros i; rewrite LevelSetFact.empty_iff //. - - intros i; rewrite ConstraintSetFact.empty_iff //. + - intros i; rewrite UnivConstraintSetFact.empty_iff //. - red. rewrite /univs_ext_constraints /=. rewrite CS_union_empty. apply wfΣ. @@ -211,7 +209,7 @@ Next Obligation. Defined. Definition abstract_env_is_consistent_empty {cf:checker_flags} {X_type : abstract_env_impl} - : VSet.t * GoodUnivConstraintSet.t -> bool := + : ContextSet.t -> bool := fun uctx => abstract_env_is_consistent (@abstract_env_empty cf X_type) uctx. Lemma abstract_env_compare_universe_correct {cf:checker_flags} {X_type : abstract_env_impl} @@ -221,14 +219,13 @@ Lemma abstract_env_compare_universe_correct {cf:checker_flags} {X_type : abstrac abstract_env_compare_universe X conv_pb u u'. Proof. intros wfu wfu'. pose proof (abstract_env_ext_wf X wfΣ). sq. - pose (Hleq := abstract_env_leqb_level_n_correct X wfΣ). - erewrite uctx'_eq in Hleq. + pose (Hleq := abstract_env_check_correct X wfΣ). eapply compare_universeP_gen with (pb := conv_pb) in Hleq. apply reflect_reflectT in Hleq. split. 1: now eapply introT. 1: now eapply elimT. - all: tea. + all: tea. now constructor. Qed. Lemma abstract_env_compare_sort_correct {cf:checker_flags} {X_type : abstract_env_impl} @@ -238,49 +235,42 @@ Lemma abstract_env_compare_sort_correct {cf:checker_flags} {X_type : abstract_en abstract_env_compare_sort X conv_pb s s'. Proof. intros wfu wfu'. pose proof (abstract_env_ext_wf X wfΣ). sq. - pose (Hleq := abstract_env_leqb_level_n_correct X wfΣ). - erewrite uctx'_eq in Hleq. + pose (Hleq := abstract_env_check_correct X wfΣ). eapply compare_sortP_gen with (pb := conv_pb) in Hleq. apply reflect_reflectT in Hleq. split. 1: now eapply introT. 1: now eapply elimT. - all: tea. + all: tea. now constructor. Qed. Lemma check_constraints_spec {cf:checker_flags} {X_type : abstract_env_impl} (X:X_type.π2.π1) {Σ} (wfΣ : abstract_env_ext_rel X Σ) ctrs : - uctx_invariants ((global_ext_uctx Σ).1, ctrs) -> + uctx_invariants ((clean_uctx (global_ext_uctx Σ)).1, ctrs) -> abstract_env_check_constraints X ctrs -> valid_constraints (global_ext_constraints Σ) ctrs. Proof. intros Huctx HH. pose proof (abstract_env_ext_wf X wfΣ). sq. - pose (Hleq := abstract_env_leqb_level_n_correct X wfΣ). - erewrite uctx'_eq in Hleq. - eapply (check_constraints_spec_gen _ (global_ext_uctx Σ)); eauto. - - now eapply wf_ext_global_uctx_invariants. - - now eapply global_ext_uctx_consistent. - - pose proof (wf_ext_global_uctx_invariants Σ H) as [H1 H2]. - split; eauto. + pose (Hleq := abstract_env_check_correct X wfΣ). + eapply (check_constraints_spec_gen (clean_uctx (global_ext_uctx Σ))); eauto. + - apply check_spec_clean, Hleq. + - split. rewrite /clean_uctx //=. lsets. exact Huctx. Defined. Lemma check_constraints_complete {cf:checker_flags} {X_type : abstract_env_impl} (X:X_type.π2.π1) {Σ} (wfΣ : abstract_env_ext_rel X Σ) ctrs (H : check_univs) : - uctx_invariants ((global_ext_uctx Σ).1, ctrs) -> + uctx_invariants ((clean_uctx (global_ext_uctx Σ)).1, ctrs) -> valid_constraints (global_ext_constraints Σ) ctrs -> abstract_env_check_constraints X ctrs. Proof. intros Huctx HH. pose proof (abstract_env_ext_wf X wfΣ). sq. - pose (Hleq := abstract_env_leqb_level_n_correct X wfΣ). - erewrite uctx'_eq in Hleq. - eapply (check_constraints_complete_gen _ (global_ext_uctx Σ)); eauto. - - now eapply wf_ext_global_uctx_invariants. - - now eapply global_ext_uctx_consistent. - - pose proof (wf_ext_global_uctx_invariants Σ H0) as [H1 H2]. - split; eauto. + pose (Hleq := abstract_env_check_correct X wfΣ). + eapply (check_constraints_spec_gen (clean_uctx (global_ext_uctx Σ))); eauto. + - apply check_spec_clean, Hleq. + - split. rewrite /clean_uctx //=. lsets. exact Huctx. Qed. Lemma abstract_env_check_constraints_correct {cf:checker_flags} {X_type : abstract_env_impl} (X:X_type.π2.π1) {Σ} (wfΣ : abstract_env_ext_rel X Σ) ctrs : - check_univs -> uctx_invariants ((global_ext_uctx Σ).1, ctrs) -> + check_univs -> uctx_invariants ((clean_uctx (global_ext_uctx Σ)).1, ctrs) -> valid_constraints Σ ctrs <-> abstract_env_check_constraints X ctrs. Proof. split; intros. @@ -312,12 +302,10 @@ Lemma abstract_env_level_mem_correct' {cf:checker_flags} {X_type : abstract_env_ ( X:X_type.π2.π1) {Σ} (wfΣ : abstract_env_ext_rel X Σ) levels u : LevelSet.mem u (LevelSet.union levels (global_ext_levels Σ)) = abstract_env_level_mem' X levels u. Proof. - unfold abstract_env_level_mem'. rewrite wGraph.VSetProp.Dec.F.union_b. - set (b0 := LevelSet.mem _ _). set (b := LevelSet.mem _ _). set (b' := abstract_env_level_mem _ _). - assert (Hbb' : b = b'). - { unfold b'. apply eq_true_iff_eq. rewrite <- (abstract_env_level_mem_correct X wfΣ u). - unfold LevelSet.In. now erewrite <- (LevelSet.Raw.mem_spec _ u). } - destruct Hbb' => //. + unfold abstract_env_level_mem'. rewrite LevelSetProp.Dec.F.union_b. f_equal. + have h := (abstract_env_level_mem_correct X wfΣ u). + apply eqb_iff. rewrite -[abstract_env_level_mem _ _ = true]h. + now rewrite LevelSet.mem_spec. Qed. Lemma wf_consistent_extension_on_consistent {cf:checker_flags} {Σ} udecl : @@ -329,13 +317,14 @@ Proof. destruct (Hext val Hval) as [val' [Hval' Hval'']]. exists val'. intros [[l ct] l'] [Hl|Hl]%UCS.union_spec; eauto. destruct (Hval _ Hl); cbn; econstructor. - - erewrite <- (Hval'' l0). erewrite <- (Hval'' l'0) => //. +Admitted. + (* - erewrite <- (Hval'' l0). erewrite <- (Hval'' l'0) => //. + destruct s as [[Hs _] _]. now destruct (Hs _ Hl). + destruct s as [[Hs _] _]. now destruct (Hs _ Hl). - erewrite <- (Hval'' l0). erewrite <- (Hval'' l'0) => //. + destruct s as [[Hs _] _]. now destruct (Hs _ Hl). - + destruct s as [[Hs _] _]. now destruct (Hs _ Hl). -Qed. + + destruct s as [[Hs _] _]. now destruct (Hs _ Hl). *) +(* Qed. *) Lemma abstract_env_lookup_correct' {cf:checker_flags} {X_type : abstract_env_impl} ( X:X_type.π2.π1) {Σ} kn : abstract_env_ext_rel X Σ -> diff --git a/safechecker/theories/PCUICWfEnvImpl.v b/safechecker/theories/PCUICWfEnvImpl.v index 333b1f727..9cc9e1bac 100644 --- a/safechecker/theories/PCUICWfEnvImpl.v +++ b/safechecker/theories/PCUICWfEnvImpl.v @@ -50,7 +50,7 @@ Program Global Instance canonical_abstract_env_struct {cf:checker_flags} {guard abstract_env_struct reference_impl reference_impl_ext := {| abstract_env_lookup := fun Σ => lookup_env (reference_impl_env_ext Σ) ; - abstract_env_leqb_level_n := fun Σ => leqb_level_n (reference_impl_ext_graph Σ) ; + abstract_env_check := fun Σ => checkb (reference_impl_ext_graph Σ) ; abstract_env_level_mem := fun Σ l => LevelSet.mem l (global_ext_levels (reference_impl_env_ext Σ)); abstract_env_guard := fun Σ fix_cofix => guard_impl fix_cofix (reference_impl_env_ext Σ); abstract_env_ext_rel := fun X Σ => Σ = reference_impl_env_ext X; @@ -62,8 +62,11 @@ Program Global Instance canonical_abstract_env_struct {cf:checker_flags} {guard {| reference_impl_env := add_global_decl X.(reference_impl_env) (kn,d); |}; abstract_env_is_consistent X uctx := let G := reference_impl_graph X in - let G' := add_uctx uctx G in - wGraph.is_acyclic G' && wGraph.IsFullSubgraph.is_full_extension G G' ; + (match push_uctx G uctx with + | Some G' => true + (* wGraph.IsFullSubgraph.is_full_extension G G' *) + | None => false + end) ; abstract_env_add_udecl X udecl Hglobal := {| reference_impl_env_ext := (X.(reference_impl_env) , udecl); |} ; abstract_primitive_constant := fun X tag => primitive_constant X tag; @@ -175,7 +178,7 @@ Program Global Instance optimized_abstract_env_struct {cf:checker_flags} {guard abstract_env_struct wf_env wf_env_ext := {| abstract_env_lookup := fun Σ k => EnvMap.lookup k (wf_env_ext_map Σ); - abstract_env_leqb_level_n X := abstract_env_leqb_level_n X.(wf_env_ext_reference); + abstract_env_check X := abstract_env_check X.(wf_env_ext_reference); abstract_env_level_mem X := abstract_env_level_mem X.(wf_env_ext_reference); abstract_env_guard := fun Σ fix_cofix => guard_impl fix_cofix (wf_env_ext_reference Σ); abstract_env_ext_rel X := abstract_env_ext_rel X.(wf_env_ext_reference); @@ -256,7 +259,7 @@ Definition build_wf_env_ext {cf : checker_flags} {guard : abstract_guard_impl} ( Section GraphSpec. Context {cf:checker_flags} {guard : abstract_guard_impl} {Σ : global_env_ext} (HΣ : ∥ wf Σ ∥) (Hφ : ∥ on_udecl Σ.1 Σ.2 ∥) - (G : universes_graph) (HG : is_graph_of_uctx G (global_ext_uctx Σ)). + (G : universe_model) (HG : model_of_uctx G (global_ext_uctx Σ)). Local Definition HΣ' : ∥ wf_ext Σ ∥. Proof. @@ -264,17 +267,13 @@ Section GraphSpec. Qed. Lemma is_graph_of_uctx_levels (l : Level.t) : - LevelSet.mem l (uGraph.wGraph.V G) <-> + LevelSet.mem l (UnivLoopChecking.UnivLoopChecking.levels G) <-> LevelSet.mem l (global_ext_levels Σ). Proof using HG. - unfold is_graph_of_uctx in HG. - case_eq (gc_of_uctx (global_ext_uctx Σ)); [intros [lvs cts] XX|intro XX]; - rewrite -> XX in *; simpl in *; [|contradiction]. - unfold gc_of_uctx in XX; simpl in XX. - destruct (gc_of_constraints Σ); [|discriminate]. - inversion XX; subst. - unfold is_true. rewrite !LevelSet.mem_spec. - symmetry. apply HG. + destruct HG as [-> _]. + rewrite ![is_true _]LevelSet.mem_spec LevelSet.union_spec LevelSet.singleton_spec. + split => //. intros [] => //. subst. + apply global_ext_levels_InSet. intuition. Qed. End GraphSpec. @@ -296,21 +295,18 @@ Next Obligation. Qed. Next Obligation. pose proof (reference_impl_ext_wf X); sq. - set (uctx := wf_ext_gc_of_uctx _) in *; destruct uctx as [[lc ctrs] Huctx]. assert (consistent (global_ext_uctx X).2) as HC. - { sq; apply (global_ext_uctx_consistent _ H). } - simpl in HC. apply gc_consistent_iff in HC. - eapply leqb_level_n_spec; eauto. - + eapply gc_of_uctx_invariants; try eapply wf_ext_global_uctx_invariants; eauto. - + clear Hl Hl'. Opaque gc_of_constraints. cbn in *. Transparent gc_of_constraints. - destruct (gc_of_constraints X); inversion Huctx. now destruct H2. - + unfold reference_impl_ext_graph; cbn. - set (G := graph_of_wf_ext _); destruct G as [G HG]. - cbn. unfold is_graph_of_uctx in HG. now rewrite Huctx in HG. + { sq; apply (global_ext_uctx_consistent _ H0). } + rewrite (checkb_spec (reference_impl_ext_graph X) (clean_uctx (global_ext_uctx X))). + + eapply wf_ext_global_uctx_invariants, H0. + + eapply model_of_clean_uctx. + apply (reference_impl_ext_graph_wf X). + + rewrite /clean_uctx. destruct c as [[l d] r]; cbn; rewrite levelset_add_remove. exact H. + + reflexivity. Qed. Next Obligation. pose (reference_impl_ext_wf X). sq. symmetry; apply LevelSet.Raw.mem_spec. typeclasses eauto. Defined. -Next Obligation. - pose (reference_impl_wf X). sq. +Next Obligation. todo "consistent extension on". Qed. + (* pose (reference_impl_wf X). sq. rename H0 into Hudecl. rename H1 into Hudecl'. assert (H0 : global_uctx_invariants (global_uctx X)). { eapply wf_global_uctx_invariants; eauto. } @@ -340,7 +336,7 @@ Next Obligation. change (UCS.union _ _) with global_ext_uctx.2. apply: consistent_ext_on_full_ext=> //. apply: add_uctx_subgraph. -Qed. +Qed. *) Next Obligation. apply guard_correct. Qed. @@ -367,8 +363,9 @@ Next Obligation. now rewrite <- H. Qed. Next Obligation. - revert n l l' Hl Hl'. erewrite wf_ext_gc_of_uctx_irr. - exact (abstract_env_leqb_level_n_correct X.(wf_env_ext_reference) eq_refl). + (* erewrite wf_ext_gc_of_uctx_irr. *) + have h := abstract_env_check_correct X.(wf_env_ext_reference). + specialize (h cf _ _ _ X eq_refl). now apply h. Qed. Next Obligation. now erewrite (abstract_env_level_mem_correct X.(wf_env_ext_reference)). diff --git a/template-pcuic/theories/TemplateToPCUICCorrectness.v b/template-pcuic/theories/TemplateToPCUICCorrectness.v index d7b31c169..09a04ca58 100644 --- a/template-pcuic/theories/TemplateToPCUICCorrectness.v +++ b/template-pcuic/theories/TemplateToPCUICCorrectness.v @@ -147,7 +147,7 @@ Qed. Lemma incl_cs_refl cs : cs ⊂_cs cs. Proof. - split; [lsets|csets]. + split; [lsets|ucsets]. Qed. Lemma extends_trans_global_decls_acc (Σ' : global_env_map) (Σ : Ast.Env.global_declarations) : @@ -2528,7 +2528,7 @@ Proof. + constructor; eauto. cbn [array_universe a]. eapply validity in X1; eauto. eapply PCUICWfUniverses.isType_wf_universes in X1. cbn [trans PCUICWfUniverses.wf_universes] in X1. unfold PCUICWfUniverses.wf_universes in X1. cbn [PCUICWfUniverses.on_universes Sort.on_sort s] in X1. - move: X1. case: PCUICWfUniverses.wf_universe_reflect => //; eauto. eauto. + move: X1. case: PCUICWfUniverses.wf_universeP => //; eauto. eauto. cbn [a array_value]. solve_all. - assert (WfAst.wf Σ B). { now apply typing_wf in X2. } From 7411067efb5943c91a584c7bcd62c5b7be7bece3 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 6 Nov 2025 16:02:25 +0100 Subject: [PATCH 127/164] Stop building quotation --- Makefile | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/Makefile b/Makefile index 3c56fa4cc..0da598896 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ -all: printconf template-rocq pcuic safechecker erasure erasure-plugin safechecker-plugin quotation +all: printconf template-rocq pcuic safechecker erasure erasure-plugin safechecker-plugin -include Makefile.conf @@ -33,7 +33,7 @@ install: all $(MAKE) -C pcuic install $(MAKE) -C safechecker install $(MAKE) -C template-pcuic install - $(MAKE) -C quotation install +# $(MAKE) -C quotation install $(MAKE) -C safechecker-plugin install $(MAKE) -C erasure install $(MAKE) -C erasure-plugin install @@ -45,7 +45,7 @@ uninstall: $(MAKE) -C pcuic uninstall $(MAKE) -C safechecker uninstall $(MAKE) -C template-pcuic uninstall - $(MAKE) -C quotation uninstall +# $(MAKE) -C quotation uninstall $(MAKE) -C safechecker-plugin uninstall $(MAKE) -C erasure uninstall $(MAKE) -C erasure-plugin uninstall @@ -65,7 +65,6 @@ html: all -R safechecker-plugin/theories MetaRocq.SafeCheckerPlugin \ -R erasure/theories MetaRocq.Erasure \ -R erasure-plugin/theories MetaRocq.ErasurePlugin \ - -R quotation/theories MetaRocq.Quotation \ -R translations MetaRocq.Translations \ -R examples MetaRocq.Examples \ -d html */theories/*.v */theories/*/*.v translations/*.v examples/*.v @@ -80,7 +79,7 @@ clean: $(MAKE) -C safechecker clean $(MAKE) -C safechecker-plugin clean $(MAKE) -C template-pcuic clean - $(MAKE) -C quotation clean +# $(MAKE) -C quotation clean $(MAKE) -C erasure clean $(MAKE) -C erasure-plugin clean $(MAKE) -C examples clean @@ -95,7 +94,7 @@ vos: $(MAKE) -C safechecker vos $(MAKE) -C safechecker-plugin vos $(MAKE) -C template-pcuic vos - $(MAKE) -C quotation vos +# $(MAKE) -C quotation vos $(MAKE) -C erasure vos $(MAKE) -C erasure-plugin vos $(MAKE) -C translations vos @@ -108,7 +107,7 @@ quick: $(MAKE) -C safechecker quick $(MAKE) -C safechecker-plugin quick $(MAKE) -C template-pcuic quick - $(MAKE) -C quotation vos # quick # we cannot unset universe checking in 8.16 due to COQBUG(https://github.com/coq/coq/issues/17361), and quick does not buy much in quotation anyway, where almost everything is transparent +# $(MAKE) -C quotation vos # quick # we cannot unset universe checking in 8.16 due to COQBUG(https://github.com/coq/coq/issues/17361), and quick does not buy much in quotation anyway, where almost everything is transparent $(MAKE) -C erasure quick $(MAKE) -C erasure-plugin quick $(MAKE) -C translations quick @@ -121,7 +120,7 @@ mrproper: $(MAKE) -C safechecker mrproper $(MAKE) -C safechecker-plugin mrproper $(MAKE) -C template-pcuic mrproper - $(MAKE) -C quotation mrproper +# $(MAKE) -C quotation mrproper $(MAKE) -C erasure mrproper $(MAKE) -C erasure-plugin mrproper $(MAKE) -C examples mrproper @@ -136,7 +135,7 @@ mrproper: $(MAKE) -C safechecker .merlin $(MAKE) -C safechecker-plugin .merlin $(MAKE) -C template-pcuic .merlin - $(MAKE) -C quotation .merlin +# $(MAKE) -C quotation .merlin $(MAKE) -C erasure .merlin $(MAKE) -C erasure-plugin .merlin @@ -158,8 +157,8 @@ safechecker: pcuic template-pcuic: template-rocq pcuic $(MAKE) -C template-pcuic -quotation: template-rocq pcuic template-pcuic - $(MAKE) -C quotation +# quotation: template-rocq pcuic template-pcuic +# $(MAKE) -C quotation safechecker-plugin: safechecker template-pcuic $(MAKE) -C safechecker-plugin From d03c383aaa081789ba66ad135b1fa50f5117e3e1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 6 Nov 2025 20:12:12 +0100 Subject: [PATCH 128/164] Ported safe checker --- .../Conversion/PCUICUnivSubstitutionConv.v | 35 ++- safechecker-plugin/_PluginProject.in | 12 +- safechecker/theories/PCUICSafeChecker.v | 274 +++++++++--------- safechecker/theories/PCUICTypeChecker.v | 25 ++ safechecker/theories/PCUICWfEnv.v | 2 +- 5 files changed, 192 insertions(+), 156 deletions(-) diff --git a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v index 64895aca4..06dd6ff9d 100644 --- a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v +++ b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v @@ -26,6 +26,23 @@ Local Ltac aa := rdest; eauto with univ_subst. Import Universe.NES. Import Universes. +Lemma map_singleton f le : Universe.map f (singleton le) = singleton (f le). +Proof. + apply equal_exprsets=> l; rewrite Universe.map_spec. firstorder subst. + * apply LevelExprSet.singleton_spec. now apply LevelExprSet.singleton_spec in H; subst. + * apply LevelExprSet.singleton_spec in H. subst l. exists le. split => //. now apply LevelExprSet.singleton_spec. +Qed. + +Lemma map_add f le u : Universe.map f (add le u) = add (f le) (Universe.map f u). +Proof using Type. + apply equal_exprsets=> l; rewrite Universe.map_spec. firstorder subst. + * apply LevelExprSet.add_spec. apply LevelExprSet.add_spec in H as [H|H]; subst; auto. + right. apply map_spec. now exists x. + * setoid_rewrite LevelExprSet.add_spec. apply LevelExprSet.add_spec in H as [H|H]. + + subst l. now exists le; split. + + apply map_spec in H as [e []]. exists e. split => //. now right. +Qed. + Lemma subset_levels l s : LevelSet.Subset (levels l) s <-> (forall lk, LevelExprSet.In lk l -> LevelSet.In lk.1 s). Proof. rewrite /LevelSet.Subset. setoid_rewrite levels_spec. firstorder. apply H. exists lk.2; destruct lk => //. @@ -2017,24 +2034,6 @@ Section SubstIdentity. * destruct l' => //. Qed. - Lemma map_singleton f le : Universe.map f (singleton le) = singleton (f le). - Proof. - apply equal_exprsets=> l; rewrite Universe.map_spec. firstorder subst. - * apply LevelExprSet.singleton_spec. now apply LevelExprSet.singleton_spec in H; subst. - * apply LevelExprSet.singleton_spec in H. subst l. exists le. split => //. now apply LevelExprSet.singleton_spec. - Qed. - - Lemma map_add f le u : Universe.map f (add le u) = add (f le) (Universe.map f u). - Proof using Type. - clear cf. - apply equal_exprsets=> l; rewrite Universe.map_spec. firstorder subst. - * apply LevelExprSet.add_spec. apply LevelExprSet.add_spec in H as [H|H]; subst; auto. - right. apply map_spec. now exists x. - * setoid_rewrite LevelExprSet.add_spec. apply LevelExprSet.add_spec in H as [H|H]. - + subst l. now exists le; split. - + apply map_spec in H as [e []]. exists e. split => //. now right. - Qed. - Lemma subst_level_instance_level_instance_level {i} {l : Level.t} : Universe.of_level (subst_level_instance_level i l) = subst_instance_level i l. Proof. diff --git a/safechecker-plugin/_PluginProject.in b/safechecker-plugin/_PluginProject.in index 9dc2f2b67..fb0ae1bdd 100644 --- a/safechecker-plugin/_PluginProject.in +++ b/safechecker-plugin/_PluginProject.in @@ -9,8 +9,18 @@ src/META.rocq-metarocq-safechecker # From template src/ssrbool.ml src/ssrbool.mli -src/uGraph0.ml src/uGraph0.mli +src/uGraph0.ml +src/hornClauses.mli +src/hornClauses.ml +src/model.mli +src/model.ml +src/partialLoopChecking.mli +src/partialLoopChecking.ml +src/univLoopChecking.mli +src/univLoopChecking.ml +src/deciders.mli +src/deciders.ml src/wGraph.ml src/wGraph.mli diff --git a/safechecker/theories/PCUICSafeChecker.v b/safechecker/theories/PCUICSafeChecker.v index 02b5fa3a7..c39958798 100644 --- a/safechecker/theories/PCUICSafeChecker.v +++ b/safechecker/theories/PCUICSafeChecker.v @@ -21,7 +21,7 @@ From MetaRocq.SafeChecker Require Import PCUICEqualityDec PCUICSafeReduce PCUICE PCUICSafeConversion PCUICWfReduction PCUICWfEnv PCUICTypeChecker. From Equations Require Import Equations. -From Stdlib Require Import ssreflect ssrbool. +From Stdlib Require Import ssreflect ssrbool ssrfun. Local Set Keyed Unification. Set Equations Transparent. @@ -31,78 +31,38 @@ From Stdlib Require Import Morphisms. Implicit Types (cf : checker_flags). -Global Instance proper_add_level_edges levels : Morphisms.Proper (wGraph.EdgeSet.Equal ==> wGraph.EdgeSet.Equal)%signature (add_level_edges levels). -Proof. - intros e e' he. - rewrite /add_level_edges. - rewrite !VSet.fold_spec. - induction (VSet.elements levels) in e, e', he |- *; cbn; auto. - apply IHl. destruct variable_of_level => //. - now rewrite he. -Qed. - -Global Instance proper_add_uctx cstrs : Morphisms.Proper (Equal_graph ==> Equal_graph)%signature (add_uctx cstrs). +(* Global Instance proper_add_uctx cstrs : Morphisms.Proper (Equal_graph ==> Equal_graph)%signature (push_uctx cstrs). Proof. intros g g' eq. rewrite /add_uctx; cbn. split. cbn. now rewrite (proj1 eq). cbn. split => //. rewrite /add_level_edges. now rewrite (proj1 (proj2 eq)). apply eq. -Qed. +Qed. *) Definition cs_equal (x y : ContextSet.t) : Prop := LevelSet.Equal x.1 y.1 /\ UnivConstraintSet.Equal x.2 y.2. -Definition gcs_equal x y : Prop := - LevelSet.Equal x.1 y.1 /\ GoodUnivConstraintSet.Equal x.2 y.2. - Require Import Relation_Definitions. - - Definition R_opt {A} (R : relation A) : relation (option A) := - fun x y => match x, y with - | Some x, Some y => R x y - | None, None => True - | _, _ => False - end. - - Global Instance gc_of_constraints_proper {cf} : Proper (UnivConstraintSet.Equal ==> R_opt GoodUnivConstraintSet.Equal) gc_of_constraints. - Proof. - intros c c' eqc; cbn. - destruct (gc_of_constraintsP c); - destruct (gc_of_constraintsP c'); cbn. - - intros cs; rewrite i i0. firstorder eauto. - - destruct e0 as [cs [incs gcn]]. - apply eqc in incs. destruct (e cs incs) as [? []]. congruence. - - destruct e as [cs [incs gcn]]. - apply eqc in incs. destruct (e0 cs incs) as [? []]. congruence. - - exact I. - Qed. - - Global Instance proper_add_level_edges' : Morphisms.Proper (LevelSet.Equal ==> wGraph.EdgeSet.Equal ==> wGraph.EdgeSet.Equal)%signature add_level_edges. - Proof. - intros l l' hl e e' <-. - intros x; rewrite !add_level_edges_spec. firstorder eauto. - Qed. - Global Instance make_graph_proper : Proper (gcs_equal ==> Equal_graph) make_graph. + (* Global Instance make_graph_proper : Proper (gcs_equal ==> Equal_graph) make_graph. Proof. intros [v c] [v' c'] [eqv eqc]; cbn. unfold make_graph; cbn in *. split; cbn; auto. split; cbn; try reflexivity. now rewrite eqc eqv. - Qed. + Qed.*) Require Import SetoidTactics. - Global Instance is_graph_of_uctx_proper {cf} G : Proper (cs_equal ==> iff) (is_graph_of_uctx G). + Global Instance model_of_uctx_proper {cf} G : Proper (cs_equal ==> iff) (model_of_uctx G). Proof. intros [l c] [l' c'] [eql eqc]; cbn. - unfold is_graph_of_uctx; cbn. cbn in *. - pose proof (gc_of_constraints_proper _ _ eqc). - destruct (gc_of_constraints c); cbn in *; destruct (gc_of_constraints c'); cbn. - now setoid_replace (l, t) with (l', t0) using relation gcs_equal. elim H. elim H. - intuition. - Qed. + unfold model_of_uctx; cbn. cbn in *. + split. intros []; split. now rewrite -eql. + rewrite -eqc. + + Admitted. (** It otherwise tries [auto with *], very bad idea. *) @@ -145,6 +105,13 @@ Section OnUdecl. apply LevelSetProp.of_list_1, InA_In_eq. eapply In_unfold_inj; try congruence. Qed. +(* + Lemma bounded_poly_ext (ls : Universe.t) (inst : list name) (cstrs : UnivConstraintSet.t) Σ : + LevelSet.Subset (Universe.levels ls) (LevelSet.union (levels_of_udecl (Polymorphic_ctx (inst, cstrs))) (global_ext_levels Σ)) -> closedu_universe #|inst| ls. + Proof. + have hb := LSet_in_poly_bounded _ inst cstrs. + move/subset_levels => hl. + Search closedu_universe. *) Lemma on_udecl_poly_bounded X inst cstrs : wf X -> @@ -158,40 +125,47 @@ Section OnUdecl. specialize (nlevs x incstrs). destruct x as [[l1 p] l2]. destruct nlevs. - apply LevelSetProp.Dec.F.union_1 in H. - apply LevelSetProp.Dec.F.union_1 in H0. - destruct H. eapply LSet_in_poly_bounded in H. - destruct H0. eapply LSet_in_poly_bounded in H0. simpl. now rewrite H H0. - eapply (LSet_in_global_bounded #|inst|) in H0 => //. simpl. - now rewrite H H0. - eapply (LSet_in_global_bounded #|inst|) in H => //. simpl. - destruct H0. eapply LSet_in_poly_bounded in H0. simpl. now rewrite H H0. - eapply (LSet_in_global_bounded #|inst|) in H0 => //. simpl. - now rewrite H H0. + cbn. toProp; unshelve eapply bounded_poly_global_levels; tea. Qed. Lemma subst_instance_level_lift inst l : closedu_level #|inst| l -> - subst_instance_level (lift_instance #|inst| (level_var_instance 0 inst)) l = lift_level #|inst| l. + subst_instance_level (lift_instance #|inst| (Instance.of_level_instance (level_var_instance 0 inst))) l = Universe.of_level @@ lift_level #|inst| l. Proof using Type. + clear cf. destruct l => // /= /Nat.ltb_lt ltn. - rewrite nth_nth_error. + rewrite nth_error_map. destruct nth_error eqn:eq. move:eq. - rewrite nth_error_map /level_var_instance [mapi_rec _ _ _]mapi_unfold (proj1 (nth_error_unfold _ _ _) ltn). - simpl. now intros [=]. - eapply nth_error_None in eq; len in eq. + - rewrite nth_error_map /level_var_instance [mapi_rec _ _ _]mapi_unfold (proj1 (nth_error_unfold _ _ _) ltn). + simpl. intros [=]. subst t. + unfold lift_universe. rewrite map_singleton //=. + - eapply nth_error_None in eq; len in eq. Qed. + Lemma subst_instance_universe_lift inst l : + closedu_universe #|inst| l -> + subst_instance (lift_instance #|inst| (Instance.of_level_instance (level_var_instance 0 inst))) l = lift_universe #|inst| l. + Proof. Admitted. + Lemma subst_instance_level_var_instance inst l : closedu_level #|inst| l -> - subst_instance_level (level_var_instance 0 inst) l = l. + subst_instance_level (level_var_instance 0 inst) l = Universe.of_level l. Proof using Type. destruct l => // /= /Nat.ltb_lt ltn. - rewrite /level_var_instance. - rewrite nth_nth_error. + rewrite /level_var_instance nth_error_map. now rewrite /level_var_instance [mapi_rec _ _ _]mapi_unfold (proj1 (nth_error_unfold _ _ _) ltn). Qed. + + Lemma subst_instance_universe_var_instance inst l : + closedu_universe #|inst| l -> + subst_instance (level_var_instance 0 inst) l = l. + Proof using Type. + Admitted. + + Lemma lift_universe_singleton n n' : lift_universe n (Universe.of_level (Level.lvar n')) = Universe.of_level (Level.lvar (n + n')). + Proof. Admitted. + Lemma variance_universes_spec Σ ctx v univs u u' : wf_ext (Σ, ctx) -> wf_ext (Σ, univs) -> @@ -207,8 +181,12 @@ Section OnUdecl. subst u u'. autorewrite with len. repeat (split; auto). - rewrite forallb_map /level_var_instance. + rewrite forallb_map. rewrite [mapi_rec _ _ _]mapi_unfold forallb_unfold /= //. - intros x Hx. apply In_Var_global_ext_poly. len. + intros x Hx. rewrite lift_universe_singleton //= Universe.levels_singleton //=. + apply LevelSet.subset_spec => lk. move/LS.singleton_spec => ->. + apply LevelSet.mem_spec. + apply In_Var_global_ext_poly. len. - destruct wfext as [onX onu]. simpl in *. destruct onu as [_ [_ [sat _]]]. do 2 red in sat. @@ -227,17 +205,20 @@ Section OnUdecl. rewrite In_lift_constraints. rewrite -> In_subst_instance_cstrs in hin. destruct hin as [c' [eqx inc']]. clear vsat. - subst x. eexists. unfold subst_instance_cstr. + subst x. eexists. unfold subst_instance_univ_cstr. unfold lift_constraint. split; eauto. destruct c' as [[l comp] r]. simpl. destruct wfctx as [_ wfctx]. simpl in wfctx. eapply on_udecl_poly_bounded in wfctx; auto. specialize (wfctx _ inc'). simpl in wfctx. move/andP: wfctx => [cll clr]. - rewrite !subst_instance_level_lift //. + rewrite !subst_instance_universe_lift //. - rewrite /level_var_instance. - rewrite [mapi_rec _ _ _]mapi_unfold forallb_unfold /= //. - intros x Hx. apply In_Var_global_ext_poly. len. + rewrite forallb_map [mapi_rec _ _ _]mapi_unfold forallb_unfold /= //. + intros x Hx. + apply LevelSet.subset_spec => lk. move/LS.singleton_spec => ->. + apply LevelSet.mem_spec. + apply In_Var_global_ext_poly. len. - destruct wfext as [onX onu]. simpl in *. destruct onu as [_ [_ [sat _]]]. do 2 red in sat. @@ -261,8 +242,8 @@ Section OnUdecl. destruct wfctx as [_ wfctx]. simpl in wfctx. eapply on_udecl_poly_bounded in wfctx; auto. specialize (wfctx _ inc'). simpl in wfctx. - move/andP: wfctx => [cll clr]. rewrite /subst_instance_cstr /=. - rewrite !subst_instance_level_var_instance //. + move/andP: wfctx => [cll clr]. rewrite /subst_instance_univ_cstr /=. + rewrite !subst_instance_universe_var_instance //. Qed. End OnUdecl. @@ -332,28 +313,56 @@ Section CheckEnv. apply/LevelSet.union_spec; by left. Qed. + Definition declared_universe (ls : LevelSet.t) u : bool := + LevelSet.subset (Universe.levels u) ls. + + Definition abstract_declared_universe X (ls : LevelSet.t) u : bool := + LevelSet.for_all (abstract_env_level_mem' (abstract_env_empty_ext X) ls) (Universe.levels u). + + Lemma abstract_declared_universe_spec X u ls : + abstract_declared_universe X ls u <-> + (forall Σ : global_env, abstract_env_rel X Σ -> LevelSet.Subset (Universe.levels u) (LevelSet.union ls (global_levels Σ))). + Proof. + split. + - intros hd Σ eq. + destruct (abstract_env_wf _ eq) as [wfΣ]. + red in hd. + apply LevelSet.for_all_spec in hd. + apply subset_levels. + intros [l k] hin. + specialize (hd l). + move: hd => /fwd. apply Universe.levels_spec. now exists k. + rewrite -(abstract_env_level_mem_correct' (abstract_env_empty_ext X) (Σ := (Σ, Monomorphic_ctx))) //. + rewrite -abstract_env_empty_ext_rel. split => //. + move/LevelSet.mem_spec => //. tc. + - intros h; apply LevelSet.for_all_spec; tc. + destruct (abstract_env_exists X) as [[Σ hΣ]]. + specialize (h _ hΣ). + destruct (abstract_env_wf _ hΣ) => l. + move/h => hin. + rewrite -(abstract_env_level_mem_correct' (abstract_env_empty_ext X) (Σ := (Σ, Monomorphic_ctx))) //. + rewrite -abstract_env_empty_ext_rel. split => //. + now apply LevelSet.mem_spec. + Qed. + + Definition uctx_of_udecl decl := (levels_of_udecl decl, constraints_of_udecl decl). + Program Definition check_udecl id X (udecl : universes_decl) - : EnvCheck X_env_ext_type (∑ uctx', gc_of_uctx (uctx_of_udecl udecl) = Some uctx' /\ - forall Σ : global_env, abstract_env_rel X Σ -> ∥ on_udecl Σ udecl ∥) := + : EnvCheck X_env_ext_type (forall Σ : global_env, abstract_env_rel X Σ -> ∥ on_udecl Σ udecl ∥) := let levels := levels_of_udecl udecl in check_eq_true_lazy (LevelSet.for_all (fun l => Level.is_var l) levels) (fun _ => (abstract_env_empty_ext X, IllFormedDecl id (Msg ("non fresh level in " ^ print_lset levels))));; - check_eq_true_lazy (UnivConstraintSet.for_all (fun '(l1, _, l2) => abstract_env_level_mem' (abstract_env_empty_ext X) levels l1 && abstract_env_level_mem' (abstract_env_empty_ext X) levels l2) (constraints_of_udecl udecl)) + check_eq_true_lazy (UnivConstraintSet.for_all (fun '(l1, _, l2) => abstract_declared_universe X levels l1 && + abstract_declared_universe X levels l2) (constraints_of_udecl udecl)) (fun _ => (abstract_env_empty_ext X, IllFormedDecl id (Msg ("non declared level in " ^ print_lset levels ^ - " |= " ^ print_constraint_set (constraints_of_udecl udecl)))));; - match gc_of_uctx (uctx_of_udecl udecl) as X' return (X' = _ -> EnvCheck X_env_ext_type _) with - | None => fun _ => - raise (abstract_env_empty_ext X, IllFormedDecl id (Msg "constraints trivially not satisfiable")) - | Some uctx' => fun Huctx => - check_eq_true (abstract_env_is_consistent X uctx') - (abstract_env_empty_ext X, IllFormedDecl id (Msg "constraints not satisfiable"));; - ret (uctx'; _) - end eq_refl. + " |= " ^ print_univ_constraint_set (constraints_of_udecl udecl)))));; + check_eq_true (abstract_env_is_consistent X (uctx_of_udecl udecl)) + (abstract_env_empty_ext X, IllFormedDecl id (Msg "constraints not satisfiable"));; + ret _. Next Obligation. - simpl. intros id X udecl H H0 uctx' Huctx H2. - rewrite <- Huctx. - split; auto. - intros Σ wfΣ. + simpl. intros id X udecl H H0 uctx' Σ wfΣ. + split. + pose proof (abstract_env_wf _ wfΣ) as [hΣ]. assert (HH: UnivConstraintSet.For_all (declared_univ_cstr_levels (LS.union (levels_of_udecl udecl) (global_levels Σ))) (constraints_of_udecl udecl)). @@ -362,26 +371,22 @@ Section CheckEnv. 2: now intros x y []. intros [[l ct] l'] Hl. specialize (H0 _ Hl). simpl in H0. apply andb_true_iff in H0. destruct H0 as [H H0]. - rewrite <- abstract_env_level_mem_correct' with (Σ := (Σ, Monomorphic_ctx)) in H. - apply LevelSet.mem_spec in H. - rewrite <- abstract_env_level_mem_correct' with (Σ := (Σ, Monomorphic_ctx)) in H0. - apply LevelSet.mem_spec in H0. - now split. rewrite <- abstract_env_empty_ext_rel. split; eauto. - rewrite <- abstract_env_empty_ext_rel. split; eauto. - } - split; last (split; last split). + move/abstract_declared_universe_spec: H => /(_ _ wfΣ). + move/abstract_declared_universe_spec: H0 => /(_ _ wfΣ). + now cbn. } + split; auto. - clear -H wfΣ. apply LevelSet.for_all_spec in H. 2: now intros x y []. intros l Hl Hlglob. move: (wf_env_non_var_levels Σ (heΣ _ _ wfΣ) l Hlglob). now rewrite (H l Hl). - - eauto. - - pose (HΣ := abstract_env_wf _ wfΣ); sq. + - split; eauto. + pose (HΣ := abstract_env_wf _ wfΣ); sq. apply wf_global_uctx_invariants in HΣ. - pose (HΣ' := abstract_env_wf _ wfΣ); sq. enough (valid_on_mono_udecl (global_uctx Σ) udecl). 1: { split. apply wf_consistent_extension_on_consistent => //. apply: consistent_extension_on_global=> //. } + red. eapply abstract_env_is_consistent_correct with (udecl := uctx_of_udecl udecl); eauto=> //. Qed. @@ -406,12 +411,11 @@ Section CheckEnv. - now apply abstract_env_empty_ext_rel in H. Qed. Next Obligation. - simpl; cbn; intros. eapply (proj2 uctx.π2); eauto. + simpl; cbn; intros. now apply uctx. Qed. Next Obligation. simpl; cbn; intros. split; intros ? ?. - { rewrite Heq_ext. - destruct uctx as [uctx' [gcof onu]]. cbn. + { rewrite Heq_ext. cbn. eapply abstract_env_add_udecl_rel; cbn; eauto. } { eapply abstract_env_add_udecl_rel with (udecl := ext) in H; cbn; try now eauto. } Qed. @@ -1480,18 +1484,18 @@ Section CheckEnv. now eapply isType_weaken. Qed. - Equations? check_variance {X} (id : kername) univs (variances : option (list Variance.t)) + Equations? check_variance {X} (name : kername) univs (variances : option (list Variance.t)) (wfunivs : forall Σ, abstract_env_rel X Σ -> ∥ wf_ext (Σ, univs) ∥) : EnvCheck X_env_ext_type (forall Σ, abstract_env_rel X Σ -> ∥ on_variance Σ univs variances ∥) := - | id, univs, None, wfunivs := ret _ - | id, univs, Some v, wfunivs with inspect (variance_universes univs v) := { + | name, univs, None, wfunivs := ret _ + | name, univs, Some v, wfunivs with inspect (variance_universes univs v) := { | exist (Some (univs', i, i')) eqvu => check_leq <- check_eq_true (eqb #|v| #|polymorphic_instance univs|) - (abstract_env_empty_ext abstract_env_empty, IllFormedDecl (string_of_kername id) (Msg "Variance annotation does not have the right length"));; - Σ' <- make_abstract_env_ext X id univs' ;; + (abstract_env_empty_ext abstract_env_empty, IllFormedDecl (string_of_kername name) (Msg "Variance annotation does not have the right length"));; + Σ' <- make_abstract_env_ext X name univs' ;; ret _ - | exist None eqvu => raise (abstract_env_empty_ext abstract_env_empty, IllFormedDecl (string_of_kername id) (Msg "Ill-formed variance annotation")) }. + | exist None eqvu => raise (abstract_env_empty_ext abstract_env_empty, IllFormedDecl (string_of_kername name) (Msg "Ill-formed variance annotation")) }. Proof. - destruct H0 as [? ?]; eauto. specialize_Σ H. have [wfΣ] := abstract_env_ext_wf _ H0. sq. @@ -2280,17 +2284,16 @@ End monad_Alli_nth_forall. let id := "toplevel" in let levels := ContextSet.levels univs in check_eq_true_lazy (LevelSet.mem Level.lzero levels) - (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("Set not in the global levels " ^ print_lset levels))));; + (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("Level zero is not declared in the global levels " ^ print_lset levels))));; check_eq_true_lazy (LevelSet.for_all (fun l => negb (Level.is_var l)) levels) - (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("variable level in the global levels " ^ print_lset levels))));; - check_eq_true_lazy (UnivConstraintSet.for_all (fun c => LevelSet.mem c.1.1 levels && LevelSet.mem c.2 levels) (ContextSet.constraints univs)) - (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("non declared level in " ^ print_lset levels ^ - " |= " ^ print_constraint_set (ContextSet.constraints univs)))));; - match gc_of_uctx univs as X' return (X' = _ -> EnvCheck X_env_ext_type _) with - | None => fun _ => raise (abstract_env_ext_empty, IllFormedDecl id (Msg "constraints trivially not satisfiable")) - | Some uctx => fun _ => check_eq_true_lazy (@abstract_env_is_consistent_empty _ X_impl uctx) - (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg "constraints not satisfiable"))) ;; - ret (let Hunivs := _ in exist (abstract_env_init univs retro Hunivs) _) end eq_refl . + (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("Variable level in the global levels " ^ print_lset levels))));; + check_eq_true_lazy (UnivConstraintSet.for_all (fun c => declared_universe levels c.1.1 && declared_universe levels c.2) (ContextSet.constraints univs)) + (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("Non declared level in " ^ print_lset levels ^ + " |= " ^ print_univ_constraint_set (ContextSet.constraints univs)))));; + check_eq_true_lazy (@abstract_env_is_consistent_empty _ X_impl univs) + (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("Constraints are not satisfiable:" ^ + print_univ_constraint_set (ContextSet.constraints univs))))) ;; + ret (let Hunivs := _ in exist (abstract_env_init univs retro Hunivs) _). Next Obligation. intros. have decll : UnivConstraintSet.For_all (declared_univ_cstr_levels (ContextSet.levels univs)) (ContextSet.constraints univs). @@ -2298,7 +2301,7 @@ End monad_Alli_nth_forall. 2: now intros x y []. intros [[l ct] l'] Hl. specialize (i1 _ Hl). simpl in i1. apply andb_true_iff in i1. destruct i1 as [H H1]. - apply LevelSet.mem_spec in H. apply LevelSet.mem_spec in H1. + apply LevelSet.subset_spec in H. apply LevelSet.subset_spec in H1. now split. } intros. split; eauto. { intros l Hl. specialize (decll l Hl). red. destruct l, p. now rewrite levels_global_levels_declared. } @@ -2307,25 +2310,24 @@ End monad_Alli_nth_forall. + clear - i i0. apply LevelSet.for_all_spec in i0. 2: now intros x y []. intros l Hl. rewrite levels_global_levels_declared in Hl; eauto. - + cbn in e. rename e into Huctx. - case_eq (gc_of_constraints univs.2); - [|intro XX; rewrite XX in Huctx; noconf Huctx]. - intros Σctrs HΣctrs. - unfold abstract_env_is_consistent_empty in i2. + + unfold abstract_env_is_consistent_empty in i2. pose proof (abs_init := abstract_env_init_correct (abstract_env_impl := X_env_type) (LS.singleton Level.lzero, UCS.empty) Retroknowledge.empty PCUICWfEnv.abstract_env_empty_obligation_1). - pose proof (abs_consist := abstract_env_is_consistent_correct (@abstract_env_empty cf X_impl) _ uctx univs abs_init); cbn in *. - rewrite HΣctrs in abs_consist, Huctx. + epose proof (abs_consist := abstract_env_is_consistent_correct (@abstract_env_empty cf X_impl) _ univs abs_init); cbn in *. + rewrite /declared_univ_cstr_levels //= in abs_consist. + forward abs_consist. + { move/UCS.for_all_spec: i1 => hf cl /hf. destruct cl as [[? ?] ?] => //=. + case/andP=> /LevelSet.subset_spec hl /LevelSet.subset_spec hr. subst levels; unfold ContextSet.levels in *; cbn in *. + split; lsets. } + rewrite /global_uctx //= /global_levels /global_constraints //= in abs_consist. pose (abstract_env_wf _ abs_init). sq. rewrite <- abs_consist in i2; eauto ; clear abs_consist; cbn; sq. - - pose proof (wf_consistent_extension_on_consistent _ _ i2). - rewrite ConstraintSetProp.union_sym in H. now rewrite CS_union_empty in H. - - intros ? H. specialize (decll _ H). eapply PCUICWeakeningEnv.declared_cstr_levels_sub; eauto. - apply wGraph.VSetProp.union_subset_1. + pose proof (wf_consistent_extension_on_consistent _ _ i2). + rewrite UnivConstraintSetProp.union_sym in H. now rewrite CS_union_empty in H. Qed. Next Obligation. - cbv beta. intros univs retro id levels X H H0 Hconsistent ? ? Hunivs. clearbody Hunivs. - split. + cbv beta. intros univs retro name levels H nv hd habs Hunivs. clearbody Hunivs. + split. - intros. eapply (abstract_env_irr _ _ (abstract_env_init_correct _ _ _)); eauto. - now sq. Unshelve. eauto. diff --git a/safechecker/theories/PCUICTypeChecker.v b/safechecker/theories/PCUICTypeChecker.v index 3cdd8e5a4..639e8d6a9 100644 --- a/safechecker/theories/PCUICTypeChecker.v +++ b/safechecker/theories/PCUICTypeChecker.v @@ -1035,6 +1035,31 @@ Section Typecheck. * clear. intros h l [k h']. move/h: h' => //=. Qed. + Lemma eq_false_true b : b = false -> + b -> False. + Proof. destruct b => //. Qed. + + Equations declared_universe u : typing_result_comp (forall Σ (wfΣ : abstract_env_ext_rel X Σ), wf_universe Σ u) := + declared_universe u with inspect (LevelSet.for_all (abstract_env_level_mem X) @@ Universe.levels u) := { + | exist false e2 := raise (Msg "undeclared level in universe") + | exist true e2 := ret _ }. + Next Obligation. + pose proof (heΣ _ wfΣ) as [[_wfΣ s]]. specialize_Σ wfΣ. + symmetry in e2. eapply LevelSet.for_all_spec in e2. + specialize (e2 l.1). + move: e2 => /fwd. apply Universe.levels_spec. now exists l.2; destruct l. + move/(abstract_env_level_mem_correct X wfΣ). destruct l => //. tc. + Qed. + Next Obligation. + destruct (abstract_env_ext_exists X) as [[Σ wfΣ]]; specialize_Σ wfΣ; + pose proof (heΣ _ wfΣ) as [heΣ]. + symmetry in e2; move: e2. + move/eq_false_true; apply. + apply LevelSet.for_all_spec; tc => l. + move/Universe.levels_spec => -[k] /H //=. + now rewrite abstract_env_level_mem_correct; tea. + Qed. + Equations check_consistent_instance uctx (wfg : forall Σ (wfΣ : abstract_env_ext_rel X Σ), ∥ global_uctx_invariants (clean_uctx (global_ext_uctx (Σ.1, uctx))) ∥) u : typing_result_comp (forall Σ (wfΣ : abstract_env_ext_rel X Σ), consistent_instance_ext Σ uctx u) := diff --git a/safechecker/theories/PCUICWfEnv.v b/safechecker/theories/PCUICWfEnv.v index e2f7a343f..e95212a2d 100644 --- a/safechecker/theories/PCUICWfEnv.v +++ b/safechecker/theories/PCUICWfEnv.v @@ -110,7 +110,7 @@ Class abstract_env_prop {cf:checker_flags} (abstract_env_impl abstract_env_ext_i abstract_env_is_consistent_correct X Σ udecl : abstract_env_rel X Σ -> UnivConstraintSet.For_all (declared_univ_cstr_levels (LevelSet.union udecl.1 (global_levels Σ))) udecl.2 -> - consistent_extension_on (global_uctx Σ) udecl.2 <-> abstract_env_is_consistent X (global_uctx Σ); + consistent_extension_on (global_uctx Σ) udecl.2 <-> abstract_env_is_consistent X udecl; abstract_env_guard_correct X {Σ} (wfΣ : abstract_env_ext_rel X Σ) fix_cofix Γ mfix : guard fix_cofix Σ Γ mfix <-> abstract_env_guard X fix_cofix Γ mfix; From 856ac84a8dd7a6684ca6cbbababe6dbf827088a6 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 6 Nov 2025 20:37:01 +0100 Subject: [PATCH 129/164] Port safechecker plugin --- .vscode/metarocq.code-workspace | 2 +- .../LoopChecking/PartialLoopChecking.v | 13 ---------- safechecker-plugin/Makefile.plugin.local | 2 ++ safechecker-plugin/_PluginProject.in | 24 +++++++++++++++---- .../src/metarocq_safechecker_plugin.mlpack | 14 ++++++++++- safechecker-plugin/theories/Extraction.v | 2 +- 6 files changed, 37 insertions(+), 20 deletions(-) diff --git a/.vscode/metarocq.code-workspace b/.vscode/metarocq.code-workspace index 329bee370..4e21c057d 100644 --- a/.vscode/metarocq.code-workspace +++ b/.vscode/metarocq.code-workspace @@ -113,7 +113,7 @@ "**/Thumbs.db": true, "**/CVS": true }, - "coq-lsp.check_only_on_request": false, + "coq-lsp.check_only_on_request": true, "coqtop.binPath": "_opam/bin", "coqtop.coqtopExe": "coqtop", "coqtop.coqidetopExe": "coqidetop", diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index 5a6d9bb66..69c3366d6 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -624,19 +624,6 @@ Proof. apply restrict_with_concl_subset. Qed. -(* Lemma not_model_valid {m cls cl} : ~~ is_model m cls -> valid_clause m cl -> Clauses.In cl cls *) -Lemma invalid_clauses_restrict {cls cls' W m} : cls ⊂_clset (cls' ⇂ W) -> - invalid_clauses (restrict_model W m) cls -> - invalid_clauses m cls. -Proof. - move=> hincl ha cl /[dup] hin /ha. - destruct cl as [prems [concl k]]. - rewrite /valid_clause. cbn. - destruct min_premise eqn:hmin => //. - move/min_premise_restrict: hmin => ->. - -Admitted. - Lemma is_model_restrict_valid_noop {cls cls' W m} : cls ⊂_clset (cls' ⇂ W) -> forall cl, Clauses.In cl cls -> valid_clause m cl -> valid_clause (restrict_model W m) cl. Proof. diff --git a/safechecker-plugin/Makefile.plugin.local b/safechecker-plugin/Makefile.plugin.local index ccecbd154..c399c0416 100644 --- a/safechecker-plugin/Makefile.plugin.local +++ b/safechecker-plugin/Makefile.plugin.local @@ -2,10 +2,12 @@ CAMLFLAGS :=-thread -bin-annot -strict-sequence -w -a+1..3-4+5..8-9+10..26-27+28 CAMLFLAGS+=-open Metarocq_template_plugin CAMLFLAGS+=-w -8 # Non-exhaustive matches due to translation of comparison to int CAMLFLAGS+=-w -20 # Unused arguments +CAMLFLAGS+=-w -26 # Unused variables CAMLFLAGS+=-w -33 # Unused opens CAMLFLAGS+=-w -32 # Unused values CAMLFLAGS+=-w -34 # Unused types CAMLFLAGS+=-w -39 # Unused rec flags +CAMLFLAGS+=-w -56 # Unreachable case CAMLFLAGS+=-w -60 # Unused module in functor CAMLPKGS+=-package rocq-metarocq-template-ocaml.plugin diff --git a/safechecker-plugin/_PluginProject.in b/safechecker-plugin/_PluginProject.in index fb0ae1bdd..77e46e313 100644 --- a/safechecker-plugin/_PluginProject.in +++ b/safechecker-plugin/_PluginProject.in @@ -9,20 +9,34 @@ src/META.rocq-metarocq-safechecker # From template src/ssrbool.ml src/ssrbool.mli -src/uGraph0.mli -src/uGraph0.ml +src/mRInstances.mli +src/mRInstances.ml + +# Universe checking algorithm +src/common1.mli +src/common1.ml +src/interfaces.mli +src/interfaces.ml src/hornClauses.mli src/hornClauses.ml +src/initialSemilattice.mli +src/initialSemilattice.ml +src/hornSemilatticeEquiv.mli +src/hornSemilatticeEquiv.ml src/model.mli src/model.ml +src/models.mli +src/models.ml src/partialLoopChecking.mli src/partialLoopChecking.ml src/univLoopChecking.mli src/univLoopChecking.ml src/deciders.mli src/deciders.ml -src/wGraph.ml -src/wGraph.mli +src/uGraph0.mli +src/uGraph0.ml +# src/wGraph.ml +# src/wGraph.mli # From PCUIC src/pCUICPrimitive.mli @@ -49,6 +63,8 @@ src/pCUICPretty.mli src/pCUICPretty.ml src/pCUICProgram.mli src/pCUICProgram.ml +src/pCUICGlobalEnv.mli +src/pCUICGlobalEnv.ml # From SafeChecker src/pCUICErrors.mli diff --git a/safechecker-plugin/src/metarocq_safechecker_plugin.mlpack b/safechecker-plugin/src/metarocq_safechecker_plugin.mlpack index 0319bc8a8..560b17c48 100644 --- a/safechecker-plugin/src/metarocq_safechecker_plugin.mlpack +++ b/safechecker-plugin/src/metarocq_safechecker_plugin.mlpack @@ -1,6 +1,17 @@ Utils Ssrbool -WGraph +MRInstances + +Common1 +Interfaces +HornClauses +InitialSemilattice +HornSemilatticeEquiv +Model +Models +PartialLoopChecking +Deciders +UnivLoopChecking UGraph0 Reflect MRProd @@ -13,6 +24,7 @@ PCUICPrimitive PCUICAst PCUICCases PCUICAstUtils +PCUICGlobalEnv PCUICReflect PCUICEquality PCUICTyping diff --git a/safechecker-plugin/theories/Extraction.v b/safechecker-plugin/theories/Extraction.v index 2598de60c..4f93ac3ef 100644 --- a/safechecker-plugin/theories/Extraction.v +++ b/safechecker-plugin/theories/Extraction.v @@ -13,7 +13,7 @@ From MetaRocq.SafeCheckerPlugin Require Import SafeTemplateChecker. (** Here we could extract uint63_from/to_model to the identity *) Extraction Blacklist Classes config uGraph Universes Ast String List Nat Int Init - UnivSubst Typing Checker Retyping OrderedType Logic Common Equality Classes + UnivSubst Typing Checker Retyping OrderedType Logic Common Common0 Equality Classes Uint63 Induction. Set Warnings "-extraction-opaque-accessed". Set Warnings "-extraction-reserved-identifier". From 696475fbf77fe02e0ad045272532dafd600528e2 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 6 Nov 2025 21:00:44 +0100 Subject: [PATCH 130/164] Fix quoting/denotation of universe instances. To fix when moving to rocq-next --- template-rocq/src/constr_denoter.ml | 9 +++++++-- template-rocq/src/constr_quoter.ml | 2 +- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/template-rocq/src/constr_denoter.ml b/template-rocq/src/constr_denoter.ml index 426f49984..c5ab1340b 100644 --- a/template-rocq/src/constr_denoter.ml +++ b/template-rocq/src/constr_denoter.ml @@ -281,7 +281,12 @@ struct let unquote_universe_instance evm trm (* of type universe_instance *) = let l = unquote_list trm in - let evm, l = map_evm unquote_level evm l in + let evm, l = map_evm unquote_universe evm l in + let l = List.map (fun u -> + match Univ.Universe.level u with + | Some l -> l + | None -> bad_term_verb trm "unquote_universe_instance_not_level") l + in evm, UVars.Instance.of_array ([||], Array.of_list l) let unquote_variance v = @@ -382,7 +387,7 @@ struct let inspect_term (t:Constr.t) : (Constr.t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, - quoted_inductive, quoted_relevance, quoted_univ_level, quoted_univ_instance, quoted_proj, + quoted_inductive, quoted_relevance, quoted_universe, quoted_univ_instance, quoted_proj, quoted_int63, quoted_float64, quoted_pstring) structure_of_term = (* debug (fun () -> Pp.(str "denote_term" ++ spc () ++ print_term t)) ; *) let (h,args) = app_full t [] in diff --git a/template-rocq/src/constr_quoter.ml b/template-rocq/src/constr_quoter.ml index 5f7b62f82..70049a7b0 100644 --- a/template-rocq/src/constr_quoter.ml +++ b/template-rocq/src/constr_quoter.ml @@ -241,7 +241,7 @@ struct CErrors.user_err Pp.(str "Quoting sort polymorphic instances not yet supported.") in (* we assume that valid instances do not contain [Prop] or [SProp] *) - to_coq_listl tlevel (CArray.map_to_list quote_level uarr) + to_coq_listl tuniverse (CArray.map_to_list quote_universe (Array.map Universe.make uarr)) let is_Lt = function | Univ.Lt -> true From c2e094f0e905b8638a3227899566d408a363e396 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 6 Nov 2025 21:39:44 +0100 Subject: [PATCH 131/164] Port erasure --- .vscode/metarocq.code-workspace | 28 ++++++++++++++++++++ erasure/theories/EEtaExpandedFix.v | 7 +++-- erasure/theories/EInduction.v | 6 ++--- erasure/theories/ErasureFunction.v | 5 ++-- erasure/theories/ErasureFunctionProperties.v | 2 +- erasure/theories/Typed/Certifying.v | 2 +- erasure/theories/Typed/OptimizeCorrectness.v | 10 ++++--- 7 files changed, 48 insertions(+), 12 deletions(-) diff --git a/.vscode/metarocq.code-workspace b/.vscode/metarocq.code-workspace index 4e21c057d..125b6ae7d 100644 --- a/.vscode/metarocq.code-workspace +++ b/.vscode/metarocq.code-workspace @@ -128,5 +128,33 @@ "coq-lsp.send_perf_data": false, "coq-lsp.admit_on_bad_qed": false, "coq-lsp.max_errors": 1, + "vsrocq.args": [ + + // "-bt", // get backtraces from Rocq on errors + "-Q", "utils/theories", "MetaRocq.Utils", + "-Q", "common/theories", "MetaRocq.Common", + "-Q", "template-rocq/theories", "MetaRocq.Template", + "-I", "template-rocq", + "-I", "template-rocq/src", + "-Q", "pcuic/theories", "MetaRocq.PCUIC", + "-I", "pcuic", + "-I", "pcuic/src", + "-Q", "template-pcuic/theories", "MetaRocq.TemplatePCUIC", + "-Q", "safechecker/theories", "MetaRocq.SafeChecker", + "-Q", "safechecker-plugin/theories", "MetaRocq.SafeCheckerPlugin", + "-I", "safechecker-plugin", + "-I", "safechecker-plugin/src", + "-Q", "erasure/theories", "MetaRocq.Erasure", + "-Q", "erasure-plugin/theories", "MetaRocq.ErasurePlugin", + "-I", "erasure-plugin", + "-I", "erasure-plugin/src", + "-Q", "translations", "MetaRocq.Translations", + "-Q", "quotation/theories", "MetaRocq.Quotation", + "-Q", "test-suite", "MetaRocq.TestSuite", + "-Q", "test-suite/plugin-demo/theories", "MetaRocq.ExtractedPluginDemo", + "-I", "test-suite/plugin-demo", + "-I", "test-suite/plugin-demo/src", + "-Q", "examples", "MetaRocq.Examples", + ], } } diff --git a/erasure/theories/EEtaExpandedFix.v b/erasure/theories/EEtaExpandedFix.v index fd827a4f2..85683286c 100644 --- a/erasure/theories/EEtaExpandedFix.v +++ b/erasure/theories/EEtaExpandedFix.v @@ -9,6 +9,9 @@ From MetaRocq.Erasure Require Import EInduction ELiftSubst ESpineView ECSubst EP Set Default Proof Using "Type*". Local Arguments eval : clear implicits. +Arguments Nat.leb : simpl never. +Arguments Nat.eqb : simpl never. +Arguments Nat.ltb : simpl never. Lemma eval_app_cong_tApp fl Σ t v args res : eval (switch_unguarded_fix fl) Σ t v -> @@ -380,8 +383,8 @@ Section isEtaExp. destruct v using rev_case; simp_eta. - destruct expanded_head_viewc; rewrite ? andb_true_r //. cbn. unfold isEtaExp_fixapp. now destruct (nth_error); cbn. cbn. - destruct (nth_error Γ n) as [m | ]; cbn; try reflexivity. - destruct (Nat.eqb_spec 0 m), (Nat.leb_spec m 0); try reflexivity; lia. + destruct (nth_error Γ n) as [m | ]; try reflexivity. + destruct (Nat.eqb_spec 0 m), (Nat.leb_spec m 0); try reflexivity; subst; cbn; lia. - rewrite isEtaExp_mkApps_nonnil //. Qed. diff --git a/erasure/theories/EInduction.v b/erasure/theories/EInduction.v index b537bb50e..0cf5ca4ca 100644 --- a/erasure/theories/EInduction.v +++ b/erasure/theories/EInduction.v @@ -248,7 +248,7 @@ Section MkApps_rec. (plazy : forall t, P t -> P (tLazy t)) (pforce : forall t, P t -> P (tForce t)). - Definition inspect {A} (x : A) : { y : A | x = y } := exist _ x eq_refl. + Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. Import EqNotations. @@ -260,7 +260,7 @@ Section MkApps_rec. | tLambda n1 t => plam n1 t (rec t) | tLetIn n2 t0 t1 => plet n2 t0 (rec t0) t1 (rec t1) | tApp t2 t3 with inspect (decompose_app (tApp t2 t3)) := - { | exist _ (t, l) da := + { | exist (t, l) da := let napp := decompose_app_notApp _ _ _ da in let nonnil := decompose_app_app _ _ _ _ da in let pt := rec t in @@ -326,7 +326,7 @@ Section MkApps_rec. | tLambda n1 t => plam n1 t | tLetIn n2 t0 t1 => plet n2 t0 t1 | tApp t2 t3 with inspect (decompose_app (tApp t2 t3)) := - { | exist _ (t, l) da := + { | exist (t, l) da := let napp := decompose_app_notApp _ _ _ da in let nonnil := decompose_app_app _ _ _ _ da in rew [P] (eq_sym (decompose_app_inv da)) in papp t l napp nonnil } diff --git a/erasure/theories/ErasureFunction.v b/erasure/theories/ErasureFunction.v index 64f7f0d86..23d588c38 100644 --- a/erasure/theories/ErasureFunction.v +++ b/erasure/theories/ErasureFunction.v @@ -1469,11 +1469,12 @@ Proof. Qed. From Stdlib Require Import Morphisms. -Global Instance proper_pair_levels_gcs : Proper ((=_lset) ==> GoodUnivConstraintSet.Equal ==> (=_gcs)) (@pair LevelSet.t GoodUnivConstraintSet.t). + +(* Global Instance proper_pair_levels_gcs : Proper ((=_lset) ==> GoodUnivConstraintSet.Equal ==> (=_gcs)) (@pair LevelSet.t GoodUnivConstraintSet.t). Proof. intros l l' eq gcs gcs' eq'. split; cbn; auto. -Qed. +Qed. *) (* TODO: Should this live elsewhere? *) Definition iter {A} (f : A -> A) : nat -> (A -> A) diff --git a/erasure/theories/ErasureFunctionProperties.v b/erasure/theories/ErasureFunctionProperties.v index 84ef59a5b..fc80783c6 100644 --- a/erasure/theories/ErasureFunctionProperties.v +++ b/erasure/theories/ErasureFunctionProperties.v @@ -2369,7 +2369,7 @@ Qed. Lemma incl_cs_refl cs : cs ⊂_cs cs. Proof using Type. - split; [lsets|csets]. + split; [lsets|ucsets]. Qed. Lemma weaken_prefix {decls Σ kn decl} : diff --git a/erasure/theories/Typed/Certifying.v b/erasure/theories/Typed/Certifying.v index c8a073665..6579b8779 100644 --- a/erasure/theories/Typed/Certifying.v +++ b/erasure/theories/Typed/Certifying.v @@ -131,7 +131,7 @@ Definition traverse_env (mpath : modpath) (suffix : string) (Σ1 Σ2 : global_de (Build_constant_body ty2 (Some body2) _ _ ) => new_body2 <- tmEval lazy (change_modpath mpath suffix (fun kn => KernameSet.mem kn affected) body2);; new_ty2 <-tmEval lazy (change_modpath mpath suffix (fun kn => KernameSet.mem kn affected) ty2);; - if @Checker.eq_term config.default_checker_flags init_graph body1 new_body2 then + if @Checker.eq_term config.default_checker_flags init_model body1 new_body2 then go affected Σtail dΣ2 else gen_prog new_ty2 new_body2 (mpath, get_def_name kn ++ suffix);; diff --git a/erasure/theories/Typed/OptimizeCorrectness.v b/erasure/theories/Typed/OptimizeCorrectness.v index 4e2989d0b..f182b26a6 100644 --- a/erasure/theories/Typed/OptimizeCorrectness.v +++ b/erasure/theories/Typed/OptimizeCorrectness.v @@ -4717,11 +4717,13 @@ Proof. unfold dearg_case_branch,dearg_branch_body;cbn. destruct (_ <=? _);cbn; reflexivity. ** subst ctx_mask;cbn in *;f_equal. - unfold complete_ctx_mask;cbn. - rewrite app_nil_r. + unfold complete_ctx_mask, dearg_case_branch, leb;cbn. + rewrite app_nil_r. simpl. rewrite masked_all_zeros. change (fold_left _ ?m (?i,?x)) with (dearg_branch_body_rec i m x). - now rewrite dearg_branch_body_rec_all_zeros. + unfold dearg_case_branch; cbn. unfold Nat.leb; cbn. f_equal. + unfold complete_ctx_mask. cbn. + now rewrite dearg_branch_body_rec_all_zeros. * unfold valid_case_masks in *. cbn in valid_brs_masks. remember (if #|get_branch_mask mm (inductive_ind ind) 0| <=? #|n| then masked ctx_mask n else n) as masked_n. replace (repeat tBox _) with (masked ctx_mask (repeat tBox #|n|)); cycle 1. @@ -4768,6 +4770,8 @@ Proof. *** apply is_expanded_substl;eauto with dearg. *** lia. ** subst mm. cbn -[dearg_branch_body_rec] in *. + unfold leb, complete_ctx_mask; cbn. + unfold leb, complete_ctx_mask; cbn. rewrite app_nil_r. rewrite dearg_branch_body_rec_all_zeros;cbn. subst ctx_mask. unfold complete_ctx_mask. From 14282269d4bd0a0de9a2cb4de0dd0220efe8e1c2 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 6 Nov 2025 21:45:26 +0100 Subject: [PATCH 132/164] Port erasure plugin --- erasure-plugin/Makefile.plugin.local | 2 ++ erasure-plugin/_PluginProject.in | 30 +++++++++++++++++-- .../src/metarocq_erasure_plugin.mlpack | 15 +++++++++- erasure-plugin/theories/Erasure.v | 4 +-- erasure-plugin/theories/Extraction.v | 2 +- 5 files changed, 46 insertions(+), 7 deletions(-) diff --git a/erasure-plugin/Makefile.plugin.local b/erasure-plugin/Makefile.plugin.local index ccecbd154..c399c0416 100644 --- a/erasure-plugin/Makefile.plugin.local +++ b/erasure-plugin/Makefile.plugin.local @@ -2,10 +2,12 @@ CAMLFLAGS :=-thread -bin-annot -strict-sequence -w -a+1..3-4+5..8-9+10..26-27+28 CAMLFLAGS+=-open Metarocq_template_plugin CAMLFLAGS+=-w -8 # Non-exhaustive matches due to translation of comparison to int CAMLFLAGS+=-w -20 # Unused arguments +CAMLFLAGS+=-w -26 # Unused variables CAMLFLAGS+=-w -33 # Unused opens CAMLFLAGS+=-w -32 # Unused values CAMLFLAGS+=-w -34 # Unused types CAMLFLAGS+=-w -39 # Unused rec flags +CAMLFLAGS+=-w -56 # Unreachable case CAMLFLAGS+=-w -60 # Unused module in functor CAMLPKGS+=-package rocq-metarocq-template-ocaml.plugin diff --git a/erasure-plugin/_PluginProject.in b/erasure-plugin/_PluginProject.in index 1317144e6..36b79d964 100644 --- a/erasure-plugin/_PluginProject.in +++ b/erasure-plugin/_PluginProject.in @@ -5,10 +5,32 @@ src/META.rocq-metarocq-erasure src/ssrbool.ml src/ssrbool.mli -src/uGraph0.ml +src/mRInstances.mli +src/mRInstances.ml + +# Universe checking algorithm +src/common1.mli +src/common1.ml +src/interfaces.mli +src/interfaces.ml +src/hornClauses.mli +src/hornClauses.ml +src/initialSemilattice.mli +src/initialSemilattice.ml +src/hornSemilatticeEquiv.mli +src/hornSemilatticeEquiv.ml +src/model.mli +src/model.ml +src/models.mli +src/models.ml +src/partialLoopChecking.mli +src/partialLoopChecking.ml +src/univLoopChecking.mli +src/univLoopChecking.ml +src/deciders.mli +src/deciders.ml src/uGraph0.mli -src/wGraph.ml -src/wGraph.mli +src/uGraph0.ml src/etaExpand.mli src/etaExpand.ml src/utils.mli @@ -32,6 +54,8 @@ src/pCUICPosition.mli src/pCUICPosition.ml src/pCUICNormal.mli src/pCUICNormal.ml +src/pCUICGlobalEnv.mli +src/pCUICGlobalEnv.ml src/templateToPCUIC.mli src/templateToPCUIC.ml src/pCUICExpandLets.mli diff --git a/erasure-plugin/src/metarocq_erasure_plugin.mlpack b/erasure-plugin/src/metarocq_erasure_plugin.mlpack index d1e01e410..23202db80 100644 --- a/erasure-plugin/src/metarocq_erasure_plugin.mlpack +++ b/erasure-plugin/src/metarocq_erasure_plugin.mlpack @@ -1,6 +1,7 @@ MSetWeakList EqdepFacts Ssrbool +MRInstances Fin Vector @@ -8,7 +9,18 @@ VectorDef Utils ResultMonad -WGraph + + +Common1 +Interfaces +HornClauses +InitialSemilattice +HornSemilatticeEquiv +Model +Models +PartialLoopChecking +Deciders +UnivLoopChecking UGraph0 EtaExpand @@ -27,6 +39,7 @@ PCUICEquality PCUICTyping PCUICInduction PCUICWfUniverses +PCUICGlobalEnv PCUICNormal PCUICPosition PCUICPretty diff --git a/erasure-plugin/theories/Erasure.v b/erasure-plugin/theories/Erasure.v index 17898a2b3..97b251f51 100644 --- a/erasure-plugin/theories/Erasure.v +++ b/erasure-plugin/theories/Erasure.v @@ -768,7 +768,7 @@ Qed. Next Obligation. unfold optional_unsafe_transforms. cbn. - destruct enable_unsafe as [[] ? ? ? ?]=> //. + destruct enable_unsafe as [[] ? ? ?]=> //. Qed. Local Obligation Tactic := intros; eauto. @@ -1099,7 +1099,7 @@ Program Definition run_erase_program {guard : abstract_guard_impl} econf := Next Obligation. Proof. unfold optional_unsafe_transforms; cbn. - destruct enable_unsafe as [[] ? ? ? ?]=> //. + destruct enable_unsafe as [[] ? ? ?]=> //. Qed. Program Definition erase_and_print_template_program econf (m : inductives_mapping) (p : Ast.Env.program) : string := diff --git a/erasure-plugin/theories/Extraction.v b/erasure-plugin/theories/Extraction.v index f06879501..69806c88e 100644 --- a/erasure-plugin/theories/Extraction.v +++ b/erasure-plugin/theories/Extraction.v @@ -9,7 +9,7 @@ From MetaRocq.Utils Require Import utils. *) Extraction Blacklist Classes config uGraph Universes Ast String List Nat Int - UnivSubst Typing Checker Retyping OrderedType Logic Common ws_cumul_pb Classes Numeral + UnivSubst Typing Checker Retyping OrderedType Logic Common Common0 ws_cumul_pb Classes Numeral Uint63 Induction. Set Warnings "-extraction-opaque-accessed". Set Warnings "-extraction-reserved-identifier". From a77295d60ca744a42df2ec4a78063e727ad88084 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 6 Nov 2025 21:49:20 +0100 Subject: [PATCH 133/164] Remove generated file --- template-rocq/src/g_template_rocq.ml | 360 --------------------------- 1 file changed, 360 deletions(-) delete mode 100644 template-rocq/src/g_template_rocq.ml diff --git a/template-rocq/src/g_template_rocq.ml b/template-rocq/src/g_template_rocq.ml deleted file mode 100644 index a9187abbd..000000000 --- a/template-rocq/src/g_template_rocq.ml +++ /dev/null @@ -1,360 +0,0 @@ -let _ = Mltop.add_known_module "rocq-metarocq-template-rocq.plugin" - -# 4 "src/g_template_rocq.mlg" - - -open Attributes -open Ltac_plugin -open Names - -(** Calling Ltac **) - -let ltac_lcall tac args = - let (location, name) = Loc.tag (Names.Id.of_string tac) - (* Loc.tag @@ Names.Id.of_string tac *) - in - CAst.make ?loc:location (Tacexpr.TacArg(Tacexpr.TacCall - (CAst.make (Locus.ArgVar (CAst.make ?loc:location name),args)))) - -open Tacexpr -open Tacinterp -open Stdarg -open Tacarg -open Redexpr - -(* If strict unquote universe mode is on then fail when unquoting a non *) -(* declared universe / an empty list of level expressions. *) -(* Otherwise, add it / a fresh level the global environnment. *) - -let _ = - let open Goptions in - declare_bool_option - { optdepr = None; - optstage = Interp; - optkey = ["MetaRocq"; "Strict"; "Unquote"; "Universe"; "Mode"]; - optread = (fun () -> !Denoter.strict_unquote_universe_mode); - optwrite = (fun b -> Denoter.strict_unquote_universe_mode := b) } - -let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) = - let fold arg (i, vars, lfun) = - let id = Names.Id.of_string ("x" ^ string_of_int i) in - let (l,n) = (Loc.tag id) in - let x = Reference (Locus.ArgVar (CAst.make ?loc:l n)) in - (succ i, x :: vars, Id.Map.add id arg lfun) - in - let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in - let lfun = Id.Map.add (Id.of_string "F") f lfun in - let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in - Tacinterp.eval_tactic_ist ist (ltac_lcall "F" args) - -let to_ltac_val c = Tacinterp.Value.of_constr c - -let run_template_program ~pm env evm ~poly pgm = - Run_template_monad.run_template_program_rec ~poly (fun ~st _ _ _ -> st) ~st:pm env (evm, pgm) - -let fresh_env () = - let env = Global.env () in - let sigma = Evd.from_env env in - env, sigma - -let to_constr_evars sigma c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c - - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Test_Quote" ~classifier:(fun _ -> Vernacextend.classify_as_query) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Test", - Vernacextend.TyTerminal - ("Quote", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))), - (let coqpp_body def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 67 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmTestQuote) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, - [|Constr.mkRel 0; to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun def ?loc ~atts () -> - coqpp_body def (Attributes.parse -# 66 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Quote", - Vernacextend.TyTerminal - ("Definition", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), - Vernacextend.TyTerminal - (":=", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))))), - (let coqpp_body name def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 77 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteDefinition) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; - to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun name def ?loc ~atts () -> - coqpp_body name def (Attributes.parse -# 76 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Definition_Eval" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Quote", - Vernacextend.TyTerminal - ("Definition", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), - Vernacextend.TyTerminal - (":=", - Vernacextend.TyTerminal - ("Eval", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_red_expr), - Vernacextend.TyTerminal - ("in", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil))))))))), - (let coqpp_body name rd def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 87 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - (* TODO : implem quoting of tactic reductions so that we can use ptmQuoteDefinitionRed *) - let (evm, rd) = Redexpr.interp_redexp_no_ltac env evm rd in - let (evm, def) = Plugin_core.reduce env evm rd (to_constr_evars evm def) in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteDefinition) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun name rd def ?loc ~atts () -> - coqpp_body name rd def (Attributes.parse -# 86 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Recursively_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Quote", - Vernacextend.TyTerminal - ("Recursively", - Vernacextend.TyTerminal - ("Definition", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), - Vernacextend.TyTerminal - (":=", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil))))))), - (let coqpp_body name def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 99 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteRecDefinition) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; - to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun name def ?loc ~atts () -> - coqpp_body name def (Attributes.parse -# 98 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Test_Unquote" ~classifier:(fun _ -> Vernacextend.classify_as_query) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Test", - Vernacextend.TyTerminal - ("Unquote", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))), - (let coqpp_body def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 109 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmTestUnquote) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, - [|to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun def ?loc ~atts () -> - coqpp_body def (Attributes.parse -# 108 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Make_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Unquote", - Vernacextend.TyTerminal - ("Definition", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), - Vernacextend.TyTerminal - (":=", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))))), - (let coqpp_body name def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 119 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmMkDefinition) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, - [|Constr_quoter.quote_ident name; - to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun name def ?loc ~atts () -> - coqpp_body name def (Attributes.parse -# 118 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Make_Inductive" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Unquote", - Vernacextend.TyTerminal - ("Inductive", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))), - (let coqpp_body def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 130 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmMkInductive) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, - [|Constr_quoter.quote_bool false; to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun def ?loc ~atts () -> - coqpp_body def (Attributes.parse -# 129 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Run_Template_Program" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Run", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil))), - (let coqpp_body def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 140 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (pgm, ctx) = Constrintern.interp_constr env evm def in - let evm = Evd.from_ctx ctx in - let pgm = EConstr.to_constr ~abort_on_undefined_evars:true evm pgm in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun def ?loc ~atts () -> - coqpp_body def (Attributes.parse -# 139 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_quote_term" ~level:0 - [(Tacentries.TyML (Tacentries.TyIdent ("quote_term", Tacentries.TyArg ( - Extend.TUentry (Genarg.get_arg_tag wit_constr), - Tacentries.TyArg ( - Extend.TUentry (Genarg.get_arg_tag wit_tactic), - Tacentries.TyNil))), - (fun c tac ist -> -# 152 "src/g_template_rocq.mlg" - (* quote the given term, pass the result to t *) - Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let c = to_constr_evars sigma c in - let c = Constr_quoter.quote_term env sigma c in - ltac_apply tac (List.map to_ltac_val [EConstr.of_constr c]) - end - )))] - -let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_denote_term" ~level:0 - [(Tacentries.TyML (Tacentries.TyIdent ("denote_term", Tacentries.TyArg ( - Extend.TUentry (Genarg.get_arg_tag wit_constr), - Tacentries.TyArg ( - Extend.TUentry (Genarg.get_arg_tag wit_tactic), - Tacentries.TyNil))), - (fun c tac ist -> -# 164 "src/g_template_rocq.mlg" - Proofview.Goal.enter (begin fun gl -> - let env = Proofview.Goal.env gl in - let evm = Proofview.Goal.sigma gl in - let evm, c = Constr_denoter.denote_term env evm (to_constr_evars evm c) in - let evm, _ = Typing.type_of env evm (EConstr.of_constr c) in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) - (ltac_apply tac (List.map to_ltac_val [EConstr.of_constr c])) - end) - )))] - -let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_run_template_program" ~level:0 - [(Tacentries.TyML (Tacentries.TyIdent ("run_template_program", - Tacentries.TyArg (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Tacentries.TyArg (Extend.TUentry (Genarg.get_arg_tag wit_tactic), - Tacentries.TyNil))), (fun c tac ist -> -# 176 "src/g_template_rocq.mlg" - let open Proofview.Notations in - Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (name, poly) -> - Proofview.Goal.enter (begin fun gl -> - let env = Proofview.Goal.env gl in - let evm = Proofview.Goal.sigma gl in - let ret = ref None in - (* We don't allow opening obligations / updating the vernacular inside proofs / as tactics *) - let pm = Declare.OblState.empty in - let _pm = Run_template_monad.run_template_program_rec - ~poly ~intactic:true ~st:pm (fun ~st env evm t -> ret := Some (env,evm,t); st) - env (evm, to_constr_evars evm c) - in - match !ret with - | Some (env, evm, t) -> - Proofview.tclTHEN - (Proofview.Unsafe.tclEVARS evm) - (ltac_apply tac (List.map to_ltac_val [EConstr.of_constr t])) - | None -> Proofview.tclUNIT () - end) - )))] - From df221275d81a40d5d0a69d928f2e62c6d64c50ea Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Thu, 6 Nov 2025 21:54:59 +0100 Subject: [PATCH 134/164] Remove old files --- common/theories/LoopChecking/Deciders.v | 62 +- common/theories/LoopChecking/ZModels.v | 315 --- template-rocq/theories/Junk.v | 2108 -------------- template-rocq/theories/LoopChecking.v | 3280 ---------------------- template-rocq/theories/LoopCheckingNat.v | 2823 ------------------- 5 files changed, 11 insertions(+), 8577 deletions(-) delete mode 100644 common/theories/LoopChecking/ZModels.v delete mode 100644 template-rocq/theories/Junk.v delete mode 100644 template-rocq/theories/LoopChecking.v delete mode 100644 template-rocq/theories/LoopCheckingNat.v diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index 8bf817b78..e8d4df31e 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -1812,26 +1812,12 @@ Module Abstract. Definition enables_clauses val cls := Clauses.For_all (enables_clause val) cls. Definition consistent_opt_val (val : Level.t -> option Z) (cls : Clauses.t) := - (* enables_clauses val cls /\ *) + clauses_sem val cls. Definition consistent_opt cls := exists val : Level.t -> option Z, consistent_opt_val val cls. - (* -Lemma opt_valuation_of_model_equiv m l : - option_get 0%Z (opt_valuation_of_model m l) = valuation_of_model m l. - Proof. - rewrite /opt_valuation_of_model /to_Z_val /to_val. - case: find_spec. - * move=> k hm. - destruct k => //. - have he := valuation_of_model_spec m l _ hm. - apply LevelMap.find_1 in he. rewrite he. todo "bounds". - apply LevelMap.find_1 in hm. cbn. todo "zero". - * move=> hnin. cbn. todo "zero". - Qed. *) - Lemma min_atom_value_mapsto {m le k} : min_atom_value m le = Some k -> LevelMap.MapsTo le.1 (Some (k + le.2)) m. Proof. @@ -2605,29 +2591,6 @@ Proof. move/entails_models=> vm. now apply vm. Qed. -(* - - move=> hv cl ha. rewrite entails_models => m' ism en. - red in hv. - apply h; tea. apply - - - intros; red; eauto. - now rewrite -checkb_entails check_entails_model. -Qed. *) - -Lemma check_entails_exists_model m cl : - check_entailsb (clauses m) cl -> exists m', [/\ is_model m' (clauses m), enabled_clause m' cl & valid_clause m' cl]. -Proof. - unfold check_entailsb. - funelim (check_entails (clauses m) cl) => // _. - clear H H0. symmetry in Heqcall. - move/check_entails_entails: Heqcall => ent. - exists v.(model_model). split. apply model_ok. todo "enabled". - eapply entails_model_valid; tea. - apply model_ok. -Qed. - - Lemma check_entails_neg_exists_model m cl : check_entailsb (clauses m) cl = false <-> exists m', [/\ is_model m' (clauses m), enabled_clause m' cl & ~ valid_clause m' cl]. @@ -2663,7 +2626,7 @@ Definition consistent_clauses cls := - clauses max (∞, ...) >= x are trivially valid. - clauses max ... >= ∞ are invalid. - This corresponds to the fact that validity checking does compute + This corresponds the fact that validity checking does compute all the "downward" consequences of its premises (say [x, y]), but will not consider unrelated max(v, x) expressions if [v] is not entailed by [x] or [y]. @@ -2817,21 +2780,18 @@ Definition valid_total_models cls cl := forall m : Model.model, is_total_model m cls -> defined_model_of (clause_levels cl) m -> valid_clause m cl. -Lemma valid_total_models_Z_models cls cl : valid_clause_Z cls cl <-> valid_total_models cls cl. +Lemma valid_total_models_Z_models cls cl : valid_clause_Z cls cl -> valid_total_models cls cl. Proof. - split. - - intros H m istot encl. - move: (H (Z_valuation_of_model m)) => /fwd. - eapply valuation_of_model_pos. - move=> /fwd. destruct istot. move/is_modelP: H1 => H1. - move=> cl' /[dup] /H0 en /H1. - now eapply valid_clause_model. - intros cs. - rewrite -def_clause_sem_valid //. - - intros vm v vpos csem. red in vm. todo "admit". + intros H m istot encl. + move: (H (Z_valuation_of_model m)) => /fwd. + eapply valuation_of_model_pos. + move=> /fwd. destruct istot. move/is_modelP: H1 => H1. + move=> cl' /[dup] /H0 en /H1. + now eapply valid_clause_model. + intros cs. + rewrite -def_clause_sem_valid //. Qed. - Instance incl_leset_preorder : PartialOrder LevelExprSet.Equal LevelExprSet.Subset. Proof. red. intros x y. split. diff --git a/common/theories/LoopChecking/ZModels.v b/common/theories/LoopChecking/ZModels.v deleted file mode 100644 index eede3f508..000000000 --- a/common/theories/LoopChecking/ZModels.v +++ /dev/null @@ -1,315 +0,0 @@ - - -Definition split_clauses m cls := - Clauses.partition (is_enabled_clause m) cls. - -Definition enabled_clauses_of m cls := (split_clauses m cls).1. -Definition disabled_clauses_of m cls := (split_clauses m cls).2. - -Lemma split_clauses_spec_1 m cls : - cls =_clset Clauses.union (enabled_clauses_of m cls) (disabled_clauses_of m cls). -Proof. Admitted. - -Lemma enabled_clauses_spec m cl cls : Clauses.In cl (enabled_clauses_of m cls) <-> Clauses.In cl cls /\ enabled_clause m cl. -Admitted. - -Lemma disabled_clauses_spec m cl cls : Clauses.In cl (disabled_clauses_of m cls) <-> Clauses.In cl cls /\ ~ enabled_clause m cl. -Admitted. - -Lemma nenabled_clause m cl : ~ enabled_clause m cl <-> min_premise m (premise cl) = None. -Proof. - case: (reflect_enabled m cl) => //. - split => //. red in p. firstorder. congruence. - firstorder. cbn in H. destruct min_premise => //. - destruct (H _ eq_refl). -Qed. - -Lemma is_model_split m cls : - is_model m cls <-> (is_total_model m (enabled_clauses_of m cls)). -Proof. - split. - - move/Clauses.for_all_spec => ism. - split. - intros cl. now rewrite enabled_clauses_spec. tc. - apply Clauses.for_all_spec. tc. - move=> cl /enabled_clauses_spec => -[] /ism //. - - move=> -[]. intros en. red in en. red in en. - intros ism. rewrite (split_clauses_spec_1 m cls). - eapply is_model_union. auto. - eapply Clauses.for_all_spec. tc. - move=> [prems [concl k]] /disabled_clauses_spec -[] hin hen. - Search enabled_clause. - apply valid_clause_intro. - now move/nenabled_clause: hen => ->. -Qed. - -Lemma enabled_clause_defined {m cl} : - enabled_clause m cl -> - defined_model_of (NES.levels (premise cl)) m. -Proof. - destruct cl as [prems [concl k]]; cbn. - move=> -[] z //= /min_premise_spec' hl. - move=> l /NES.levels_spec -[] k' /hl [v] [] hm _. - eapply level_value_MapsTo' in hm. now eexists. -Qed. - -Lemma check_clause_invalid_Z cls cl mcheck : - check_gen cls cl = Invalid mcheck -> ~ valid_clause_Z (enabled_clauses_of mcheck cls) cl. -Proof. - move/check_invalid => -[ism mof min en inv] nv. - destruct cl as [prems [concl k]]. - destruct (level_value mcheck concl) eqn:he. - * specialize (nv (Z_valuation_of_model mcheck)). - forward nv. apply valuation_of_model_pos. - forward nv. apply is_model_split in ism. - apply valid_clauses_model. apply ism. apply ism. - move: nv. - rewrite def_clause_sem_valid. - unfold defined_model_of. - intros l; rewrite clause_levels_spec //=. - intros [hin|eq]. - move/enabled_clause_defined: en. - now move/(_ _ hin). subst. - eapply level_value_MapsTo' in he. now eexists. - contradiction. - * apply is_model_split in ism. - destruct en as [minp eqmin]. - remember (interp_nes (Z_valuation_of_model mcheck) prems) as iprems eqn:hprems. - symmetry in hprems. - set val := fun l => - if l == concl then iprems + 1 - k - else Z_valuation_of_model mcheck l. - specialize (nv val). - forward nv. admit. - forward nv. admit. - move: nv; cbn. - rewrite {1}/val eqb_refl. - have eqi : interp_nes val prems = interp_nes (Z_valuation_of_model mcheck) prems. - move/min_premise_spec': eqmin => //=. - eapply interp_nes_elim. tc. - intros [le lek] h. rewrite /interp_expr. - rewrite interp_nes_singleton /interp_expr //=. - specialize (h le lek). admit. - intros. admit. - rewrite !eqi hprems. lia. -Admitted. - -Lemma contra A B : (A -> B) -> (~ B -> ~ A). -Proof. intros f nb a. exact (nb (f a)). Qed. - -Lemma invalid_clause_Z_ex cls cl : - (exists v : Level.t -> Z, positive_valuation v /\ clauses_sem v cls /\ ~ clause_sem v cl) -> - ~ valid_clause_Z cls cl. -Proof. - intros [v [vpos [cs ncsem]]]. - red. move/(_ v vpos cs). contradiction. -Qed. - -(* - Check for validity in Z: cls |= cl. - - Take an existing total model m of cls. - Add clauses low: v -> Set forall v. Ensure m[Set] = model_max m. - Add clauses high Set + 1 + (model_max - m[v]) -> v for every v, trivially - satisfied: as min_premise m [Set + 1 + (model_max m - m[v])] = - model_max m - (1 + (model_max m - model_min m)) = - 1 - model_min m <= m[v]. - - So m is also a total model of cls + low + high. - Launch checking for cls' ⊃ cls. - If we find a loop we get cls' |- loop, but as m is a total model of cls', that implies false in Z. - Otherwise we get a valid model [mcheck |= cls'] - and either valid_clause mcheck cl or ~ valid_clause mcheck cl. - - If valid_clause mcheck cl, then - mcheck |= cls as cls ⊂ cls'. - So we have a valid clause in Zinf and Z, but not a proof - for every valuation... - - E.g check x >= 0, y >= 0 -> x >= y. - adds 0 >= x and 0 >= y, forcing x = y = 0! - Add instead just 0 >= y, not better, it entails x >= y = 0. - Add instead just ⊥ + 1 >= y: starting from { x = 0; y = None; ⊥ = None }. - we get - { x = 0; y = None; ⊥ = 0 }, - { x = 0; y = -1; ⊥ = 0 }. Good, does not entail x >= y - But x + 1 >= y ? - { x = 1; y = None; ⊥ = None } -> - { x = 1; y = None; ⊥ = 1 } -> - { x = 1; y = 0; ⊥ = 1 }. - Ok as well. - - - If ~ valid_clause mcheck cl. - Then we have clauses_sem (Z_valuation_of_model mcheck) cls', - so clauses_sem (Z_valuation_of_model mcheck) cls, and - ~ clause_sem (Z_valuation_of_model mcheck) cl. -*) - -Definition bound_clauses (m : Model.model) := - LevelMap.fold (fun l k => - Clauses.add (singleton (Level.zero, model_max m + 1 - option_get 0 k), (l, 0))) m Clauses.empty. - -Lemma bound_clauses_spec {cl m} : - Clauses.In cl (bound_clauses m) -> - exists l k, LevelMap.MapsTo l k m /\ cl = (singleton (Level.zero, model_max m + 1 - option_get 0 k), (l, 0)). -Proof. - rewrite /bound_clauses. - set (mmax := model_max m). clearbody mmax. - eapply LevelMapFact.fold_rec. - - intros s' he hin. clsets. - - intros x a cls s' s'' hin hnin hadd ih. - rsets. destruct H. - * subst cl. exists x, a. split. - eapply levelmap_add_spec in hadd. rewrite hadd. - apply LevelMapFact.F.add_mapsto_iff. now left. reflexivity. - * eapply levelmap_add_spec in hadd. - specialize (ih H) as [l []]. exists l, x0. split => //. - rewrite hadd. - apply LevelMapFact.F.add_mapsto_iff. right; split => //. - intros ->. destruct H0. subst cl. - apply hnin; now eexists. - apply H0. apply H0. -Qed. -(* -Lemma bound_clauses_spec_inv {l k V} : - LevelSet.In l V -> - Clauses.In (singleton (Level.zero, k), (l, 0)) (bound_clauses k V). -Proof. - rewrite /bound_clauses. - eapply LevelSetProp.fold_rec. - - intros s' he hin. lsets. - - intros x a s' s'' hin hnin hadd ih. - rsets. apply hadd in H as [H|H]. - * subst l. now left. - * specialize (ih H). now right. -Qed. *) - -Lemma bound_clauses_prop m cls : - is_model m cls -> is_model m (bound_clauses m). -Proof. - intros ism. - apply is_modelP => cl /bound_clauses_spec -[] l [k] [] hm heq. - subst cl. - apply valid_clause_intro => z. - rewrite min_premise_singleton /min_atom_value. - destruct level_value eqn:hl => //=. - have hz : z0 = model_max m. todo "zero spec". - subst z0. - intros [=]. - have hzeq : z = - 1 + option_get 0 k. lia. - rewrite hzeq. - rewrite (level_value_MapsTo hm). destruct k. cbn in *; subst. - constructor. lia. - cbn in *. subst z. - todo "defined level". -Qed. - -Lemma bound_clauses_ext m m' : - m' ⩽ m -> is_model m (bound_clauses m) -> is_model m' (bound_clauses m). -Proof. - intros hext. -Abort. - - -Definition check_gen_Z (m : t) cl := - check_gen (Clauses.union (bound_clauses m) (clauses m)) cl. - -Lemma enabled_clause_mcheck_zero_enabled mcheck cl cls : - enabled_clause mcheck cl -> - is_model mcheck cls -> - Deciders.above_zero_declared (clauses_levels cls) cls -> - exists k, LevelMap.MapsTo Level.zero (Some k) mcheck. -Proof. -Admitted. - -Lemma enabled_clause_mcheck_all_enabled mcheck cl cls : - enabled_clause mcheck cl -> - is_model mcheck cls -> - Deciders.above_zero_declared (clauses_levels cls) cls -> - forall l, LevelMap.In l mcheck -> exists k, LevelMap.MapsTo l (Some k) mcheck. -Proof. -Admitted. - -Lemma option_map_add_zero k : option_map (Z.add 0) k = k. -Proof. destruct k => //. Qed. - -Lemma check_clause_invalid_Z_dis m cl : - clause_levels cl ⊂_lset levels m -> - check_gen_Z m cl = Valid -> valid_clause_Z (clauses m) cl. -Proof. - intros hwf. - unfold check_gen_Z. - set (bcls := bound_clauses _). - set (cls' := Clauses.union _ _). - move/check_gen_entails. - rewrite entails_completeness. - intros hm. eapply valid_total_models_Z_models. - intros m' tot def. - specialize (hm (option Z) _ (opt_valuation_of_model m')). - apply clause_sem_valid. apply hm. - eapply clauses_sem_union. - destruct tot as [en ism]. - split; revgoals. - eapply clauses_sem_valid; exact ism. revgoals. eauto. - have hmin : minimal_above (clauses m) (check_init_model (clauses m) cl) m. - admit. - red in hmin. - specialize (hmin m'). forward hmin. admit. - forward hmin. exact ism. - intros cl' hin. - eapply bound_clauses_spec in hin as [l [k [hm' heq]]]. - subst cl'. cbn -[Semilattice.eq]. rewrite interp_nes_singleton /interp_expr. - rewrite /opt_valuation_of_model. - case: (find_spec l m'). - intros k0 hml. destruct k0 => //. 2:{ todo "m' must have a value for l". } - case: (find_spec Level.zero m'). - intros kz hmz. destruct kz. 2:{ todo "zero must have a value". } - rewrite option_map_add_zero. - destruct k. - have hmax : z0 = model_max m'. admit. - subst z0. - have hv := valuation_of_value_pos hml. - cbn -[Semilattice.le]. cbn. - eapply hmin in hm' as [k' []]. - eapply LevelMapFact.F.MapsTo_fun in hml; tea. subst k'. depelim H0. - rewrite /valuation_of_value. - have hmleq : model_max m <= model_max m'. admit. - unfold valuation_of_value in hv. - have hv' := valuation_of_value_pos H0. - unfold valuation_of_value in hv'. - have hmeq : (model_max m' - model_max m' - model_min m') = - model_min m'. lia. - rewrite hmeq. lia. - cbn. - todo "scope". - todo "zero defined". - todo "zero defined". -Qed. - -Lemma check_clause_invalid_Z_dis m cl mcheck : - clause_levels cl ⊂_lset levels m -> - check_gen_Z m cl = Invalid mcheck -> ~ valid_clause_Z (clauses m) cl. -Proof. - intros hwf. - unfold check_gen_Z. - set (bcls := bound_clauses _ _). - set (cls' := Clauses.union _ _). - move/check_invalid => -[ism mof hmin en inval]. - apply invalid_clause_Z_ex. - exists (Z_valuation_of_model mcheck). - split. apply valuation_of_model_pos. - have hab := above_zero_declared m. - have hdef0 : defined_model_of (clauses_levels cls') mcheck. - { eapply enabled_clause_defined in en. - specialize (hab (choose (premise cl)).1). - forward hab. apply hwf. - eapply clause_levels_spec. left. - eapply NES.levels_spec. exists (choose (premise cl)).2. - destruct (choose _) eqn:hc. cbn. rewrite -hc. - eapply choose_spec. - red in hab. - } - split. - eapply valid_clauses_model. admit. - eapply is_model_subset; tea. subst cls'; clsets. - intros csem. - eapply def_clause_sem_valid in csem. contradiction. - eapply enabled_clause_defined in en. admit. -Qed. \ No newline at end of file diff --git a/template-rocq/theories/Junk.v b/template-rocq/theories/Junk.v deleted file mode 100644 index 2eb899e03..000000000 --- a/template-rocq/theories/Junk.v +++ /dev/null @@ -1,2108 +0,0 @@ -Definition has_lt V m m' := - (exists l k k', LevelSet.In l V /\ LevelMap.MapsTo l k m /\ LevelMap.MapsTo l k' m' /\ lt_value k k'). - -Lemma nlt_spec V m m' : ~ has_lt V m m' <-> forall l k k', LevelSet.In l V -> LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m' -> lt_value k k' -> False. -Proof. - split. - - intros nlt l k k' inv hm hm' lt. - apply nlt. red. exists l, k, k'; split => //. - - intros hl [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]. - apply (hl l0 k0 k0') => //. -Qed. - -(* Lemma nsmaller m m' : ~ is_smaller_model m m' <-> - exists l k k', LevelMap.MapsTo l k m /\ LevelMap.MapsTo l k' m' /\ lt_value k' k. -Proof. - split. - - intros hnsm. unfold is_smaller_model in hnsm. - eapply Decidable.not_and in hnsm. destruct hnsm. *) - - -Definition le_values V m m' := - forall l, LevelSet.In l V -> (level_value m l ≤ level_value m' l)%opt. - -Infix "≦[ V ]" := (le_values V) (at level 70, format "x ≦[ V ] y"). - -Lemma dec_le_values V m m' : Decidable.decidable (m ≦[V] m'). -Proof. -Admitted. - - -Lemma is_ext_le_value V m m' : - (m ⩽ m') -> le_values V m m'. -Proof. - move=> hext l. - destruct (@level_valueP m l). eapply hext in H as [k' [hm' le]]. - now rewrite (level_value_MapsTo hm'). - constructor. -Qed. - -Lemma le_opt_lt x y z : (lt_value x y)%opt -> (y ≤ z)%opt -> lt_value x z. -Proof. - destruct x, y, z; cbn; intros hle hle'; depelim hle'; lia. -Qed. - -Lemma nlt_opt_le x y : ~ (x ≤ y)%opt -> lt_value y x. -Proof. - destruct (check_atom_value x y) eqn:ca. - - move/check_atom_value_spec: ca. contradiction. - - destruct x, y; cbn in * => //. - intros hne. red in hne. cbn in hne. lia. -Qed. - -Definition lt_value (x y : option Z) := - match x, y with - | Some x, Some y => x < y - | None, Some _ => True - | Some _, None => False - | None, None => False - end. - -Definition is_ext m m' : bool := - LevelMapFact.for_all (fun l k => - match LevelMap.find l m' with - | None => false - | Some k' => check_atom_value k k' - end) m. - -(* Definition extends m m' := - (forall l k, LevelMap.MapsTo l k m -> exists k', LevelMap.MapsTo l k' m' /\ (k ≤ k')%opt). *) - -Lemma is_ext_spec m m' : is_ext m m' <-> m ⩽ m'. -Proof. - split. - - rewrite /is_ext. - rewrite [is_true _]LevelMapFact.for_all_iff => hf l k /hf. - case: (find_spec l m') => //. - move=> k0 hm /check_atom_value_spec hle. exists k0. split => //. - - intros ext. rewrite /is_ext. - rewrite [is_true _]LevelMapFact.for_all_iff => l e /ext. - intros [k' [hm hle]]. - rewrite (LevelMap.find_1 hm). - now apply/check_atom_value_spec. -Qed. - -Lemma dec_ext m m' : Decidable.decidable (m ⩽ m'). -Proof. - red. rewrite -is_ext_spec. now destruct is_ext. -Qed. - - - -Instance lt_irrefl : Irreflexive lt_value. -Proof. - intros []; cbn. red. unfold lt_value. unfold lt; cbn. lia. - now hnf. -Qed. - -Instance le_inter_refl : Reflexive le_inter. -Proof. - intros x l k k' m m'. eapply LevelMapFact.F.MapsTo_fun in m; tea. subst. reflexivity. -Qed. - -Instance le_values_refl V : Reflexive (le_values V). -Proof. - intros x l; reflexivity. -Qed. - -Instance le_inter_trans V : Transitive (le_values V). -Proof. - intros x y z h0 h1 l hin. transitivity (level_value y l). apply h0 => //. apply h1 => //. -Qed. - -Instance le_values_preorder V : PreOrder (le_values V). -Proof. - split; tc. -Qed. - -Definition eq_level_values V m m' := - forall l, LevelSet.In l V -> level_value m l = level_value m' l. - -Instance eq_level_values_equiv V : Equivalence (eq_level_values V). -Proof. - split. - - intros x l. reflexivity. - - move=> x y h l. now symmetry. - - move=> x y z h h' l. now transitivity (level_value y l). -Qed. - -Instance le_values_partial_order V : PartialOrder (eq_level_values V) (le_values V). -Proof. - intros m m'. - split. - - intros hm. cbn. split. intros l hin. now rewrite hm. - red. intros l hin; now rewrite hm. - - cbn; unfold flip => -[] le le'. - red. intros l hin. move: (le l hin) (le' l hin). - apply antisymmetry. -Qed. - -Definition is_smaller_model V (m m' : model) := - m ≦[V] m' /\ has_lt V m m'. - -(* Lemma le_values_inter V m m' : le_values V m m' -> le_inter m m'. -Proof. - intros hle l k k' hm hm'. - move: (hle l). - rewrite (level_value_MapsTo hm). - now rewrite (level_value_MapsTo hm'). -Qed. *) - -(* Instance model_rel_strictorder V : StrictOrder (is_smaller_model V). -Proof. - split. - - intros x. red. - unfold is_smaller_model. - move=> [eq hlt]. destruct hlt as [l [k [k' [hin [hm [hm' hlt]]]]]]. - eapply LevelMapFact.F.MapsTo_fun in hm; tea. subst. destruct k; cbn in hlt => //. lia. - - intros x y z [le [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]] [le' _]. - split. - * now transitivity y. - * red. exists l0, k0. apply le_values_inter in le. - specialize (le _ _ _ hin hm0 hm0'). - specialize (le' l0). - rewrite (level_value_MapsTo hm0') in le'. - move: le'. - case: (@level_valueP z l0). - intros k hm le'. exists k. split => //. split => //. split => //. eapply le_opt_lt; tea. - now eapply le'. - intros hnin lenon. specialize (lenon hin). - depelim lenon => //. auto. - now destruct k0 ; cbn in hlt'. -Qed. *) -(* -Definition is_smaller_model_dec V m m' : Decidable.decidable (is_smaller_model V m m'). -Proof. Admitted. - -Lemma eq_values_equal V m m' : LevelMap.Equal m m' -> eq_level_values V m m'. -Proof. - move=> eqv l; move: (eqv l). - rewrite /level_value. do 2 destruct LevelMap.find => //; congruence. -Qed. - -Lemma eq_level_values_inter {V m m'} : eq_level_values V m m' -> - forall l k k', LevelSet.In l V -> LevelMap.MapsTo l k m -> LevelMap.MapsTo l k' m' -> (k = k')%opt. -Proof. - intros eq l k k' hin hm hm'. - specialize (eq l). move: eq. - rewrite (level_value_MapsTo hm) (level_value_MapsTo hm'). intros ->. reflexivity. auto. -Qed. -Print is_smaller_model. -Lemma nis_smaller_spec V m m' : ~ (is_smaller_model V m m') <-> ~ (m ≦[V] m') \/ ~ has_lt V m m'. -Proof. - rewrite /is_smaller_model. - split. - - move/Decidable.not_and => /fwd. apply dec_le_values. auto. - - intros [] []. now apply H. now apply H. -Qed. - -Lemma le_lt_model V m m' : m ≦[V] m' -> ~ (is_smaller_model V m' m). -Proof. - intros le [lt li]. - eapply antisymmetry in le; tea. - move: li. change (~ has_lt V m' m). rewrite nlt_spec. - intros. - eapply eq_level_values_inter in le; tea. subst k'. - now eapply irreflexivity in H2. -Qed. - -Lemma le_inter_has_lt V m m' : le_inter m m' <-> ~ has_lt V m' m. -Proof. - split. - - intros hinter [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]. - specialize (hinter _ _ _ hm0' hm0). - eapply le_opt_lt in hlt'; tea. - now eapply irreflexivity in hlt'. - - move/nlt_spec => hlt l k k' hm hm'. - destruct (check_atom_value_spec k k') => //. exfalso. - apply (hlt l k' k hin) => //. - now apply nlt_opt_le in H. -Qed. - -Lemma nle_inter_has_lt V m m' : ~ le_inter V m m' <-> has_lt V m' m. -Proof. - split. - - intros nle. rewrite le_inter_has_lt in nle. todo "decidability". - - rewrite le_inter_has_lt. auto. -Qed. - -Lemma le_values_has_lt V m m' : le_values V m m' -> ~ has_lt V m' m. -Proof. - intros hinter [l0 [k0 [k0' [hin [hm0 [hm0' hlt']]]]]]. - eapply le_values_inter in hinter. - specialize (hinter _ _ _ hin hm0' hm0). - eapply le_opt_lt in hlt'; tea. - now eapply irreflexivity in hlt'. -Qed. *) - -(* Lemma le_values_inter_inv V m m' : model_of V m -> le_inter V m m' -> m ≦[V] m'. -Proof. - intros mof hle l hin. - specialize (mof l hin). - specialize (hle l hin). - move: hle. - destruct (@level_valueP m l) => //. - intros hle. intros h h'. eapply LevelMapFact.F.MapsTo_fun in H; tea. subst k. - depelim hle. - eapply level_value_MapsTo' in H0. - eapply LevelMapFact.F.MapsTo_fun in H0; tea. subst k'. - now constructor. - constructor. -Qed. *) - -(* -- move/nlt_spec => hlt l. k k' hm hm'. - destruct (check_atom_value_spec k k') => //. exfalso. - apply (hlt l k' k). split => //. split => //. - now apply nlt_opt_le in H. -Qed. *) -(* -Lemma contra A B : Decidable.decidable B -> (A -> ~ B) -> (~ A -> B). -Proof. - intros dec f na. - destruct dec. exact H. *) - -Lemma nle_values_has_lt V m m' : - ~ LevelSet.Empty V -> - model_of V m -> ~ le_values V m m' -> has_lt V m' m. -Proof. - intros hne le. -Admitted. - -(* -Lemma nle_ m m' : ~ m ⩽ m' <-> (LevelMap.Empty m' /\ ~ LevelMap.Empty m) \/ - has_lt m m'. -Proof. - move: m'. apply: LevelMapFact.map_induction. - - intros m' he. split. - intros hne. left; split => //. intros he'. apply hne. - have eq : m =m m'. - { rewrite LevelMapFact.F.Equal_mapsto_iff. firstorder. } - rewrite eq. reflexivity. - intros [[hem hem']|lt]. - * intros le. now apply hem' => l k /le -[k' []] /hem. - * intros hle. destruct lt as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. - now eapply he in hm0'. - - move=> m0 m1 nle l k nin hadd. split. - * intros nle'. right. red. - specialize (hle _ _ hm0) as [k' [hin']]. - eapply LevelMapFact.F.MapsTo_fun in hm0'; tea. subst k0'. *) - -Instance le_values_proper V : Proper (LevelMap.Equal ==> LevelMap.Equal ==> iff) (le_values V). -Proof. - intros ?? h ?? h'; rewrite /le_values //=. - now setoid_rewrite h; setoid_rewrite h'. -Qed. -(* -Lemma nle_lt_model m m' : m ≦ m' <-> ~ has_lt m' m. -Proof. - split. - - intros hm' hlt. - destruct hlt as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. - eapply le_values_inter in hm'. - specialize (hm' l0 _ _ hm0' hm0). - have h := le_opt_lt _ _ _ hlt' hm'. now apply irreflexivity in h. - - intros nlt l. rewrite -le_inter_has_lt in nlt. - red in nlt. - - Search has_lt. -*) -(* - move: m m'. apply: LevelMapFact.map_induction. - - intros m he m'. split. - intros hne. elim hne. intros l. - destruct (@level_valueP m l). now eapply he in H. constructor. - unfold has_lt. intros [l [k [k' [hm [hm' _]]]]]. - now eapply he in hm'. - - intros m m0 h x k hnin hadd m'. - apply levelmap_add_spec in hadd. - rewrite /has_lt. - split. - intros hle. setoid_rewrite hadd in hle. - destruct () - - - left; split => //. intros he'. apply hne. - have eq : m =m m'. - { rewrite LevelMapFact.F.Equal_mapsto_iff. firstorder. } - rewrite eq. reflexivity. - intros [[hem hem']|lt]. - * intros le. now apply hem' => l k /le -[k' []] /hem. - * intros hle. destruct lt as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. - now eapply he in hm0'. - - move=> m0 m1 nle l k nin hadd. split. - * intros nle'. right. red. - specialize (hle _ _ hm0) as [k' [hin']]. - - - intros nle. - destruct (dec_le_values m' m). split => //. - eapply nle_values_has_lt. in H. - apply nle_inter_has_lt. - intros lei. apply nle. - red in H, lei. intros l. specialize (H l). - destruct (@level_valueP m l). - destruct (@level_valueP m' l). - specialize (lei _ _ _ H0 H1). auto. - - Search le_inter. - eapply is_ext_le_inter in H. - eapply antisymmetry in H;. - - - destruct (is_smaller_model_dec m' m) => //. - [lt li]. - have eq : m =m m'. - now apply antisymmetry. - setoid_rewrite eq in li. - destruct li as [l0 [k0 [k0' [hm0 [hm0' hlt']]]]]. - eapply LevelMapFact.F.MapsTo_fun in hm0; tea. subst. - now apply irreflexivity in hlt'. -Qed. *) - - -(* -Lemma minimal_unique cls m m' : - minimal cls m -> is_model cls m -> minimal cls m' -> is_model cls m' -> (normalize_model m) ⩽ (normalize_model m'). -Proof. - intros min ism. - rewrite minimal_forall in min. - intros min' ism'. - rewrite minimal_forall in min'. - specialize (min _ ism'). - specialize (min' _ ism). - destruct (is_smaller_model_dec (normalize_model m) (normalize_model m')). apply H. - assert (sirr := irreflexivity (R := is_smaller_model) (normalize_model m)). - - destruct (dec_ext (normalize_model m) (normalize_model m')) => //. -Qed. *) -Print has_lt. -Lemma nle_values V m m' : - ~ LevelSet.Empty V -> - model_of V m -> - ~ (le_values V m m') -> - exists l, LevelSet.In l V /\ lt_value (level_value m' l) (level_value m l). -Proof. - intros hne mof leq. - have := (nle_values_has_lt V m m' hne mof leq). - intros [l [k [k' []]]]. destruct H0 as [? []]. - exists l; split => //. - now rewrite (level_value_MapsTo H0) (level_value_MapsTo H1). -Qed. - -(* Lemma minimal_le cls m m' : - minimal cls m -> is_model cls m' -> model_of (clauses_levels cls) m' -> - model_of (clauses_levels cls) m -> - is_smaller_model (clauses_levels cls) (normalize_model m) (normalize_model m'). -Proof. - intros nex ism mof mof'. - rewrite minimal_forall in nex. - specialize (nex _ ism). - destruct (is_smaller_model_dec (clauses_levels cls) (normalize_model m) (normalize_model m')) => //. -Abort. *) - - - -(* Lemma minimal_forall cls cls' m : minimal cls cls' m <-> - forall m', is_model cls m' -> is_smaller_model (clauses_levels cls) (normalize_model m') (normalize_model m) -> False. -Proof. - split. - - intros hmin m' ism issm. apply hmin. exists m'. split => //. - - intros hm' [m' [issm ism]]. apply (hm' m' ism issm). -Qed. *) - -(* Lemma minimal_mapsto cls m m' : - minimal cls cls' m -> is_model cls m' -> is_smaller_model (clauses_levels cls) (normalize_model m') (normalize_model m) -> False. -Proof. - intros nex ism. - rewrite minimal_forall in nex. - now specialize (nex _ ism). -Qed. *) - -(* Lemma minimal_model_unique cls minit m m' : - minimal_above minit cls m -> minimal_above minit cls m' -> is_model cls m -> is_model cls m' -> - normalize_model m =m normalize_model m'. -Abort. *) - - - -#[program] -Definition of_level_map_n (m : LevelMap.t nat) V n (hne : ~ LevelMap.Empty m) : nonEmptyLevelExprSet := - {| t_set := LevelMap.fold (fun l k acc => - if LevelSet.mem l V then LevelExprSet.add (l, n + k) acc else - LevelExprSet.add (l, k) acc) m LevelExprSet.empty |}. -Next Obligation. Admitted. - -Lemma of_level_map_n_spec m V hne : - forall l n k, LevelExprSet.In (l, k) (of_level_map_n m V n hne) -> - (exists k', LevelMap.MapsTo l k' m /\ - (LevelSet.In l V -> k = n + k') /\ - (~ LevelSet.In l V -> k = k')). -Proof. -Admitted. - -Lemma of_level_map_n_spec_inv m V hne : - forall l n k, LevelMap.MapsTo l k m -> - exists k', LevelExprSet.In (l, k') (of_level_map_n m V n hne) /\ - (LevelSet.In l V -> k' = n + k) /\ - (~ LevelSet.In l V -> k' = k). -Proof. -Admitted. - - -Lemma of_level_map_of_level_map_n m V ne : - of_level_map m ne = of_level_map_n m V 0 ne. -Proof. - apply eq_univ'. - intros [l k]. - rewrite of_level_map_spec. - firstorder. - - unshelve eapply (of_level_map_n_spec_inv _ V ne _ 0) in H. - destruct H as [k' [hin [inv ninv]]]. - destruct (inLevelSet V l) as [hvin|hnin]. - specialize (inv hvin). cbn in inv. now subst k'. - specialize (ninv hnin). cbn in ninv. now subst. - - eapply of_level_map_n_spec in H as [k' [hm [hin hnin]]]. - destruct (inLevelSet V l) as [hvin|hvnin]. - now rewrite (hin hvin). - now rewrite (hnin hvnin). -Qed. - -Lemma of_level_map_n_only_model m V n ne : - - only_model_of V m -> - of_level_map_n m V n ne = add_prems n (of_level_map m ne). -Proof. - intros om. - apply eq_univ'. - intros [l k]. - rewrite In_add_prems. - split. - - move/of_level_map_n_spec => [k' [hm [hin hnin]]]. - destruct (inLevelSet V l) as [hvin|hvnin]. - * rewrite (hin hvin). exists (l, k'). - rewrite of_level_map_spec. split => //. rewrite /add_expr. lia_f_equal. - * elim hvnin. apply om. now exists k'. - - intros [[? ?] [hin heq]]. unfold add_expr in heq; noconf heq. - unshelve eapply of_level_map_spec in hin. - have inv : LevelSet.In l V. - { apply om. now exists n0. } - eapply (of_level_map_n_spec_inv _ V ne _ n) in hin as [k' [hin [hinv hninv]]]. - specialize (hinv inv). subst k'. now rewrite Nat.add_comm. -Qed. - - -(* Lemma entails_any V cls m nem m' nem' : - only_model_of V m -> - cls ⊢a of_level_map m nem → of_level_map m' nem' -> - model_rel_partial Nat.lt V m m' -> - cls ⊢a of_level_map m nem → of_level_map_n m V 1 nem. -Proof. - intros tot cla mp [l k]. - move/of_level_map_n_spec. - intros [k' [hm [hin hnin]]]. - destruct (LevelSetDecide.MSetDecideAuxiliary.dec_In l V). - rewrite (hin H). - rewrite -[1 + _]Nat.add_1_r. - eapply entails_any_one; tea. - rewrite (hnin H). - constructor. now rewrite of_level_map_spec. -Qed. *) - -(* Lemma entails_any V cls m nem m' nem' : - model_of V m -> - model_rel_partial Z.lt V m m' -> - cls ⊢a of_level_map_n m V 1 nem → of_level_map_n m V 2 nem. -Proof. *) - - -(* Lemma entails_concls cls V n m hne hne' : - model_of V m -> - entails_all cls (of_level_map_n m V n hne) (of_level_set V n hne'). -Proof. - move=> tot [l k]. - rewrite levelexprset_of_levels_spec => [] [] hin ->. - specialize (tot _ hin) as [k' hm]. - move/of_level_map_n_spec_inv in hm. - specialize (hm V hne n) as [k'' [hm [hin' hnin]]]. - specialize (hin' hin). subst k''. cbn in *. - exists - depind ent. - - move: H. - rewrite of_level_map_n_spec => [] [k' [mt [hin hnin]]]. - destruct (inLevelSet V l) as [H|H]. - * now left. - * right. apply hnin in H. now subst k'. - - specialize (IHent _ _ _ en l). - - intros [] *) - -(* -Lemma strictly_updates_restrict cls V m m' : - strictly_updates cls V m m' -> - (forall cl, Clauses.In cl (cls_diff cls V) -> valid_clause m cl) -> - strictly_updates (cls ⇂ V) V m m'. -Proof. - induction 1. - - intros hcl. constructor; auto. - move: {hcl} (hcl cl). - rewrite Clauses.diff_spec in_clauses_with_concl in_restrict_clauses. - destruct cl as [prems [concl k]]; cbn. - move=> h. split => //. eapply in_singleton. - forward h. - { split. split => //. apply in_singleton. - intros [insing hle incl']. - assert (~ LevelSet.Empty (levels prems)). admit. - have eqc : (forall l, LevelSet.In l (levels prems) -> l = concl). - { move=> l /hle. now rewrite LevelSet.singleton_spec. } - move: H0; rewrite /valid_clause //=. - intros [v [hmin hlt la eqm]]. - destruct min_premise eqn:hm => //. - have [minple [minprem [inprems eqm]]] := min_premise_spec m prems. - - - assert (LevelSet.Equal (levels prems) (LevelSet.singleton concl)). split => //. lsets. - rewrite LevelSet.singleton_spec => ->. destruct (LevelSet.choose (levels prems)) eqn:hc. - apply LevelSet.choose_spec1 in hc. apply hle in hc. apply LevelSet.singleton_spec in hc; red in hc; subst. - -*) - -(* -Lemma strictly_updates_entails_loop_relax cls V mzero hne m : - let bound := v_minus_w_bound V m in - let maxgain := max_gain cls in - let n := Z.to_nat bound + maxgain in - model_of V mzero -> - strictly_updates cls V mzero m -> - entails_all cls (of_level_map_n mzero V n hne) (of_level_map_n mzero V (n + 1) hne). -Proof. - move=> bound maxgain n tot su. - have mp := strictly_updates_model_lt su tot. - have nem := strictly_updates_non_empty_map su. - eapply (strictly_updates_entails hne nem) in su; tea. - eapply entails_any in su; tea. - eapply (entails_all_shift n) in su. - rewrite -of_level_map_of_level_map_n. -Qed. -*) -(* Lemma of_level_map_n_split m V n hne : of_level_map_n m V n hne = of_level_set V n hne' *) -Lemma max_premise_model_unique cls m : max_premise_model cls clauses_levels m -> m = max_premise_map cls. -Proof. -Admitted. - - -(* -Lemma strictly_updates_entails_loop_relax' ocls cls V (hne : ~ LevelSet.Empty V) mzero m : - above_max_premise_model ocls mzero -> - cls ⊂_clset ocls -> - V =_lset clauses_levels cls -> - model_of V mzero -> - strictly_updates cls V mzero m -> - entails_all cls (of_level_set V (max_clause_premise cls) hne) - (of_level_set V (max_clause_premise cls + 1) hne). -Proof. - move=> habove hincl hv tot su. - eapply strictly_updates_entails_loop_relax; tea. *) - - - -(* -Lemma above_max_premise_model_strengthen {cls cls' m} : - cls ⊂_clset cls' -> - above_max_premise_model cls m -> - above_max_premise_model cls' m. -Proof. - intros hincl [[V' su]|eq]. - left. 2:{ subst. red. } exists V'. - eapply strictly_updates_weaken; tea. red in ha. - move/(hmon _ _ hincl)/(ha l) => ha'. - eapply infer_atom_downward; tea. - apply max_clause_premise_mon in hincl. lia. -Qed. *) -Lemma model_max_max_premise_map cls : (model_max (max_premise_map cls)) = max_clause_premise cls. -Proof. -Admitted. - - - -Definition new_model m V newk : model := - LevelMap.fold (fun l k acc => - let k' := if LevelSet.mem l V then newk else k in - LevelMap.add l k' acc) m (LevelMap.empty _). - -Lemma new_model_spec m V newk l k : - LevelMap.MapsTo l k (new_model m V newk) -> - (exists k', LevelMap.MapsTo l k' m /\ - if LevelSet.mem l V then k = newk else k = k'). -Proof. Admitted. - -Definition domain (l : LevelMap.t (option Z)) : LevelSet.t := - LevelSetProp.of_list (List.map fst (LevelMap.elements l)). - - -(* (forall cl', Clauses.In cl cls -> forall l k, LevelExprSet.In (l, k) (premise cl') -> k <= n) *) -Lemma strictly_updates_entails_loop_max cls V (hne : ~ LevelSet.Empty V) m : - V =_lset clauses_levels cls -> - strictly_updates cls V (max_premise_map cls) m -> - entails_all cls (of_level_set V ((model_max (max_premise_map cls))) hne) - (of_level_set V ((model_max (max_premise_map cls)) + 1) hne). -Proof. - intros. - rewrite !model_max_max_premise_map. - eapply strictly_updates_entails_loop; tea. - eapply max_premise_model_exists. - apply todo. -Qed. - - -Definition find_max (ls : LevelExprSet.t) (l : Level.t) := - LevelExprSet.fold (fun '(l', k) acc => if eqb l l' then opt_max (Some k) acc else acc) ls None. - -Inductive find_max_spec ls l : option nat -> Prop := -| find_max_ex m : LevelExprSet.In (l, m) ls -> (forall k, LevelExprSet.In (l, k) ls -> k <= m) -> find_max_spec ls l (Some m) -| find_max_absent : ~ (exists k, LevelExprSet.In (l, k) ls) -> find_max_spec ls l None. - -Lemma find_max_correct ls l : find_max_spec ls l (find_max ls l). -Proof. - unfold find_max. - apply: (LevelExprSetProp.fold_rec (P := fun ls a => find_max_spec ls l a)). - - intros s' ise; constructor. intros [k hin]. now apply ise in hin. - - intros x a s' s'' hin hnotin hadd hspec. - destruct x as [l' k]. - destruct (eqb_spec l l'); subst. - * depelim hspec. - { constructor. destruct (Nat.max_spec k m) as [[hle hm]|[hle hm]]. - + rewrite hm. apply hadd; right; apply H. - + rewrite hm. apply hadd; left; reflexivity. - + intros k' hin'. apply hadd in hin' as []. - { noconf H1. lia. } - { specialize (H0 _ H1). lia. } } - { constructor. apply hadd; now left. - intros k0 hin'. apply hadd in hin' as []. - { noconf H0; reflexivity. } - { elim H. now exists k0. } } - * depelim hspec; constructor; eauto. - + apply hadd; now right. - + intros k' hin'. apply hadd in hin' as []. - { noconf H2. congruence. } - now apply H0 in H2. - + intros [k0 hk0]. apply hadd in hk0 as []. - { noconf H1; congruence. } - apply H. now exists k0. -Qed. - - -(* Lemma valuation_of_model_pos l k model : LevelMap.MapsTo l (Z.to_nat k) (valuation_of_model model) -> (k >= 0)%Z. -Proof. - unfold valuation_of_model. - revert l k. - eapply LevelMapFact.fold_rec. - - intros. now rewrite LevelMapFact.F.empty_mapsto_iff in H0. - - intros l0 k0 e m' m'' me nk hadd hind l k. - rewrite LevelMapFact.F.add_mapsto_iff. - intros []. - * destruct H. red in H; subst. - destruct k0. - { have hmax := (model_max_spec model l (Some z) me). depelim hmax. - have hmin := (model_min_spec model l (Some z) me). depelim hmin. - assert (0 <= model_max model)%Z. admit. - assert (model_min model <= 0)%Z. admit. - assert (model_max model - option_get 0%Z (Some z) - model_min model = k)%Z. admit. - cbn in H4. - lia. *) - - - - -Definition model_above cls m := forall l, - LevelSet.In l (clauses_levels cls) -> - exists k', LevelMap.MapsTo l k' m /\ max_clause_premise cls <= k'. - -Lemma model_above_infers {cls m} : - model_above cls m -> - (forall l, LevelSet.In l (clauses_levels cls) -> infers_atom m l (max_clause_premise cls)). -Proof. -Admitted. - -Lemma model_above_update {cls V' m m'} : - model_above cls m -> - strictly_updates cls V' m m' -> - model_above cls m'. -Proof. - move=> above /strictly_updates_ext. - move=> le l /above => [] [] k' [] hm hle. - apply le in hm as [k'' [hin' le']]. - exists k''. split => //. now transitivity k'. -Qed. - -Lemma max_premise_model_above cls m : max_premise_model cls clauses_levels m -> model_above cls m. -Admitted. - - -(* Lemma max_premise_model_above cls sel sel' m : - (sel' cls ⊂_lset sel cls) -> - max_premise_model cls sel m -> - above_max_premise_model cls m. -Proof. - move=> incl mp l hl; move: (proj1 mp l (incl _ hl)); rewrite /infers_atom. - move/level_value_MapsTo => ->. reflexivity. -Qed. *) - - - -Definition add_max l k m := - match LevelMap.find l m with - | Some k' => - if (k' LevelMap.add l k m - end. - -Definition min_model_map (m : model) cls : model := - Clauses.fold (fun '(cl, concl) acc => - LevelExprSet.fold (fun '(l, k) acc => - add_max l k acc) cl (add_max (levelexpr_level concl) 0 acc)) cls m. - -Lemma In_add_max l l' k acc : - LevelMap.In (elt:=nat) l (add_max l' k acc) <-> - (l = l' \/ LevelMap.In l acc). -Proof. - unfold add_max. - destruct LevelMap.find eqn:hl. - - case: Nat.ltb_spec. - + rewrite LevelMapFact.F.add_in_iff /Level.eq. - firstorder eauto. - + intros. intuition auto. subst. - now rewrite LevelMapFact.F.in_find_iff hl. - - LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. -Qed. - -Definition is_max k' k l acc := - match LevelMap.find l acc with - | Some k'' => k' = Nat.max k k'' - | _ => k' = k - end. - - -Definition min_model_map (m : model) cls : model := - Clauses.fold (fun '(cl, concl) acc => - LevelExprSet.fold (fun '(l, k) acc => - add_max l k acc) cl (add_max (levelexpr_level concl) 0 acc)) cls m. - -Lemma MapsTo_add_max l l' k k' acc : - LevelMap.MapsTo (elt:=nat) l k' (add_max l' k acc) <-> - if eqb l l' then is_max k' k l acc else LevelMap.MapsTo l k' acc. -Proof. - unfold add_max. - destruct LevelMap.find eqn:hl. - { case: Nat.ltb_spec. - - rewrite LevelMapFact.F.add_mapsto_iff /Level.eq. - destruct (eqb_spec l l'). - { unfold is_max. - firstorder eauto. subst k' l'. rewrite hl. f_equal. lia. congruence. subst l'. - rewrite hl in H0. subst k'. - left. split; auto. f_equal; lia. } - intros. firstorder eauto. congruence. - - intros. unfold is_max. - destruct (eqb_spec l l'); subst. rewrite hl. firstorder eauto. apply LevelMap.find_1 in H. rewrite hl in H. noconf H. - f_equal; lia. subst k'. apply LevelMap.find_2. rewrite hl. f_equal. f_equal. lia. reflexivity. - } - - rewrite LevelMapFact.F.add_mapsto_iff. intuition auto; subst. - destruct (eqb_spec l l'); subst. unfold is_max. now rewrite hl. congruence. - destruct (eqb_spec l l'); subst. unfold is_max. now rewrite hl. congruence. - destruct (eqb_spec l l'); subst. unfold is_max in H; rewrite hl in H. subst k'. left; intuition eauto. reflexivity. - right. intuition eauto. -Qed. - -Lemma In_fold_add_max k n a : - LevelMap.In (elt:=nat) k - (LevelExprSet.fold - (fun '(l, k0) acc => add_max l k0 acc) n a) <-> - (LevelSet.In k (levels n)) \/ LevelMap.In k a. -Proof. - eapply LevelExprSetProp.fold_rec. - - intros s' he. - rewrite (LevelExprSetProp.empty_is_empty_1 he). - cbn. unfold levels. rewrite LevelExprSetProp.fold_empty. rewrite LevelSetFact.empty_iff. intuition auto. - - intros. - destruct x as [l k']. - rewrite In_add_max. - rewrite H2 !levelexprset_levels_spec. - split. - * intros []; subst. - left. exists k'. apply H1. now left. - destruct H3 as [[k'' ?]|?]. left; exists k''. apply H1. now right. - now right. - * red in H1. setoid_rewrite H1. - intros [[k'' []]|]. noconf H3. now left. - right. now left; exists k''. right; right. apply H3. -Qed. - -Lemma MapsTo_fold_add_max l n a : - let map := LevelExprSet.fold (fun '(l, k0) acc => add_max l k0 acc) n a in - (forall k, LevelMap.MapsTo (elt:=nat) l k map -> - ((exists kl, LevelExprSet.In (l, kl) n /\ kl = k /\ - (forall kl', LevelExprSet.In (l, kl') n -> kl' <= kl) /\ - (forall kl', LevelMap.MapsTo l kl' a -> kl' <= kl)) \/ - (LevelMap.MapsTo l k a /\ (forall kl', LevelExprSet.In (l, kl') n -> kl' <= k)))) - /\ (forall l, ~ LevelMap.In l map -> ~ (exists k, LevelExprSet.In (l, k) n) /\ ~ (LevelMap.In l a)). -Proof. - eapply LevelExprSetProp.fold_rec. - - intros s' he. cbn. - setoid_rewrite (LevelExprSetProp.empty_is_empty_1 he). - intuition auto. right. split; eauto. - intros kl. now move/LevelExprSet.empty_spec. - destruct H0. now apply LevelExprSet.empty_spec in H0. - (* destruct H0 as [? [he' _]]. now rewrite LevelExprSetFact.empty_iff in he'. *) - - cbn; intros. - destruct x as [xl k']. split. - 2:{ intros l0 hnin. destruct H2 as [_ H2]. specialize (H2 l0). split. - { intros [k hex]. eapply H1 in hex as [hin|hin]. noconf hin. apply hnin. - eapply In_add_max. now left. - unshelve eapply (proj1 (H2 _)). - intros hin'. apply hnin. rewrite In_add_max. now right. now exists k. } - { apply H2 => hin. elim hnin. rewrite In_add_max. now right. } } - intros. - rewrite MapsTo_add_max in H3. - destruct (eqb_spec l xl); subst. - * unfold is_max in H3 at 1. - destruct LevelMap.find eqn:hfind. - { subst k. pose proof (LevelMap.find_2 hfind). destruct H2 as [H2 Hnotin]. destruct (H2 _ H3). - left. destruct H4 as [kl [hkl hleq]]. destruct hleq as [hleq hmax]. subst n0. - destruct (Nat.max_spec k' kl) as [[]|[]]. - { exists kl. split. apply H1. now right. split. f_equal. lia. split. intros. - apply H1 in H6 as []. noconf H6. lia. now apply (proj1 hmax). destruct hmax as [_ hmax]. - intros. now apply hmax. } - { exists k'. split. apply H1. now left. split. f_equal; lia. destruct hmax as [hmax hmax']; split. - intros kl' hin. apply H1 in hin as []; subst. noconf H6. lia. specialize (hmax _ H6). lia. - intros. transitivity kl. now apply hmax'. lia. } - destruct (H2 _ H3) as [[kl [hkl hleq]]|]. noconf hleq. - destruct hleq as [hleq hmax]. subst n0. - destruct (Nat.max_spec k' kl) as [[]|[]]. - { left. exists kl. split. apply H1. now right. destruct hmax as [hmax hmax']. split. f_equal. lia. split. - intros. apply H1 in H7 as []. noconf H7. lia. now apply hmax. apply hmax'. } - { left. exists k'. split. apply H1. now left. destruct hmax as [hmax hmax']. split. f_equal. lia. split. - intros kl' hin. apply H1 in hin as []. noconf H7. lia. specialize (hmax _ H7). lia. - intros. transitivity kl => //. now eapply hmax'. } - destruct H4. clear H5. - destruct (Nat.max_spec k' n0) as [[]|[]]. - { right. split. now rewrite H7. - intros kl' hin. apply H1 in hin as [hin|hin]; noconf hin. lia. - specialize (H6 _ hin). depelim H6; lia. } - { left. exists k'. split. apply H1. now left. split. f_equal. lia. split. - intros kl' hin. apply H1 in hin as []. noconf H8. lia. - specialize (H6 _ H8). lia. - intros. transitivity n0. 2: lia. eapply (LevelMapFact.F.MapsTo_fun H4) in H8. subst kl'. reflexivity. } - } - subst k. left. exists k'. split; eauto. firstorder. split. reflexivity. - destruct H2 as [hl hnotin]. eapply LevelMapFact.F.not_find_in_iff in hfind. - apply hnotin in hfind as hfind'. - split. - { intros. eapply H1 in H2 as [hin|hin]; noconf hin. reflexivity. - destruct hfind' as [hfind' _]. - elim hfind'. now exists kl'. } - { intros kl' hin. destruct hfind' as []. now elim H3; exists kl'. } - * destruct H2 as [H2 hfind]. destruct (H2 _ H3) as [[lk [hkl hleq]]|]. - + left. depelim hleq. destruct H6 as [hinl hinacc]. exists lk. split; [firstorder|]. split => //. - split => //. - { intros kl' hin. apply H1 in hin as [hin|hin]. noconf hin. congruence. subst k. now apply hinl. } - + right. intuition auto. - eapply H1 in H5 as [hin|hin]; noconf hin. congruence. - now eapply H7. -Qed. - - -Lemma min_model_map_levels m cls k : - LevelMap.In k (min_model_map m cls) <-> - LevelSet.In k (clauses_levels cls) \/ LevelMap.In k m. -Proof. - rewrite /min_model_map. - rewrite clauses_levels_spec. - eapply ClausesProp.fold_rec. - - intros s' he. intuition auto. - destruct H0 as [cl []]. - clsets. - - intros x a s' s'' inx ninx hadd ih. - destruct x as [cl k']. - rewrite In_fold_add_max In_add_max. rewrite ih. - intuition auto. left. exists (cl, k'); intuition auto. - apply hadd. now left. - rewrite clause_levels_spec. now left. - subst. left. exists (cl, k'). split. apply hadd; now left. - rewrite clause_levels_spec. now right. - destruct H as [cl'' []]. left. exists cl''. - intuition auto. apply hadd. now right. - destruct H3 as [cl'' []]. - apply hadd in H0 as []; subst. - rewrite clause_levels_spec in H3. destruct H3; subst. - cbn in H0. now left. right. now left. - right. right. left; exists cl''. split => //. -Qed. - -Lemma premises_model_map_levels m cls k : - LevelMap.In k (premises_model_map m cls) <-> - LevelSet.In k (clauses_premises_levels cls) \/ LevelMap.In k m. -Proof. - rewrite /premises_model_map. - rewrite clauses_premises_levels_spec. - eapply ClausesProp.fold_rec. - - intros s' he. intuition auto. - destruct H0 as [cl []]. - clsets. - - intros x a s' s'' inx ninx hadd ih. - destruct x as [cl k']. - rewrite In_fold_add_max ih. - intuition auto. - * left. exists (cl, k'); intuition auto. - apply hadd. now left. - * destruct H as [cl'' []]. left. exists cl''. - intuition auto. apply hadd. now right. - * destruct H3 as [cl'' []]. - apply hadd in H0 as []; subst. - now left. right. now left. -Qed. - - - -Section Completeness. - Reserved Notation "x ≡ y" (at level 90). - Record semilattice := - { carrier :> Type; - eq : carrier -> carrier -> Prop where "x ≡ y" := (eq x y); - succ : carrier -> carrier; - join : carrier -> carrier -> carrier; - join_assoc x y z : join x (join y z) ≡ join (join x y) z; - join_comm x y : join x y ≡ join y x; - join_idem x : join x x ≡ x; - join_sub x : join x (succ x) ≡ succ x; - succ_join : forall x y, succ (join x y) ≡ join (succ x) (succ y); - }. - - Notation "x ≡ y" := (eq _ x y). - - Section Derived. - Context (s : semilattice). - Definition le (x y : s) := join s x y ≡ y. - - Fixpoint add (x : s) n : s := - match n with - | 0 => x - | S n => succ _ (add x n) - end. - - End Derived. - - Definition term (V : Type) : Type := list (V * nat). - Definition relation (V : Type) := term V -> term V -> Prop. - - Record presented (V : Type) := { - terms : term V -> Prop; - relations : relation V }. - - Definition valid (V : Type) (C : presented V) (t u : term V) := relations _ C t u. - - Section Terms. - Context (V : Type) (pres : presented V). - Definition succV (t : term V) := map (fun '(x, n) => (x, S n)) t. - Definition maxV (t u : term V) := t ++ u. - - Definition presents : semilattice. - Proof. - unshelve refine {| carrier := term V; eq := relations _ pres; succ := succV; join := maxV |}. - all:apply (todo "laws"). - Defined. - - (* Definition interp_exp (vn : V * nat) : presents := let '(v, n) := vn in add presents v n. *) - Definition interp_term (t : term V) := - let '(hd, tl) := t in - List.fold_left (fun x n => join _ n (interp_exp x)) tl (interp_exp hd). - - Lemma all_terms (x : s) : exists t : term, - - - - - - Section Completeness. - - Definition add_presentation eq p := - {| V := p.(V); C := eq :: p.(C) |}. - - Definition relation_levels (r : rel) := (NES.levels r.1 ∪ NES.levels r.2)%levels. - - Definition wf_presentation p := - forall r, List.In r p.(C) -> relation_levels r ⊂_lset p.(V). - - Definition levels_position (l : Level.t) (ls : LevelSet.t) i := - List.nth_error (LevelSet.elements ls) i = Some l. - - Equations level_position (l : Level.t) (ls : list Level.t) : option nat := - level_position l [] := None ; - level_position l (x :: xs) with Level.eqb l x := - { | true => Some 0 - | false with level_position l xs := - | None => None - | Some n => Some (S n) }. - - Definition levelexpr_pos (l : LevelExpr.t) (ls : LevelSet.t) := - match level_position l.1 (LevelSet.elements ls) with - | None => 0 - | Some pos => LevelSet.cardinal ls * Z.to_nat l.2 + pos - end. - - Section Enum. - - Inductive enumeration : premises × premises -> Type := - | enum_single le le' : enumeration (singleton le, singleton le') - | enum_add_left le (u v : premises) : ~ LevelExprSet.In le u -> enumeration (u, v) -> enumeration (NES.add le u, v) - | enum_add_right le (u v : premises) : ~ LevelExprSet.In le v -> enumeration (u, v) -> enumeration (u, NES.add le v). - - Lemma acc_enum : forall r, enumeration r. - Proof. - intros [l r]. - move: l r. apply: NES.elim. - - intros le. - apply: NES.elim. - * intros le'. constructor. - * intros le' x. now constructor. - - intros le x ihr nin r. now constructor. - Qed. - End Enum. - Definition strict_subset (s s' : LevelExprSet.t) := - LevelExprSet.Subset s s' /\ ~ LevelExprSet.Equal s s'. - -(* Lemma strict_subset_incl (x y z : LevelSet.t) : LevelSet.Subset x y -> strict_subset y z -> strict_subset x z. -Proof. - intros hs []. split => //. lsets. - intros heq. apply H0. lsets. -Qed. *) - - Definition premises_strict_subset (x y : premises) := strict_subset x y. - - Definition ord := lexprod premises_strict_subset premises_strict_subset. - Derive Signature for lexprod. - - Lemma premises_incl_singleton (u : premises) le : - u ⊂_leset (singleton le) -> LevelExprSet.Equal u (singleton le). - Proof. - intros incl; split => //. - - apply incl. - - intros hin. eapply LevelExprSet.singleton_spec in hin. subst. - move: u incl. apply: NES.elim. - * intros le' hs. specialize (hs le'). forward hs. apply LevelExprSet.singleton_spec. lesets. - apply LevelExprSet.singleton_spec in hs. subst le'. - now apply LevelExprSet.singleton_spec. - * intros le' x ih hnin hadd. - rewrite LevelExprSet.add_spec. right; apply ih. - intros ? hin. apply hadd. now rewrite LevelExprSet.add_spec; right. - Qed. - - Lemma subset_add {a l x} : - ~ LevelExprSet.In l a -> a ⊂_leset NES.add l x -> a ⊂_leset x. - Proof. - intros hnin; rewrite -union_add_singleton. - move=> hsub lk /[dup]/hsub. rewrite union_spec. - intros [] => //. apply LevelExprSet.singleton_spec in H. subst. contradiction. - Qed. - - (* Lemma subset_add_2 {a l x} : - LevelExprSet.In l a -> a ⊂_leset NES.add l x -> a ⊂_leset x. - Proof. - intros hnin; rewrite -union_add_singleton. - move=> hsub lk /[dup]/hsub. rewrite union_spec. - intros [] => //. apply LevelExprSet.singleton_spec in H. subst. contradiction. - Qed. *) - - Section LevelExprSetCardinal. - - Import LevelExprSet. - Import LevelExprSetProp. - - Lemma cardinal_1_is_singleton a : cardinal a = 1 <-> exists x, Equal a (singleton x). - Proof. Admitted. - - Lemma premises_cardinal (p : premises) : cardinal p > 0. - Proof. Admitted. - - Lemma not_Equal_exists_diff (p p' : premises) : - p ⊂_leset p' -> ~ Equal p p' -> - exists le, (In le p' /\ ~ In le p). - Proof. - intros hsub neq. - pose c := choose (diff p' p). - case hc : c => [elt|]. move/choose_spec1: hc. - rewrite diff_spec => -[hin nin]. now exists elt. - move/choose_spec2: hc => hc. - have hsub' : p' ⊂_leset p. lesets. elim neq. - lesets. - Qed. - - Lemma premises_strict_subset_spec p p' : premises_strict_subset p p' <-> - (p ⊂_leset p') /\ exists le, In le p' /\ ~ In le p. - Proof. - split. - - intros [hincl hneq]. split => //. - now apply not_Equal_exists_diff. - - intros [hincl [le [inp' ninp]]]. - split => // => he. rewrite -he in inp'. contradiction. - Qed. - - Lemma premises_strict_subset_cardinal (p p' : premises) : - premises_strict_subset p p' -> (cardinal p < cardinal p')%nat. - Proof. - rewrite premises_strict_subset_spec => -[incl [le [inp' ninp]]]. - eapply subset_cardinal_lt; tea. - Qed. - - Lemma cardinal_add {le x} : ~ In le x -> cardinal (add le x) = 1 + cardinal x. - Proof. lesets. Qed. - - Lemma premises_eq_singleton {a : premises} {x} : a = singleton x :> LevelExprSet.t -> a = NES.singleton x. - Proof. - intros he. rewrite -equal_exprsets. cbn. now rewrite he. - Qed. - - Lemma premises_strict_subset_wf : well_founded premises_strict_subset. - Proof. - red. intros a. - have hr : LevelExprSet.cardinal a <= LevelExprSet.cardinal a by lesets. - revert hr. generalize a at 2 => a'. move: a' a. - apply: NES.elim. - - intros le a. rewrite NES.LevelExprSetProp.singleton_cardinal. - have carda := premises_cardinal a => cardle. - have : cardinal a = 1 by lia. - rewrite cardinal_1_is_singleton => -[x heq]. - move/eq_leibniz/premises_eq_singleton: heq. intros ->. - constructor. intros y hp. - destruct hp. eapply premises_incl_singleton in H. contradiction. - - intros le x accx hnin. - intros a asub. - constructor => y. - move/premises_strict_subset_cardinal => hc. - apply accx. rewrite cardinal_add // in asub. lia. - Qed. - End LevelExprSetCardinal. - - Lemma acc_ord r : Acc ord r. - Proof. - apply wf_lexprod; apply premises_strict_subset_wf. - Qed. - Instance ord_wf : WellFounded ord. - Proof. red. exact acc_ord. Qed. - - Lemma premises_strict_subset_add {l} {u : premises} : - ~ LevelExprSet.In l u -> premises_strict_subset u (NES.add l u). - Proof. - intros hnin; rewrite premises_strict_subset_spec. - rewrite -union_add_singleton. setoid_rewrite union_spec. split. - - intros l'. rewrite union_spec; lesets. - - exists l; split => //. right; now apply LevelExprSet.singleton_spec. - Qed. - - - - -(* Completeness try *) -(* - - - Parameter ϕ : nat -> rel. - Parameter ϕ_exists : forall r, exists n, ϕ n = r. - Parameter ϕ_inj : forall n n', ϕ n = ϕ n' -> n = n'. - - Definition neg_r p e := - p ⊢ℒ add_prems 1 e.1 ≤ e.2 \/ p ⊢ℒ add_prems 1 e.2 ≤ e.1. - - (* Definition consistent (r : rels) := - ~ (exists e, r ⊢ℒ e /\ neg_r r e). - - Definition satisfiable (r : rels) := - exists v, interp_rels v r. - - Definition satisfiable_consistent {p} : - satisfiable p -> consistent p. - Proof. - move=> [v it] [[l r] [hx [hnl|hnl]]]; - eapply presentation_entails_valid_eq in hx; - eapply presentation_entails_valid_le in hnl; - move: (hx _ it); move: (hnl _ it); cbn; - rewrite !interp_add_prems; lia. - Qed. *) - - (* Definition consistent' (Γ : rels) := - exists r, ~ (Γ ⊢ℒ r). *) - - Definition bottom (s : semilattice) := - exists x : s, add 1%Z x ≤ x. - - Notation "⟘" := (bottom _) : sl_scope. - - Definition consistent Γ := - ~ exists e, Γ ⊢ℒ e ≡ add_prems 1 e. - - Inductive 𝒮 (r : rels) : rels -> nat -> Prop := - | S_0 Γ : List.incl Γ r -> 𝒮 r Γ 0 - | S_incl Γ n : 𝒮 r Γ n -> - (* ~ consistent (ϕ n :: Γ) -> *) - 𝒮 r Γ (S n) - | S_phi Γ n : 𝒮 r Γ n -> consistent (ϕ n :: Γ) -> 𝒮 r (ϕ n :: Γ) (S n). - - Definition 𝒮ω rs (Γ : rels) := exists (n: nat), 𝒮 rs Γ n. - - Definition in𝒮ω rs r := exists (n: nat) Γ, 𝒮 rs Γ n /\ Γ ⊢ℒ r. - - (* /\ Γ ⊢ℒ r *) - - Definition maximally_consistent (Γ : rels) := - consistent Γ /\ forall r, (~ consistent (r :: Γ) \/ Γ ⊢ℒ r). - - Definition satisfiable (s : semilattice) (r : rels) := - exists v, interp_rels (SL := sl s) v r. - - Lemma consistent_satisfiable Γ : - satisfiable Z_semilattice Γ -> consistent Γ. - Proof. - move=> [v sat] [e]. - move/presentation_entails_valid_rel/(_ Z_semilattice v sat). cbn. - rewrite interp_add_prems. change (add 1%Z (interp_nes v e)) with (Z.add 1 (interp_nes v e)). - cbn -[Z.add]. lia. - Qed. - - Section MaximallyConsistent. - - Lemma 𝒮ω_consistent_maximal Γ Γ' n : consistent Γ -> 𝒮 Γ Γ' n -> consistent Γ'. - (* /\ (consistent' (ϕ n :: Γ') \/ Γ' ⊢ℒ ϕ n). *) - Proof. - move=> con sprf. induction sprf. - - intros [e pe]. apply con. exists e. - eapply entails_L_rels_subset; tea. - - exact IHsprf. - - intros [e neq]. - destruct H. now exists e. - Qed. - - Definition 𝒮ω_exists rs (crs : consistent rs) n : exists Γ, 𝒮 rs Γ n. - Proof. - induction n. - - exists rs. by constructor. - - destruct IHn as [Γ' sn]. - destruct (check_pres_clause_spec Γ' (ϕ n)). - * exists (ϕ n :: Γ'). apply S_phi => //. - intros [e he]. apply 𝒮ω_consistent_maximal in sn => //. - eapply entails_L_cut in H; tea. - apply sn. now exists e. - * exists Γ'. apply S_incl => //. - Qed. - - Definition inSw rs r := exists n Γ, 𝒮 rs Γ n /\ Γ ⊢ℒ r. - - Import Semilattice. - - Lemma axiom_inSw {rs r} : rs ⊢ℒ r -> inSw rs r. - Proof. - intros hs. exists 0, rs; split. constructor. red; auto. - exact: hs. - Qed. - -*) - - - Class Decidable (A : Prop) := dec : A \/ ~ A. - Arguments dec A {Decidable}. - - (* Definition check_pres_clause p r := - LoopCheck.Impl.check_clauses (clauses_of_relations p) (clauses_of_eq r.1 r.2). - - Lemma check_pres_clause_spec p r : p ⊢ℒ r \/ ~ (p ⊢ℒ r). - Proof. - destruct (check_pres_clause p r) eqn:eq. - - move: eq. - rewrite /check_pres_clause. - Admitted. - - Instance dec_entails_L {p s t} : Decidable (p ⊢ℒ s ≡ t). - Proof. - red. eapply check_pres_clause_spec. - Qed. - - Lemma contra_prop A B (decB : Decidable B) : (~ B -> ~ A) -> (A -> B). - Proof. intros he a. destruct (dec B). exact H. specialize (he H). contradiction. Qed. - - Definition satisfiable (s : semilattice) (r : rels) := - exists v, interp_rels (SL := sl s) v r. - *) - - - Structure semilattice {Q} := - { carrier :> Type; - comm_monoid : IsCommMonoid Q ; - sl : Semilattice carrier Q }. - Arguments semilattice : clear implicits. - - Instance semilattice_CommMonoid {Q} (s : semilattice Q) : IsCommMonoid Q := comm_monoid s. - - Instance semilattice_Semilattice {Q} (s : semilattice Q) : @Semilattice (carrier s) Q (comm_monoid s) := sl s. - - - -Inductive simplified cls : Clause.t -> Prop := -| simpl_incl cl : cls cl -> simplified cls cl -| simpl_below {cl prems concl prems' k k'} : - simplified cls cl -> - cls (prems, (concl, k)) -> - (concl, k') ∈ prems -> - k' < k -> - remove_prem_opt (concl, k') prems = Some prems' -> - simplified cls (prems', (concl, k)). - -(* -Inductive simplified cls : Clauses.t -> Prop := -| simpl_below {cls' prems concl prems' k k'} : - simplified cls cls' -> - max_chain cls (prems, (concl, k)) -> - (concl, k') ∈ prems -> - k' < k -> - remove_prem_opt (concl, k') prems = Some prems' -> - Clauses.In (prems', (concl, k)) cls' -> - simplified cls cls'. *) - - - -(* Inductive simplified cls : Clause.t -> Prop := -| simpl_incl cl : entails cls cl -> simplified cls cl -| simpl_below {prems concl prems' k k'} : - simplified cls (prems, (concl, k)) -> - (concl, k') ∈ prems -> - k' < k -> - remove_prem_opt (concl, k') prems = Some prems' -> - simplified cls (prems', (concl, k)). *) - -Inductive simplified cls : Clauses.t -> Prop := -| simpl_incl cls' : entails_clauses cls' cls -> simplified cls cls' -| simpl_below {cls' prems concl prems' k k'} : - simplified cls cls' -> - cls' ⊢ prems → (concl, k) -> - (concl, k') ∈ prems -> - k' < k -> - remove_prem_opt (concl, k') prems = Some prems' -> - simplified cls (Clauses.add (prems', (concl, k)) cls'). - -Definition con_cls cls := ~ exists u, entails_all cls u (succ u). - -Lemma eq_inj concl le (prems : NES.t) : - ~ le ∈ prems -> - NES.add concl (singleton le) = union (singleton le) prems -> - prems = singleton concl. -Proof. - move=> hnin /equal_exprsets eq. - apply equal_exprsets => l. - rewrite LevelExprSet.singleton_spec /LevelExprSet.E.eq. - split. - - intros inp. - specialize (eq l). - have hneq : l <> le. - { intros ->. contradiction. } - destruct eq as [eq eq']. - forward eq'. rewrite LevelExprSet.union_spec. now right. - eapply LevelExprSet.add_spec in eq' as [eq'|eq']; auto. - eapply LevelExprSet.singleton_spec in eq'. contradiction. - - intros ->. - have hneq : concl <> le. - { intros ->. - have eqs : NES.add le (singleton le) = singleton le. - apply equal_exprsets. intros l. - rewrite LevelExprSet.add_spec. firstorder. red in H; subst l. - now apply LevelExprSet.singleton_spec. - rewrite eqs in eq. - specialize (eq (choose prems)). - destruct eq. forward H0. - apply LevelExprSet.union_spec. right; apply choose_spec. - eapply LevelExprSet.singleton_spec in H0. - red in H0; subst le. - apply hnin. apply choose_spec. } - specialize (eq concl). - destruct eq. - forward H. apply NES.add_spec. now left. - apply LevelExprSet.union_spec in H as [H|H] => //. - apply LevelExprSet.singleton_spec in H. red in H; subst. - congruence. -Qed. - -Definition simple_clauses cls cl := - let '(prems, (concl, k)) := cl in - ~ exists k', k' < k /\ (concl, k') ∈ prems /\ entails cls cl. - -(* Enforce x ∨ y + k' -> z + k. - If satisfiable, check for each premise if (m[l] - k') + k > m[concl] - if not, i.e. m[y] - k' + k > m[z] then remove the premise y + k'. - - Then the new clauses have the same model and entail the previous one. - For Z models they are equivalent. - *) - -Lemma simplified_entails cls cls' : - simplified cls cls' -> - forall cl, entails cls cl -> entails cls' cl. -Proof. - induction 1. - - intros cl. red in H. specialize (H cl). -Admitted. -Lemma con_cls_entails cls cl : - con_cls cls -> - entails cls cl -> - forall k', ((concl cl).1, k') ∈ premise cl -> - k' < (concl cl).2 -> - exists cls' prem', - remove_prem_opt ((concl cl).1, k') (premise cl) = Some prem' /\ - simplified cls cls' /\ - entails cls' (prem', concl cl). -Proof. - intros hcon. - induction 1. - - intros k' hin hlt. - destruct concl0 as [concl k]. - cbn -[lt remove_prem_opt] in *. - destruct remove_prem_opt eqn:hr. - * eapply remove_prem_opt_Some_eq in hr as [hr hneq]=> //. - subst prems. - exists cls. - eexists; split; trea. - eapply LevelExprSet.union_spec in H as [H|H]. - { apply LevelExprSet.singleton_spec in H. noconf H. cbn in hlt. lia. } - split. - { constructor. eapply entails_clauses_tauto. } - now constructor. - * eapply remove_prem_opt_None in hr. - apply hr in hin. subst prems. - eapply LevelExprSet.singleton_spec in H; noconf H. - cbn in hlt. lia. - - destruct concl0 as [concl k]. - cbn -[lt remove_prem_opt] in *. - intros k' hin hlt. - move: (IHentails k') => /fwd. - { eapply LevelExprSet.add_spec. now right. } - move/(_ hlt) => -[cls' [prem' [hr [hsimp hent]]]]. - eapply remove_prem_opt_Some_eq in hr as [hr hnin]. - rewrite hr in H0. - destruct (remove_prem_opt (concl, k') prems) eqn:hr'; revgoals. - * eapply remove_prem_opt_None in hr'. - eapply hr' in hin. subst prems. - exfalso. - apply eq_inj in hr. subst prem'. - apply subset_singleton in H1. subst prems'. - clear hr'. - eapply entails_cumul_one in H0. - 2:{ eapply in_pred_closure_entails_clause in H. now eapply entails_all_singleton. } - elim hcon; exists (singleton (concl, k')). - rewrite add_prems_singleton. - eapply entails_all_trans. - eapply entails_all_singleton; tea. - eapply entails_all_singleton; tea. - eapply entails_lower. exists k. split => //. - now eapply LevelExprSet.singleton_spec. - cbn in *. lia. exact hnin. - * destruct (LevelExprSet.mem (concl, k') prems') eqn:hm. - eapply LevelExprSet.mem_spec in hm. - destruct (remove_prem_opt (concl, k') prems') eqn:hr2. - { exists (Clauses.add (t1, concl') cls'). exists t0. split => //. - split => //. - { constructor. admit. } - have he : prem' = NES.add concl' t0. - admit. subst prem'. - eapply (entails_cumul_one (prems' := singleton concl')). - eapply entails_all_singleton. - have hinc : t1 ⊂_leset t0. admit. - eapply entails_subset; tea. eapply entails_in. - eapply Clauses.add_spec. now left. - eapply entails_clauses_subset. - rewrite union_add_singleton. exact hent. clsets. } - eapply remove_prem_opt_None in hr2. - apply hr2 in hm. subst prems'. - destruct (Classes.eq_dec concl' (concl, k')). subst. - exists cls', t0. split => //. split => //. - have eq : prem' = t0. admit. subst t0. exact hent. - exists (Clauses.add (t0, (concl, k)) cls'), t0. split => //. split => //. admit. - eapply entails_in. eapply Clauses.add_spec. now left. - Admitted. - -Lemma simplified_entails cls cl : - con_cls cls -> - simplified cls cl -> entails cls cl. -Proof. - intros con. induction 1. - - now eapply entails_in. - - eapply remove_prem_opt_Some_eq in H2. - subst prems. - - eapply (entails_cumul_one (prems' := singleton (concl0, k'))); revgoals. - - - now rewrite -NES.union_add_singleton in IHsimplified. - - { rewrite union_opt_union union_remove //. now eapply entails_weak_union. } - eapply (entails_shift (k' - k)) in IHmax_chain1. - cbn in IHmax_chain1. - have heq: k' - k + k = k' by lia. - rewrite heq in IHmax_chain1. - eapply entails_all_singleton. - now eapply entails_weak_union_opt. -Qed. - -Lemma strictly_updates_strengthen V m m' : - strictly_updates (clauses m) V (model m) m' -> - is_model m' (clauses m) -> - is_model m' (thin_clauses m). -Proof. - intros su. - remember (model m) as model. - remember (clauses m) as cls. - revert m Heqcls Heqmodel. - induction su. - - destruct cl as [prems [concl k]]. - destruct H1 as [vmin [hmin nabove eqm]]. - move/negPf: nabove => /[dup]. - move/update_model_not_above => ext /level_value_not_above_spec. - move=> hle m0 eqcls eqm0. subst cls m. - move=> /[dup] ism' /is_modelP /(_ (prems, (concl, k))) /fwd // /valid_clause_elim hz. - have [hf [[minp minl] [hin heq]]] := min_premise_spec_aux _ _ _ hmin. - destruct (Classes.eq_dec minp concl). - * (* Minimial premise is the conclusion *) - subst minp. - unfold min_atom_value in heq. - destruct (level_value _ concl) eqn:hl => //. - noconf heq. depelim hle. - (* We are updating the conclusion by k - minl > 0 *) - have hk : k - minl > 0 by lia. - have hpres := min_premise_pres prems ext. - rewrite hmin in hpres. - depelim hpres. - specialize (hz y). - rewrite eqm in hz. specialize (hz H3). - rewrite level_value_add in hz. depelim hz. - have [hf' hex'] := min_premise_spec_aux _ _ _ H3. - specialize (hf' _ hin). - rewrite /min_atom_value level_value_add in hf'. - depelim hf'. cbn in *. - destruct hex' as [[minp' minl'] [hin' heq']]. - have hz : z <= y + minl by lia. - have hz' : y + minl <= k + (z - minl) by lia. - destruct (Classes.eq_dec minp' concl). - { subst minp'. rewrite /min_atom_value level_value_add in heq'. noconf heq'. - have hm : minl' = minl. - apply antisymmetry. 2:lia. - have ha := hf _ hin. - have hb := hf _ hin'. - apply level_value_MapsTo' in hl. - rewrite !(Model.min_atom_value_mapsto hl) in ha, hb. - cbn in ha, hb. depelim hb. lia. lia. - } - have hne : exists le', (concl, minl) <> le' /\ LevelExprSet.In le' prems. - { exists (minp', minl'). split => //. intros [=]. congruence. } - set premsd := remove_prem (concl, minl) prems hne. - apply/is_modelP => cl /thin_clauses_spec_inv. - move=> -[cl0 [heqo hino]]. - have hs := thin_clause_opt_spec m0 cl0. - rewrite heqo in hs. - destruct hs as [premsnl [premsl [eq eq' ent nent]]]. - subst cl. - Search thin_clauses. - - - exists (Clauses.add (premsd, (concl, k)) cls). - split; [|split]. - { (* Weakening *) todo "weaking of entails H". } - { rewrite ClausesProp.add_union_singleton. eapply is_model_union => //. - eapply is_model_singleton. - eapply valid_clause_intro. setoid_rewrite eqm. - intros z' hz''. - eapply (min_premise_remove (hne := hne)) in H3; tea. - rewrite H3 in hz''. noconf hz''. - rewrite level_value_add. constructor. lia. - intros h'; noconf h'. congruence. } - red. - intros prems' concl' k0 k' ent hlt. - admit. - * -Qed. - - -Lemma strengthen_model m cls : - is_total_model m cls -> - exists cls', cls' ⊢ℋ cls /\ is_total_model m cls' /\ normalized cls'. -Proof. - intros ism. - -Qed. - - -(* - Suppose we have an entailment comming from strict updates which gaves us a model of: - - cls |- l + k' ∨ prems -> l + k - - Then we can remove l + k' from all premises in cls. - - If a clause mentionned l + k' in its premise and it was the minimal premise either - we found a loop or the minimal premise is another universe so the clause without the - l + k' premise is valid. - -*) - - -Definition normalized cls := - forall prems concl k k', - entails cls (NES.add (concl, k') prems, (concl, k)) -> - k' < k -> - entails cls (prems, (concl, k)). - -#[local] Obligation Tactic := idtac. -#[program] Definition remove_prem le (e : NES.t) (hne : exists le', le <> le' /\ LevelExprSet.In le' e) := - {| t_set := LevelExprSet.remove le e; - t_ne := _ |}. -Next Obligation with idtac. - intros le e [le' [diff hin]]. - rewrite -not_Empty_is_empty => /(_ le'); apply. - apply LevelExprSet.remove_spec. split => //. congruence. -Qed. - -Lemma remove_prem_spec le e hne le' : - LevelExprSet.In le' (remove_prem le e hne) <-> - LevelExprSet.In le' e /\ le <> le'. -Proof. Admitted. - -Lemma remove_prem_singleton le le' hne : - remove_prem le (singleton le') hne = singleton le'. -Proof. - apply equal_exprsets. - intros lk. - rewrite LevelExprSet.singleton_spec. - split. - - move/remove_prem_spec => -[/LevelExprSet.singleton_spec hdiff]. - red in hdiff; subst lk. reflexivity. - - intros ->. apply/remove_prem_spec. - destruct hne as [? [hd hs]]. - eapply LevelExprSet.singleton_spec in hs. red in hs; subst. - split => //. now apply singleton_spec. -Qed. - -Lemma remove_prem_add le le' prems hne hne' : - le <> le' -> - remove_prem le (NES.add le' prems) hne = NES.add le' (remove_prem le prems hne'). -Proof. - intros hdiff. apply equal_exprsets. - intros lk. - rewrite !remove_prem_spec !add_spec remove_prem_spec. - firstorder. subst. - eapply LevelExprSet.add_spec in H0 as [heq|hin] => //. -Qed. - -Lemma min_premise_remove {m le prems hne minv minp mink} : - min_premise m prems = Some minv -> - Some minv = min_atom_value m (minp, mink) -> - LevelExprSet.In (minp, mink) prems -> - le <> (minp, mink) -> - min_premise m (remove_prem le prems hne) = Some minv. -Proof. - move=> hmin mineq hin hdiff. - have [hf [[minp' minl] [heq hin']]] := min_premise_spec m (remove_prem le prems hne). - rewrite hin'. - eapply remove_prem_spec in heq as [hinr hdiff']. - enough (min_atom_value m (minp', minl) = min_atom_value m (minp, mink)). - noconf H. congruence. - apply antisymmetry. - * rewrite -mineq. - specialize (hf (minp, mink)). forward hf. - apply remove_prem_spec. split => //. - rewrite -mineq in hf. - now rewrite hin' in hf. - * have [hf' _] := min_premise_spec m prems. - specialize (hf' _ hinr). - now rewrite hmin mineq in hf'. -Qed. - - - -Lemma strictly_updates_update cls W m m' : - strictly_updates cls W m m' -> - forall prems concl k minp, - Clauses.In (prems, (concl, k)) cls -> - min_premise m prems = Some minp -> - opt_le Z.lt (level_value m concl) (Some (k + minp)) -> - (Some (k + minp) ≤ level_value m' concl)%opt -> - updates cls m (LevelMap.add concl (Some (k + minp)) m) /\ - updates cls (LevelMap.add concl (Some (k + minp)) m) m'. -Proof. - move: W m m'. apply: strictly_updates_elim. - - intros l l' h ? ? x ? ? y. subst x0 x1. - unfold updates, is_update_of. - reflexivity. - - intros m [prems [concl k]] m' hin su prems' concl' k' minp hin' eqminp lt le'. - destruct su as [z [minp' nabove]]. - move/not_value_above: nabove => nabove. - cbn. - destruct (Classes.eq_dec concl concl'). - { (* Updates the same level *) - subst concl'. - (* have eql : LevelSet.add concl (LevelSet.singleton concl) =_lset LevelSet.singleton concl. *) - (* { rsets. lsets. } *) - (* rewrite eql. *) - rewrite H. rewrite H in le'. - rewrite level_value_add in le'. depelim le'. - destruct (Z.eq_dec (k' + minp) (k + z))%Z. - { (* No real update *) - cbn in e; rewrite e. - split. - * exists (LevelSet.singleton concl). - rewrite /is_update_of levelset_is_empty_singleton. - apply (one_update (cl := (prems, (concl, k)))); tea. - cbn. exists z. split => //. - now apply/not_value_above. - * exists LevelSet.empty. - rewrite /is_update_of levelset_is_empty_empty. - reflexivity. } - { (* Real updates to compose *) - cbn in n. - have hlt : (k' + minp < k + z)%Z by lia. - clear n H0. split. - * exists (LevelSet.singleton concl). - rewrite /is_update_of levelset_is_empty_singleton. - eapply (one_update (cl := (prems', (concl, k')))). exact hin'. - cbn. exists minp. split => //. - now apply/not_value_above. - * exists (LevelSet.singleton concl). - rewrite /is_update_of levelset_is_empty_singleton. - eapply (one_update (cl := (prems, (concl, k)))). exact hin. - cbn. exists z. split => //. 2:{ apply/not_value_above. rewrite level_value_add. - constructor => //. } - have [hf hex] := min_premise_spec_aux _ _ _ minp'. - destruct hex as [[minpl minpk] [inmin eqmin]]. - unfold min_atom_value in eqmin. - destruct (level_value m minpl) as [minpv|] eqn:hl => //. noconf eqmin. - destruct (Classes.eq_dec minpl concl). subst minpl. - rewrite hl in lt. depelim lt. rewrite hl in nabove. depelim nabove. - have hk : (minpk < k)%Z by lia. - have hk' : (k' + minp - minpk = minpv - minpk). -Admitted. - (* rewrite min_premise_add_down - rewrite level_value_add. - - have [hf' hex'] := min_premise_spec_aux _ _ _ eqminp. - destruct hex' as [[minpl' minpk'] [inmin' eqmin']]. - unfold min_atom_value in eqmin'. - destruct (level_value m minpl') as [minpv'|] eqn:hl' => //. noconf eqmin'. - destruct (Classes.eq_dec minpl' concl). subst minpl'. - rewrite hl in hl'. noconf hl'. -Admitted.*) - (* rewrite hl in lt. depelim lt. rewrite hl in nabove. depelim nabove. - - - rewrite -eql. - rewrite -(union_idem cls). - rewrite LevelSetProp.add_union_singleton. - eapply strictly_updates_trans. - - - - - } - - - Admitted. *) -(* -Lemma strictly_updates_use_ext cls W m m' m0 : - strictly_updates cls W m m' -> - m ⩽ m0 -> - m0 ⩽ m' -> - updates cls m0 m'. -Proof. - move: W m m'. - apply: (strictly_updates_elim cls). - - intros l l' h ? ? x ? ? y. subst x0 x1. - unfold updates. reflexivity. - - destruct cl as [prems [concl k]]. - move=> m' hin [minp [hmin /not_value_above habove]]. - rewrite /updates. intros h. setoid_rewrite h. - move=> ext ext'. - have := @min_premise_pres m m0 prems ext. - rewrite hmin; move/Some_leq => -[minm0] [] minp0 hle. - exists (LevelSet.singleton concl). - rewrite /is_update_of levelset_is_empty_singleton. - - /hz /Some_leq [mfconcl] [] vmconcl leq' leq. hle. - - - eapply is_model_valid in ism. - specialize (ism _ hin). cbn in ism. - move/valid_clause_elim: ism. - intros hz. - - -Qed. -*) -Lemma minimal_above_updates_updates cls W m m' : - strictly_updates cls W m m' -> - minimal_above_updates cls m m'. -Proof. - move: W m m'. - apply: (strictly_updates_elim cls). - - intros l l' h ? ? x ? ? y. subst x0 x1. - unfold minimal_above_updates. reflexivity. - - destruct cl as [prems [concl k]]. - move=> m' hin [minp [hmin habove]]. - rewrite /minimal_above_updates. intros h. setoid_rewrite h. - move=> mf ext ism. - eapply is_model_valid in ism. - specialize (ism _ hin). cbn in ism. - move/valid_clause_elim: ism. - intros hz. - have := @min_premise_pres m mf prems (updates_ext ext). - rewrite hmin. move/Some_leq => -[minmf] [] /hz /Some_leq [mfconcl] [] vmconcl leq' leq. - destruct ext as [W ext]. - exists (LevelSet.add concl W). red. - destruct LevelSet.is_empty eqn:ise. - { exfalso. eapply LevelSet.is_empty_spec in ise. apply (ise concl). lsets. } - move/is_update_of_case: ext => -[[emp eq]|su]. - { exfalso. move: vmconcl habove. rewrite -eq. - move=> hl /not_value_above. rewrite hl => hlt. - depelim hlt. lia. } - { move/not_value_above: habove => hlt. - (* The conclusion is higher in mf. *) - todo "commutation". } - (* eapply strictly_updates_update; tea. *) - - - (* rewrite vmconcl. constructor. lia. } *) - - intros * su ma su' ma'. - intros mf extinit ism. - move: (ma mf extinit ism) => hext. - exact (ma' mf hext ism). -Qed. - -Lemma updates_extends {cls m m'} : updates cls m m' -> m ⩽ m'. -Admitted. -(* Lemma minimal_above_valid cls minit m : - minimal_above_updates cls minit m -> - updates cls minit m -> - forall cl, valid_clause m cl -> - forall m', updates cls m m' -> is_model m cls' -> valid_clause m' cl. -Proof. - intros hmin hupd [prems [concl k]]. - move/valid_clause_elim => hz m' ext ism. - unfold valid_clause. cbn. - destruct (min_premise m' prems) eqn:hminp => //. - specialize (hmin m' ext ism). - destruct (min_premise m prems) eqn:hl. - specialize (hz _ eq_refl). - have minp := min_premise_pres prems (updates_extends hmin). - rewrite hl in minp. rewrite hminp in minp. depelim minp. - depelim hz. rewrite /level_value_above. - have mle := model_le_values concl (updates_extends hmin). - rewrite H0 in mle. depelim mle. rewrite H3. apply Z.leb_le. - - specialize (min' m). - Search level_value. - Search valid_clause. *) - - - -(** If a clause cl is not entailed then its inverse must be consistent. *) -Lemma nentails_thin_con m cl : - ~ entails (thin_clauses m) cl -> - (exists l, Clauses.union (thin_clauses m) (inverse_clauses cl) ⊢ℋ (succ l ⋞ l)%cls) -> False. -Proof. - intros _ hl. - set (cl' := (singleton (concl cl), succ_expr (concl cl))). - destruct (entails_dec_thin m cl'). - { eapply entails_completeness in e. - specialize (e Z _ (Z_valuation_of_model m)). - forward e. apply valid_clauses_model; - apply total_model_thin. - destruct cl as [prems [concl k]]; cbn in e. rewrite /interp_expr in e. - rewrite interp_nes_singleton //= in e. lia. } - { destruct hl as [l hl]. - unfold inverse_clauses in hl. - destruct cl as [prems concl]. cbn in cl'. - admit. } -Admitted. - - -Lemma entails_thin_disj m cl : - entails (thin_clauses m) cl -> - thin_clauses m ⊢ℋ inverse_clauses cl -> False. -Proof. - have ht := is_total_model_thin m m. - forward ht. split. eapply model_enabled. apply model_ok. - rewrite entails_completeness => ha. - move/entails_clauses_completeness => hz. - move: (hz (Z_valuation_of_model m)) => /fwd. - apply valuation_of_model_pos. move=> /fwd. - eapply valid_clauses_model; apply ht. - specialize (ha Z _ (Z_valuation_of_model m)). - forward ha. - eapply valid_clauses_model; apply ht. - move: ha. rewrite -neg_inverse_Z. contradiction. -Qed. - -Definition thinned_clause cls cl := - forall e, e ∈ premise cl -> ~ cls ⊢ premise cl → succ_expr e. - -Lemma nthinned_clause cls cl : ~ thinned_clause cls cl <-> - (exists e, e ∈ premise cl /\ cls ⊢ premise cl → succ_expr e). -Proof. - split. intros. - admit. intros [e [hin heent]] hf. - specialize (hf e hin). contradiction. -Admitted. - -Definition thinned_clauses cls := - forall cl, Clauses.In cl cls -> thinned_clause cls cl. - -Definition unique_prems (prems : NES.t) := - forall l k k', (l, k) ∈ prems -> (l, k') ∈ prems -> k = k'. - -Definition increasing cl := - (exists k', LevelExprSet.In ((concl cl).1, k') (premise cl)) /\ - (forall k', LevelExprSet.In ((concl cl).1, k') (premise cl) -> (k' < (concl cl).2)%Z). - -Lemma increasing_dec cl : { increasing cl } + { ~ increasing cl }. -Admitted. - -Lemma nincreasing_spec cl : (~ increasing cl) <-> - (~ exists k', LevelExprSet.In ((concl cl).1, k') (premise cl)) \/ - (exists k', LevelExprSet.In ((concl cl).1, k') (premise cl) /\ (concl cl).2 <= k')%Z. -Proof. -Admitted. - -Lemma entails_thin_dup cls prems concl : - entails cls (prems, concl) -> - forall l k k', (l, k) ∈ prems -> (l, k') ∈ prems -> k < k' -> - exists prems', remove_prem_opt (l, k) prems = Some prems' /\ - entails cls (prems', concl). -Proof. - intros ent l k k' ha hb hlt. - destruct (remove_prem_opt) eqn:rm. - - eapply remove_prem_opt_Some_eq in rm as []. subst prems. - exists t0. split => //. - eapply (entails_cumul_one (prems' := singleton (l, k))). - eapply entails_all_singleton. - move/LevelExprSet.union_spec: hb => -[]. - * move/LevelExprSet.singleton_spec => [=] eq. subst k'. cbn in hlt; lia. - * intros he. eapply entails_lower. exists k'. split => //. cbn in *; lia. - * now rewrite union_comm. - * exact ha. - - eapply remove_prem_opt_None in rm. - apply rm in ha. - cbn in ha; subst prems. - apply LevelExprSet.singleton_spec in hb. noconf hb. - cbn in hlt. lia. -Qed. -(* - Inductive entailsS (cls : Clauses.t) : clause -> Prop := - | clause_in (prems : premises) (concl : LevelExpr.t) : - LevelExprSet.In concl prems -> entailsS cls (prems, concl) - - | clause_cut prems' concl' prems concl : - in_pred_closure cls (prems', concl') -> - ~ (exists k', (concl'.1, k') ∈ prems /\ concl'.2 <= k') -> - entailsS cls (NES.add concl' prems, concl) -> - LevelExprSet.Subset prems' prems -> - entailsS cls (prems, concl). - -About entailsS_ind. - - Lemma entails_entailsS cls cl : - entailsS cls cl -> - entails cls cl. - Proof. - induction 1. - - now constructor. - - eapply Clauses.clause_cut; tea. - Qed. *) - - - -(* Print entails. *) - -Lemma entails_thinned cls : - (* thinned_clauses cls -> *) - forall cl, entails cls cl -> - (increasing cl /\ exists cl, Clauses.In cl cls /\ ~ thinned_clause cls cl) \/ - (~ increasing cl). -Proof. - intros cl. - induction 1. - - right. move=> -[[k' hin] ha]. - destruct concl0 as [concl k]. - cbn in *. - specialize (ha _ H). lia. - - cbn. - destruct IHentails. - destruct H2 as [inc nthin]. - destruct inc as [[k' hink'] hf]. - * cbn -[lt] in *. - eapply LevelExprSet.add_spec in hink' as [heq|hinc]. - red in heq; subst concl'. - destruct (increasing_dec (prems, concl0)). - now left. now right. - left. split => //. - split; cbn -[lt]. now exists k'. - intros. apply hf. apply LevelExprSet.add_spec; now right. - * apply nincreasing_spec in H2. - cbn -[lt] in *. - destruct H2. - right. move=> [h h']. apply H2. cbn in *. - destruct h as [k' ?]; exists k'; apply LevelExprSet.add_spec; now right. - destruct H2. - destruct (increasing_dec (prems, concl0)). - left. split => //. destruct H2. - apply LevelExprSet.add_spec in H2. destruct H2. - red in H2; subst concl'. - red in i. cbn in i. - Admitted. - - (** We are inferring (concl0, n + kc') from a clause (premsc, (concl0, kc')) - in cls where premsc + n ⊂ prems and prems has all it concl0 atoms smaller - than kc'. If the premsc contains concl0 it cannot be thinned. - Otherwise it might be introducing concl0, n + kc', e.g. - - x -> (concl0, kc') allows to prove x -> (concl0, kc). - - *) - - -Lemma thin_clauses_levels m : clauses_levels (thin_clauses m) ⊂_lset clauses_levels (clauses m). -Proof. Admitted. - -Lemma entails_dec_thin (m : t) cl : - { entails (thin_clauses m) cl } + { ~ entails (thin_clauses m) cl }. -Proof. - destruct (check_gen (thin_clauses m) cl) eqn:ch. - - move/check_looping: ch; elim. - exists (model_of m). split. - { have dm := defined_model m. - eapply defined_model_of_subset; tea. - eapply defined_model_of_subset; tea. - intros ?; rewrite -clauses_levels_declared. - apply thin_clauses_levels. } - apply total_model_thin. - - move/check_invalid_entails: ch. intros ne. now right. - - move/check_gen_entails: ch. now left. -Qed. - -Definition valid_total_models cls cl := - forall m : Model.model, is_total_model m cls -> - defined_model_of (clause_levels cl) m -> valid_clause m cl. - -Lemma valid_total_models_Z_models cls cl : valid_clause_Z cls cl <-> valid_total_models cls cl. -Proof. - split. - - intros H m istot encl. - move: (H (Z_valuation_of_model m)) => /fwd. - destruct istot. move/is_modelP: H1 => H1. - move=> cl' /[dup] /H0 en /H1. - now eapply valid_clause_model. - intros cs. - rewrite -def_clause_sem_valid //. - - intros vm v vpos csem. red in vm. todo "admit". -Qed. - diff --git a/template-rocq/theories/LoopChecking.v b/template-rocq/theories/LoopChecking.v deleted file mode 100644 index 77c8db9a8..000000000 --- a/template-rocq/theories/LoopChecking.v +++ /dev/null @@ -1,3280 +0,0 @@ -(* Distributed under the terms of the MIT license. *) -From Stdlib Require Import ssreflect ssrbool ZArith. -From Stdlib Require Import Program RelationClasses Morphisms. -From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils. - -From MetaRocq.Common Require Universes. -From Equations Require Import Equations. -Set Equations Transparent. - -(* TODO move *) -Arguments exist {A P}. -Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. - -Module FMapOrderedType_from_UsualOrderedType (O : UsualOrderedType). - Import O. - Definition t := O.t. - Definition eq : O.t -> O.t -> Prop := O.eq. - Definition lt : O.t -> O.t -> Prop := O.lt. - Definition eq_refl : forall x : O.t, eq x x := reflexivity. - Definition eq_sym : forall x y : O.t, eq x y -> eq y x := fun x y H => symmetry H. - - Lemma eq_trans : forall x y z, O.eq x y -> O.eq y z -> O.eq x z. - Proof. intros x y z. unfold O.eq. apply transitivity. Qed. - Lemma lt_trans : forall x y z, O.lt x y -> O.lt y z -> O.lt x z. - Proof. intros. eapply O.lt_strorder; tea. Qed. - - Lemma lt_not_eq : forall x y : O.t, lt x y -> ~ eq x y. - Proof. - intros x y H eq. do 2 red in eq. subst x. now eapply lt_strorder in H. - Qed. - - Definition compare : forall x y : O.t, Compare lt eq x y. - Proof. - intros. - case_eq (compare x y); intros. - apply EQ. abstract (destruct (compare_spec x y) => //). - apply LT. abstract (destruct (compare_spec x y) => //). - apply GT. abstract (destruct (compare_spec x y) => //). - Defined. - - Definition eq_dec : forall x y : O.t, {eq x y} + {~ eq x y} := eq_dec. -End FMapOrderedType_from_UsualOrderedType. - -Module Type LevelOrderedType. - Include UsualOrderedType. - - Parameter reflect_eq : ReflectEq t. - #[local] Existing Instance reflect_eq. - - Parameter to_string : t -> string. - -End LevelOrderedType. - -Module Type FMapOTInterface (E : UsualOrderedType). - Module OT := FMapOrderedType_from_UsualOrderedType E. - Include FMapInterface.Sfun OT. -End FMapOTInterface. - -Module Type LevelExprItf (Level : LevelOrderedType). - Include UsualOrderedType with Definition t := (Level.t * nat)%type. - Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. -End LevelExprItf. - -Module Type LevelExprSet_fun (Level : LevelOrderedType) (LevelExpr : LevelExprItf Level). - Include SWithLeibniz with Module E := LevelExpr. - - Record nonEmptyLevelExprSet - := { t_set :> t ; - t_ne : is_empty t_set = false }. - - (* Parameter map : (LevelExpr.t -> LevelExpr.t) -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet. *) - - (* Parameter map_spec : forall e f u, In e (map f u) <-> exists e0, In e0 u /\ e = (f e0). *) - -End LevelExprSet_fun. - -Module Type LoopCheckingItf (Level : LevelOrderedType) - (LevelSet : MSetInterface.SetsOn Level) - (LevelExpr : LevelExprItf Level) - (LevelExprSet : LevelExprSet_fun Level LevelExpr) - (LevelMap : FMapOTInterface Level). - - Definition model := LevelMap.t Z. - Definition valuation := LevelMap.t nat. - - Definition clause : Type := LevelExprSet.nonEmptyLevelExprSet × LevelExpr.t. - - Parameter clauses : Type. - Parameter clauses_of_list : list clause -> clauses. - Parameter list_of_clauses : clauses -> list clause. - - Inductive constraint_type := UnivEq | UnivLe. - Notation constraint := (LevelExprSet.nonEmptyLevelExprSet * constraint_type * LevelExprSet.nonEmptyLevelExprSet). - - Parameter enforce_constraint : forall (cstr : constraint) (cls : clauses), clauses. - - Parameter valid_model : forall (V : LevelSet.t) (m : model) (cls : clauses), Type. - - Parameter model_model : forall V m cls, valid_model V m cls -> model. - - (* { model_model : model; - model_of_V :> model_of V model_model; - model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; - model_ok :> is_model cls model_model; - model_extends : model_extension V m model_model; - }. *) - - Infix "⊂_lset" := LevelSet.Subset (at level 70). - - Parameter enforce_clauses : forall {V init cls} (m : valid_model V init cls) (cls' : clauses), option model. - - Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := - | Loop - | Model (w : LevelSet.t) (m : valid_model V m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). - - Parameter init_model : clauses -> model. - Parameter clauses_levels : clauses -> LevelSet.t. - - Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). - - Parameter infer : forall (cls : clauses), infer_result (clauses_levels cls) cls. - - Parameter print_result : forall {V cls}, infer_result V cls -> string. - - Parameter print_clauses : clauses -> string. - -End LoopCheckingItf. - -Module LoopChecking - (* Signature of levels: decidable, ordered type *) - (Level : LevelOrderedType) - (LevelSet : MSetInterface.SetsOn Level) - (LevelExpr : LevelExprItf Level) - (LevelExprSet : LevelExprSet_fun Level LevelExpr) - (LevelMap : FMapOTInterface Level) <: LoopCheckingItf Level LevelSet LevelExpr LevelExprSet LevelMap. - -Definition level (e : LevelExpr.t) : Level.t := fst e. -Definition levels (e : LevelExprSet.t) := - LevelExprSet.fold (fun le => LevelSet.add (level le)) e LevelSet.empty. - -Import LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). - -Local Existing Instance Level.reflect_eq. - -Module LevelSetFact := WFactsOn Level LevelSet. -Module LevelSetProp := WPropertiesOn Level LevelSet. -Module LevelSetDecide := LevelSetProp.Dec. -Module LevelMapFact := FMapFacts.WProperties_fun LevelMap.OT LevelMap. - -Ltac lsets := LevelSetDecide.fsetdec. -Notation "(=_lset)" := LevelSet.Equal (at level 0). -Infix "=_lset" := LevelSet.Equal (at level 30). -Infix "⊂_lset" := LevelSet.Subset (at level 70). -Infix "∪" := LevelSet.union (at level 70). - -Definition print_level_nat_map (m : LevelMap.t nat) := - let list := LevelMap.elements m in - print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_nat w) nl list. - -Definition print_lset (l : LevelSet.t) := - let list := LevelSet.elements l in - print_list Level.to_string " " list. - -Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. -Module LevelExprSetProp := WPropertiesOn LevelExpr LevelExprSet. - -(* We have decidable equality w.r.t leibniz equality for sets of levels. *) -#[global, program] Instance levelexprset_reflect : ReflectEq LevelExprSet.t := - { eqb := LevelExprSet.equal }. -Next Obligation. - destruct (LevelExprSet.equal x y) eqn:e; constructor. - eapply LevelExprSet.equal_spec in e. - now eapply LevelExprSet.eq_leibniz. - intros e'. - subst y. - pose proof (@LevelExprSetFact.equal_1 x x). - forward H. reflexivity. congruence. -Qed. - -#[global] Instance levelexprset_eq_dec : Classes.EqDec LevelExprSet.t := Classes.eq_dec. - -Derive NoConfusion for LevelExprSet.nonEmptyLevelExprSet. - -(* We use uip on the is_empty condition *) -#[global, program] Instance nonEmptyLevelExprSet_reflect : ReflectEq nonEmptyLevelExprSet := - { eqb x y := eqb x.(t_set) y.(t_set) }. -Next Obligation. - destruct (eqb_spec (t_set x) (t_set y)); constructor. - destruct x, y; cbn in *. subst. - now rewrite (uip t_ne0 t_ne1). - intros e; subst x; apply H. - reflexivity. -Qed. - -(** This coercion allows to see the non-empty set as a regular [LevelExprSet.t] *) -Coercion t_set : nonEmptyLevelExprSet >-> LevelExprSet.t. -Module LevelExprSetDecide := WDecide (LevelExprSet). -Ltac lesets := LevelExprSetDecide.fsetdec. -Infix "⊂_leset" := LevelExprSet.Subset (at level 70). - -Module NonEmptySetFacts. - #[program] Definition singleton (e : LevelExpr.t) : nonEmptyLevelExprSet - := {| t_set := LevelExprSet.singleton e |}. - Next Obligation. - apply negbTE. - eapply (contra_notN (P := LevelExprSet.Empty (LevelExprSet.singleton e))). - apply LevelExprSetFact.is_empty_2. intros ne. red in ne. specialize (ne e). lesets. - Qed. - - Lemma not_Empty_is_empty s : - ~ LevelExprSet.Empty s -> LevelExprSet.is_empty s = false. - Proof. - intro H. apply not_true_is_false. intro H'. - apply H. now apply LevelExprSetFact.is_empty_2 in H'. - Qed. - - Program Definition add (e : LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet - := {| t_set := LevelExprSet.add e u |}. - Next Obligation. - apply not_Empty_is_empty; intro H. - eapply H. eapply LevelExprSet.add_spec. - left; reflexivity. - Qed. - - Lemma add_spec e u e' : - LevelExprSet.In e' (add e u) <-> e' = e \/ LevelExprSet.In e' u. - Proof. - apply LevelExprSet.add_spec. - Qed. - - Definition add_list : list LevelExpr.t -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet - := List.fold_left (fun u e => add e u). - - Lemma add_list_spec l u e : - LevelExprSet.In e (add_list l u) <-> In e l \/ LevelExprSet.In e u. - Proof. - unfold add_list. rewrite <- fold_left_rev_right. - etransitivity. 2:{ eapply or_iff_compat_r. etransitivity. - 2: apply @InA_In_eq with (A:=LevelExpr.t). - eapply InA_rev. } - induction (List.rev l); cbn. - - split. intuition. intros [H|H]; tas. invs H. - - split. - + intro H. apply add_spec in H. destruct H as [H|H]. - * left. now constructor. - * apply IHl0 in H. destruct H as [H|H]; [left|now right]. - now constructor 2. - + intros [H|H]. inv H. - * apply add_spec; now left. - * apply add_spec; right. apply IHl0. now left. - * apply add_spec; right. apply IHl0. now right. - Qed. - - Lemma elements_not_empty {u : nonEmptyLevelExprSet} : LevelExprSet.elements u <> []. - Proof. - rewrite -LevelExprSetProp.elements_Empty. - move/LevelExprSetFact.is_empty_1. - destruct u as [u1 u2]; cbn in *. congruence. - Qed. - - Equations to_nonempty_list (u : nonEmptyLevelExprSet) : LevelExpr.t * list LevelExpr.t := - | u with inspect (LevelExprSet.elements u) := { - | exist [] eqel => False_rect _ (elements_not_empty eqel) - | exist (e :: l) _ => (e, l) }. - - Lemma singleton_to_nonempty_list e : to_nonempty_list (singleton e) = (e, []). - Proof. - funelim (to_nonempty_list (singleton e)). bang. - clear H. - pose proof (LevelExprSet.singleton_spec e1 e). - rewrite LevelExprSetFact.elements_iff in H. - rewrite InA_In_eq in H. rewrite e0 in H. - destruct H. forward H. now left. noconf H. f_equal. - pose proof (LevelExprSet.cardinal_spec (LevelExprSet.singleton e1)). rewrite e0 in H. cbn in H. - rewrite LevelExprSetProp.singleton_cardinal in H. - destruct l => //. - Qed. - - Lemma to_nonempty_list_spec u : - let '(e, u') := to_nonempty_list u in - e :: u' = LevelExprSet.elements u. - Proof. - funelim (to_nonempty_list u). bang. now rewrite e0. - Qed. - - Lemma to_nonempty_list_spec' u : - (to_nonempty_list u).1 :: (to_nonempty_list u).2 = LevelExprSet.elements u. - Proof. - pose proof (to_nonempty_list_spec u). - now destruct (to_nonempty_list u). - Qed. - - Lemma In_to_nonempty_list (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : - LevelExprSet.In e u - <-> e = (to_nonempty_list u).1 \/ In e (to_nonempty_list u).2. - Proof. - etransitivity. symmetry. apply LevelExprSet.elements_spec1. - pose proof (to_nonempty_list_spec' u) as H. - destruct (to_nonempty_list u) as [e' l]; cbn in *. - rewrite <- H; clear. etransitivity. apply InA_cons. - eapply or_iff_compat_l. apply InA_In_eq. - Qed. - - Lemma In_to_nonempty_list_rev (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : - LevelExprSet.In e u - <-> e = (to_nonempty_list u).1 \/ In e (List.rev (to_nonempty_list u).2). - Proof. - etransitivity. eapply In_to_nonempty_list. - apply or_iff_compat_l. apply in_rev. - Qed. - - Definition map (f : LevelExpr.t -> LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := - let '(e, l) := to_nonempty_list u in - add_list (List.map f l) (singleton (f e)). - - Lemma map_spec f u e : - LevelExprSet.In e (map f u) <-> exists e0, LevelExprSet.In e0 u /\ e = (f e0). - Proof. - unfold map. symmetry. etransitivity. - { eapply iff_ex; intro. eapply and_iff_compat_r. eapply In_to_nonempty_list. } - destruct (to_nonempty_list u) as [e' l]; cbn in *. - symmetry. etransitivity. eapply add_list_spec. - etransitivity. eapply or_iff_compat_l. apply LevelExprSet.singleton_spec. - etransitivity. eapply or_iff_compat_r. - apply in_map_iff. clear u. split. - - intros [[e0 []]|H]. - + exists e0. split. right; tas. congruence. - + exists e'. split; tas. left; reflexivity. - - intros [xx [[H|H] ?]]. - + right. congruence. - + left. exists xx. split; tas; congruence. - Qed. - - Program Definition non_empty_union (u v : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := - {| t_set := LevelExprSet.union u v |}. - Next Obligation. - apply not_Empty_is_empty; intro H. - assert (HH: LevelExprSet.Empty u). { - intros x Hx. apply (H x). - eapply LevelExprSet.union_spec. now left. } - apply LevelExprSetFact.is_empty_1 in HH. - rewrite t_ne in HH; discriminate. - Qed. - - - Lemma eq_univ (u v : nonEmptyLevelExprSet) : - u = v :> LevelExprSet.t -> u = v. - Proof. - destruct u as [u1 u2], v as [v1 v2]; cbn. intros X; destruct X. - now rewrite (uip_bool _ _ u2 v2). - Qed. - - Lemma eq_univ' (u v : nonEmptyLevelExprSet) : - LevelExprSet.Equal u v -> u = v. - Proof. - intro H. now apply eq_univ, LevelExprSet.eq_leibniz. - Qed. - - Lemma eq_univ'' (u v : nonEmptyLevelExprSet) : - LevelExprSet.elements u = LevelExprSet.elements v -> u = v. - Proof. - intro H. apply eq_univ. - destruct u as [u1 u2], v as [v1 v2]; cbn in *; clear u2 v2. - eapply LevelExprSet.eq_leibniz. red. - intros x. rewrite -!LevelExprSet.elements_spec1 H //. - Qed. - - Lemma univ_expr_eqb_true_iff (u v : nonEmptyLevelExprSet) : - LevelExprSet.equal u v <-> u = v. - Proof. - split. - - intros. - apply eq_univ'. now apply LevelExprSet.equal_spec. - - intros ->. now apply LevelExprSet.equal_spec. - Qed. - - Lemma univ_expr_eqb_comm (u v : nonEmptyLevelExprSet) : - LevelExprSet.equal u v <-> LevelExprSet.equal v u. - Proof. - transitivity (u = v). 2: transitivity (v = u). - - apply univ_expr_eqb_true_iff. - - split; apply eq_sym. - - split; apply univ_expr_eqb_true_iff. - Qed. - - - Lemma LevelExprSet_for_all_false f u : - LevelExprSet.for_all f u = false -> LevelExprSet.exists_ (negb ∘ f) u. - Proof. - intro H. rewrite LevelExprSetFact.exists_b. - rewrite LevelExprSetFact.for_all_b in H. - all: try now intros x y []. - induction (LevelExprSet.elements u); cbn in *; [discriminate|]. - apply andb_false_iff in H; apply orb_true_iff; destruct H as [H|H]. - left; now rewrite H. - right; now rewrite IHl. - Qed. - - Lemma LevelExprSet_For_all_exprs (P : LevelExpr.t -> Prop) (u : nonEmptyLevelExprSet) - : LevelExprSet.For_all P u - <-> P (to_nonempty_list u).1 /\ Forall P (to_nonempty_list u).2. - Proof. - etransitivity. - - eapply iff_forall; intro e. eapply imp_iff_compat_r. - apply In_to_nonempty_list. - - cbn; split. - + intro H. split. apply H. now left. - apply Forall_forall. intros x H0. apply H; now right. - + intros [H1 H2] e [He|He]. subst e; tas. - eapply Forall_forall in H2; tea. - Qed. - -End NonEmptySetFacts. -Import NonEmptySetFacts. - -Definition clause : Type := nonEmptyLevelExprSet × LevelExpr.t. - -Module Clause. - Definition t := clause. - - Definition eq : t -> t -> Prop := eq. - - Definition eq_equiv : RelationClasses.Equivalence eq := _. - - Inductive lt_ : t -> t -> Prop := - | lt_clause1 l e e' : LevelExpr.lt e e' -> lt_ (l, e) (l, e') - | lt_clause2 l l' b b' : LevelExprSet.lt l.(t_set) l'.(t_set) -> lt_ (l, b) (l', b'). - - Definition lt := lt_. - - Global Instance lt_strorder : RelationClasses.StrictOrder lt. - Proof. - constructor. - - intros x X; inversion X; subst. now eapply LevelExpr.lt_strorder in H1. - eapply LevelExprSet.lt_strorder; eassumption. - - intros x y z X1 X2; invs X1; invs X2; constructor; tea. - etransitivity; tea. - etransitivity; tea. - Qed. - - Definition lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt. - intros x x' H1 y y' H2. unfold lt. subst. reflexivity. - Qed. - - Definition compare (x y : t) : comparison := - match x, y with - | (l1, b1), (l2, b2) => - match LevelExprSet.compare l1.(t_set) l2.(t_set) with - | Eq => LevelExpr.compare b1 b2 - | x => x - end - end. - - Definition compare_spec : - forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y). - Proof. - intros [? ?] [? ?]; cbn; repeat constructor. - destruct (LevelExprSet.compare_spec n n0); repeat constructor; tas. - eapply LevelExprSet.eq_leibniz in H. apply NonEmptySetFacts.eq_univ in H. - subst. cbn in *. - destruct (LevelExpr.compare_spec t0 t1); repeat constructor; tas. now subst. - Qed. - - Global Instance reflect_t : ReflectEq t := reflect_prod _ _ . - - Definition eq_dec : forall (l1 l2 : t), {l1 = l2} + {l1 <> l2} := Classes.eq_dec. - - Definition eq_leibniz (x y : t) : eq x y -> x = y := id. -End Clause. - -Module Clauses := MSetAVL.Make Clause. -Module ClausesFact := WFactsOn Clause Clauses. -Module ClausesProp := WPropertiesOn Clause Clauses. -Module ClausesDecide := WDecide (Clauses). -Ltac clsets := ClausesDecide.fsetdec. - -Definition clauses := Clauses.t. - -Lemma filter_add {p x s} : Clauses.Equal (Clauses.filter p (Clauses.add x s)) (if p x then Clauses.add x (Clauses.filter p s) else Clauses.filter p s). -Proof. - intros i. - rewrite Clauses.filter_spec. - destruct (eqb_spec i x); subst; - destruct (p x) eqn:px; rewrite !Clauses.add_spec !Clauses.filter_spec; intuition auto || congruence. -Qed. - -Local Instance proper_fold_transpose {A} (f : Clauses.elt -> A -> A) : - transpose eq f -> - Proper (Clauses.Equal ==> eq ==> eq) (Clauses.fold f). -Proof. - intros hf s s' Hss' x ? <-. - eapply ClausesProp.fold_equal; tc; tea. -Qed. -Existing Class transpose. - -Lemma clauses_fold_filter {A} (f : Clauses.elt -> A -> A) (p : Clauses.elt -> bool) cls acc : - transpose Logic.eq f -> - Clauses.fold f (Clauses.filter p cls) acc = - Clauses.fold (fun elt acc => if p elt then f elt acc else acc) cls acc. -Proof. - intros hf. - symmetry. eapply ClausesProp.fold_rec_bis. - - intros s s' a eq. intros ->. - eapply ClausesProp.fold_equal; tc. auto. - intros x. - rewrite !Clauses.filter_spec. - now rewrite eq. - - now cbn. - - intros. - rewrite H1. - rewrite filter_add. - destruct (p x) eqn:px => //. - rewrite ClausesProp.fold_add //. - rewrite Clauses.filter_spec. intuition auto. -Qed. - -Definition levelexpr_level : LevelExpr.t -> Level.t := fst. -Coercion levelexpr_level : LevelExpr.t >-> Level.t. -Extraction Inline levelexpr_level. - -Definition strict_subset (s s' : LevelSet.t) := - LevelSet.Subset s s' /\ ~ LevelSet.Equal s s'. - -Lemma strict_subset_incl (x y z : LevelSet.t) : LevelSet.Subset x y -> strict_subset y z -> strict_subset x z. -Proof. - intros hs []. split => //. lsets. - intros heq. apply H0. lsets. -Qed. - -Lemma strict_subset_cardinal s s' : strict_subset s s' -> LevelSet.cardinal s < LevelSet.cardinal s'. -Proof. - intros []. - assert (LevelSet.cardinal s <> LevelSet.cardinal s'). - { intros heq. apply H0. - intros x. split; intros. now apply H. - destruct (LevelSet.mem x s) eqn:hin. - eapply LevelSet.mem_spec in hin. - auto. eapply LevelSetProp.FM.not_mem_iff in hin. - exfalso. - eapply LevelSetProp.subset_cardinal_lt in hin; tea. - lia. } - enough (LevelSet.cardinal s <= LevelSet.cardinal s') by lia. - now eapply LevelSetProp.subset_cardinal. -Qed. - -Definition premise (cl : clause) := fst cl. -Definition concl (cl : clause) := snd cl. -Extraction Inline premise concl. - -Definition clause_levels cl := - LevelSet.union (levels (premise cl)) (LevelSet.singleton (levelexpr_level (concl cl))). - -Definition clauses_levels (cls : clauses) : LevelSet.t := - Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls LevelSet.empty. - -Lemma Clauses_In_elements l s : - In l (Clauses.elements s) <-> Clauses.In l s. -Proof. - rewrite ClausesFact.elements_iff. - now rewrite InA_In_eq. -Qed. - -Lemma clauses_levels_spec_aux l cls acc : - LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls acc) <-> - (exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl)) \/ LevelSet.In l acc. -Proof. - eapply ClausesProp.fold_rec. - - intros. - intuition auto. destruct H1 as [k [hin hl]]. clsets. - - intros x a s' s'' hin nin hadd ih. - rewrite LevelSet.union_spec. - split. - * intros [hin'|]. - left. exists x. split => //. - apply hadd. now left. - apply ih in H. - intuition auto. - left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. - * intros [[k [ins'' ?]]|inacc]. - eapply hadd in ins''. destruct ins''; subst. - + now left. - + right. apply ih. now left; exists k. - + right. intuition auto. -Qed. - -Lemma clauses_levels_spec l cls : - LevelSet.In l (clauses_levels cls) <-> - exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl). -Proof. - unfold clauses_levels. - rewrite clauses_levels_spec_aux. - intuition auto. lsets. -Qed. - -Lemma clause_levels_spec l cl : - LevelSet.In l (clause_levels cl) <-> - LevelSet.In l (levels (premise cl)) \/ l = levelexpr_level (concl cl). -Proof. - unfold clause_levels. - now rewrite LevelSet.union_spec LevelSet.singleton_spec. -Qed. - -Definition model := LevelMap.t (option Z). - -Definition level_value (m : model) (level : Level.t) : option Z := - match LevelMap.find level m with - | None => None - | Some v => v - end. - -Definition levelexpr_value (m : model) (atom : LevelExpr.t) := - level_value m (levelexpr_level atom). - -Extraction Inline levelexpr_value. - -Definition min_atom_value (m : model) (atom : LevelExpr.t) := - let '(l, k) := atom in - match level_value m l with - | None => None - | Some val => Some (val - Z.of_nat k)%Z - end. - -Definition option_map2 {A} (f : A -> A -> A) (o o' : option A) : option A := - match o, o' with - | Some x, Some y => Some (f x y) - | None, Some _ - | Some _, None - | None, None => None - end. - -Definition min_premise (m : model) (l : nonEmptyLevelExprSet) : option Z := - let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (fun min atom => option_map2 Z.min (min_atom_value m atom) min) tl (min_atom_value m hd). - -Open Scope Z_scope. - -Definition satisfiable_atom (m : model) (atom : Level.t * nat) : bool := - let '(l, k) := atom in - match level_value m l with - | Some val => Z.of_nat k <=? val - | None => false - end. - -Definition satisfiable_premise (m : model) (l : nonEmptyLevelExprSet) := - LevelExprSet.for_all (satisfiable_atom m) l. - -(* Definition valid_clause (m : model) (cl : clause) := *) - (* implb (satisfiable_premise m (premise cl)) (satisfiable_atom m (concl cl)). *) -Definition level_value_above m l k := - match level_value m l with - | Some val => k <=? val - | None => false - end. - -Definition valid_clause (m : model) (cl : clause) := - let k0 := min_premise m (premise cl) in - match k0 with - | None => true - | Some k0 => - let (l, k) := concl cl in - level_value_above m l (Z.of_nat k + k0) - end. - -Definition is_model (cls : clauses) (m : model) : bool := - Clauses.for_all (valid_clause m) cls. - -Inductive update_result := - | VacuouslyTrue - | Holds - | DoesntHold (wm : LevelSet.t × model). - -Definition update_model (m : model) l v : model := LevelMap.add l (Some v) m. - -Definition update_value (wm : LevelSet.t × model) (cl : clause) : update_result := - let (w, m) := wm in - let k0 := min_premise m (premise cl) in - match k0 with - | None => VacuouslyTrue - | Some k0 => - let (l, k) := concl cl in - (* Does the conclusion also hold? - We optimize a bit here, rather than adding k0 in a second stage, - we do it already while checking the clause. In the paper, a second - pass computes this. - *) - if level_value_above m l (Z.of_nat k + k0) then Holds - else DoesntHold (LevelSet.add l w, update_model m l (Z.of_nat k + k0)) - end. - -Definition check_clause_model cl '(modified, wm) := - match update_value wm cl with - | VacuouslyTrue => (modified, wm) - | DoesntHold wm' => (true, wm') - | Holds => (modified, wm) - end. - -Definition check_model_aux (cls : clauses) (wm : LevelSet.t × model) : bool × (LevelSet.t × model) := - Clauses.fold check_clause_model cls (false, wm). - -(* If check_model = None then we have a model of all clauses, - othewise, we return Some (W', m') where W ⊂ W' and the model has - been updated for at least one atom l ∈ W'. *) -Definition check_model (cls : clauses) (wm : LevelSet.t × model) := - let '(modified, wm) := check_model_aux cls wm in - if modified then Some wm else None. - -Lemma check_model_aux_subset {cls w v} : - forall b w' v', check_model_aux cls (w, v) = (b, (w', v')) -> LevelSet.Subset w w'. -Proof. - intros w' v'. - unfold check_model, check_model_aux, check_clause_model. revert w' v'. - eapply ClausesProp.fold_rec => //. - { intros. noconf H0. reflexivity. } - intros x a s' s'' hin nin hadd IH. - intros b w' v'. destruct a. - destruct p as []. - unfold update_value. - destruct x as [prem [l k]]; cbn. - destruct min_premise as [k0|] eqn:hk0. - 2:apply IH. - destruct level_value_above. - - intros [= -> -> ->] => //. now eapply IH. - - intros [= <- <- <-]. intros x inx. - eapply LevelSet.add_spec. - specialize (IH _ _ _ eq_refl). - now right. -Qed. - -Lemma check_model_subset {cls w v} : - forall w' v', check_model cls (w, v) = Some (w', v') -> LevelSet.Subset w w'. -Proof. - intros w' v'. unfold check_model. - destruct check_model_aux eqn:cm. - destruct p as [W m]. - eapply check_model_aux_subset in cm. - destruct b => //. now intros [= <- <-]. -Qed. - -Definition premise_restricted_to W cl := - LevelSet.subset (levels (premise cl)) W. - -Definition clause_restricted_to W cl := - LevelSet.subset (levels (premise cl)) W && - LevelSet.mem (level (concl cl)) W. - -Definition restrict_clauses (cls : clauses) (W : LevelSet.t) := - Clauses.filter (clause_restricted_to W) cls. - -Lemma in_restrict_clauses (cls : clauses) (concls : LevelSet.t) cl : - Clauses.In cl (restrict_clauses cls concls) <-> - [/\ LevelSet.In (level (concl cl)) concls, - LevelSet.Subset (levels (premise cl)) concls & - Clauses.In cl cls]. -Proof. - unfold restrict_clauses. - rewrite Clauses.filter_spec. - destruct cl. cbn. - rewrite andb_true_iff LevelSet.subset_spec LevelSet.mem_spec. - firstorder auto. -Qed. - -Definition clauses_with_concl (cls : clauses) (concl : LevelSet.t) := - Clauses.filter (fun '(prem, concla) => LevelSet.mem (level concla) concl) cls. - -Lemma in_clauses_with_concl (cls : clauses) (concls : LevelSet.t) cl : - Clauses.In cl (clauses_with_concl cls concls) <-> - LevelSet.In (level (concl cl)) concls /\ Clauses.In cl cls. -Proof. - unfold clauses_with_concl. - rewrite Clauses.filter_spec. - destruct cl. rewrite LevelSet.mem_spec. cbn. firstorder eauto. -Qed. - -Definition clauses_conclusions (cls : clauses) : LevelSet.t := - Clauses.fold (fun cl acc => LevelSet.add (level (concl cl)) acc) cls LevelSet.empty. - -Lemma clauses_conclusions_spec a cls : - LevelSet.In a (clauses_conclusions cls) <-> - exists cl, Clauses.In cl cls /\ level (concl cl) = a. -Proof. - unfold clauses_conclusions. - eapply ClausesProp.fold_rec; clear. - - move=> s' he /=. rewrite LevelSetFact.empty_iff. - firstorder auto. - - move=> cl ls cls' cls'' hin hnin hadd ih. - rewrite LevelSet.add_spec. firstorder eauto. - specialize (H0 x). cbn in H0. - apply hadd in H1. firstorder eauto. - subst. left. now destruct x. -Qed. - -Lemma clauses_conclusions_clauses_with_concl cls concl : - LevelSet.Subset (clauses_conclusions (clauses_with_concl cls concl)) concl. -Proof. - intros x [cl []] % clauses_conclusions_spec. - eapply in_clauses_with_concl in H as []. - now rewrite H0 in H. -Qed. - -Lemma clauses_conclusions_restrict_clauses cls W : - LevelSet.Subset (clauses_conclusions (restrict_clauses cls W)) W. -Proof. - intros x [cl []] % clauses_conclusions_spec. - eapply in_restrict_clauses in H as []. - now rewrite H0 in H. -Qed. - -Definition in_clauses_conclusions (cls : clauses) (x : Level.t): Prop := - exists cl, Clauses.In cl cls /\ (level cl.2) = x. - -Definition v_minus_w_bound (W : LevelSet.t) (m : model) := - LevelMap.fold (fun w v acc => Z.max (option_get 0%Z v) acc) - (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0%Z. - -Definition levelexpr_k : LevelExpr.t -> nat := snd. -Coercion levelexpr_k : LevelExpr.t >-> nat. - -Definition level_expr_elt : LevelExprSet.elt -> LevelExpr.t := fun x => x. -Coercion level_expr_elt : LevelExprSet.elt >-> LevelExpr.t. - -Definition premise_min (l : nonEmptyLevelExprSet) : nat := - let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (B:=LevelExpr.t) (fun min atom => Nat.min atom min) tl hd. - -Definition gain (cl : clause) : Z := - Z.of_nat (levelexpr_k (concl cl)) - Z.of_nat (premise_min (premise cl)). - -Definition max_gain (cls : clauses) := - Clauses.fold (fun cl acc => Nat.max (Z.to_nat (gain cl)) acc) cls 0%nat. - -Definition model_same_domain (m m' : model) := - forall l, LevelMap.In l m <-> LevelMap.In l m'. - -#[local] Instance model_same_domain_refl : Reflexive model_same_domain. -Proof. intros m l. reflexivity. Qed. - -#[local] Instance model_same_domain_trans : Transitive model_same_domain. -Proof. intros m m' m'' h h' l. rewrite (h l). apply h'. Qed. - - -Inductive opt_le {A} (le : relation A) : relation (option A) := -| opt_le_some x y : le x y -> opt_le le (Some x) (Some y) -| opt_le_none_some x : opt_le le None x. -Derive Signature for opt_le. - -Instance opt_le_refl {A} (le : relation A) : Reflexive le -> Reflexive (opt_le le). -Proof. - intros hre x; induction x; constructor; reflexivity. -Qed. - -Instance opt_le_trans {A} (le : relation A) : Transitive le -> Transitive (opt_le le). -Proof. - intros hre x; induction x; destruct y as [y|]; intros z H H'; depelim H; depelim H'; constructor. - now transitivity y. -Qed. - -Definition value_le : relation (option Z) := opt_le Z.le. - -Infix "≤" := value_le (at level 50). - -Definition model_le (m m' : model) := - forall l k, LevelMap.MapsTo l k m -> - exists k', LevelMap.MapsTo l k' m' /\ k ≤ k'. - -Infix "⩽" := model_le (at level 70). (* \leqslant *) - -Definition model_map_outside V (m m' : model) := - forall l, ~ LevelSet.In l V -> - forall k, LevelMap.MapsTo l k m <-> LevelMap.MapsTo l k m'. - -#[local] Instance model_map_outside_refl V : Reflexive (model_map_outside V). -Proof. intros m l. reflexivity. Qed. - -#[local] Instance model_map_outside_trans V : Transitive (model_map_outside V). -Proof. - intros m m' m'' h h' l hnin k. - rewrite (h l hnin k). now apply h'. -Qed. - -(** The termination proof relies on the correctness of check_model: - it does strictly increase a value but not above [max_gain cls]. -*) - -Lemma clauses_conclusions_diff cls s : - clauses_conclusions (Clauses.diff cls (clauses_with_concl cls s)) ⊂_lset - LevelSet.diff (clauses_conclusions cls) s. -Proof. - intros a. rewrite LevelSet.diff_spec !clauses_conclusions_spec. - firstorder eauto. - exists x; split => //. - now rewrite Clauses.diff_spec in H. - intros ha. - rewrite Clauses.diff_spec in H; destruct H as []. - apply H1. - rewrite in_clauses_with_concl. split => //. - now rewrite H0. -Qed. - -Lemma diff_eq U V : LevelSet.diff V U =_lset V <-> LevelSet.inter V U =_lset LevelSet.empty. -Proof. split. lsets. lsets. Qed. - -Lemma levelset_neq U V : LevelSet.equal U V = false -> ~ LevelSet.Equal U V. -Proof. intros eq heq % LevelSet.equal_spec. congruence. Qed. - -Lemma levelset_union_same U : LevelSet.union U U =_lset U. -Proof. lsets. Qed. - -Class Commutative {A} (f : A -> A -> A) := comm : forall x y, f x y = f y x. -Instance option_map_2_comm {A} f : @Commutative A f -> @Commutative (option A) (option_map2 f). -Proof. - intros com [x|] [y|] => //=. now rewrite comm. -Qed. - -Instance Zmin_comm : Commutative Z.min := Z.min_comm. -Instance Zmax_comm : Commutative Z.max := Z.max_comm. - -Class Associative {A} (f : A -> A -> A) := assoc : forall x y z, f x (f y z) = f (f x y) z. -Instance option_map_2_assoc {A} f : @Associative A f -> @Associative (option A) (option_map2 f). -Proof. - intros assoc [x|] [y|] [z|]; cbn => //. now rewrite assoc. -Qed. - -Instance Zmin_assoc : Associative Z.min := Z.min_assoc. -Instance Zmax_assoc : Associative Z.max := Z.max_assoc. - -Lemma fold_left_comm {A B} (f : B -> A -> B) (l : list A) (x : A) (acc : B) : - (forall x y z, f (f z x) y = f (f z y) x) -> - fold_left f l (f acc x) = f (fold_left f l acc) x. -Proof. - intros. - induction l in acc, x |- *; cbn. auto. - rewrite -IHl. f_equal. now rewrite H. -Qed. - -Lemma fold_left_min_opt_comm {A} (f : A -> A -> A) l x acc : - Associative f -> Commutative f -> - fold_left (option_map2 f) l (option_map2 f acc x) = option_map2 f (fold_left (option_map2 f) l acc) x. -Proof. - intros ass c. rewrite fold_left_comm => //. - intros. rewrite -(assoc (f := option_map2 f)). - rewrite -(assoc (f := option_map2 f) z y x0). - f_equal. apply comm. -Qed. - -Lemma fold_left_le {A} {le} (f g : A -> LevelSet.elt -> A) l : - (forall acc acc' x, In x l -> le acc acc' -> le (f acc x) (g acc' x)) -> - forall acc acc', le acc acc' -> - le (fold_left f l acc) (fold_left g l acc'). -Proof. - intros hfg. - induction l => //. cbn. intros. - apply IHl. intros. apply hfg => //. now right. apply hfg => //. now left. -Qed. - -Local Open Scope nat_scope. -Lemma fold_left_ne_lt (f g : nat -> LevelSet.elt -> nat) l acc : - (forall (x y : LevelSet.elt) z, f (f z x) y = f (f z y) x) -> - (forall (x y : LevelSet.elt) z, g (g z x) y = g (g z y) x) -> - l <> [] -> - (forall acc acc' x, In x l -> (acc <= acc') -> (f acc x <= g acc' x)) -> - (forall acc acc' x, In x l -> (acc < acc') -> (f acc x < g acc' x)) -> - (exists x, In x l /\ forall acc acc', (acc <= acc') -> (f acc x < g acc' x)) -> - fold_left f l acc < fold_left g l acc. -Proof. - intros hf hg. - generalize (Nat.le_refl acc). - generalize acc at 2 4. - induction l in acc |- * => //. - intros. - destruct l; cbn. - { destruct H3 as [x []]. cbn in H3. destruct H3; subst => //. - now eapply (H4 acc acc0). } - cbn in IHl. - rewrite hf hg. - rewrite fold_left_comm //. rewrite (fold_left_comm g) //. - destruct H3 as [min [hmin hfg]]. - destruct hmin as [<-|hel]. - - apply hfg. apply fold_left_le => //. intros; eapply H1 => //. now right; right. - apply H1 => //. now right; left. - - apply H2. now left. eapply IHl => //. - * intros acc1 acc' x hin. apply (H1 acc1 acc' x). now right. - * intros acc1 acc' x hin. apply (H2 acc1 acc' x). now right. - * exists min. split => //. -Qed. -Close Scope nat_scope. - -Infix "↓" := clauses_with_concl (at level 70). (* \downarrow *) -Infix "⇂" := restrict_clauses (at level 70). (* \downharpoonright *) - -Lemma clauses_conclusions_diff_left cls W cls' : - clauses_conclusions (Clauses.diff (cls ↓ W) cls') ⊂_lset W. -Proof. - intros l. - rewrite clauses_conclusions_spec. - move=> [] cl. rewrite Clauses.diff_spec => [] [] []. - move/in_clauses_with_concl => [] hin ? ? eq. - now rewrite eq in hin. -Qed. - -Lemma clauses_conclusions_diff_restrict cls W cls' : - clauses_conclusions (Clauses.diff (cls ⇂ W) cls') ⊂_lset W. -Proof. - intros l. - rewrite clauses_conclusions_spec. - move=> [] cl. rewrite Clauses.diff_spec => [] [] []. - move/in_restrict_clauses => [] hin ? ? ? eq. - now rewrite eq in hin. -Qed. - -Lemma LevelSet_In_elements l s : - In l (LevelSet.elements s) <-> LevelSet.In l s. -Proof. - rewrite LevelSetFact.elements_iff. - now rewrite InA_In_eq. -Qed. - -Lemma clauses_empty_eq {s} : Clauses.Empty s -> Clauses.Equal s Clauses.empty. -Proof. clsets. Qed. - -Lemma update_value_valid {W m cl} : - match update_value (W, m) cl with - | VacuouslyTrue | Holds => valid_clause m cl - | DoesntHold _ => ~~ valid_clause m cl - end. -Proof. - unfold update_value, valid_clause. - destruct cl as [prem [l k]]; cbn. - destruct min_premise => //. - unfold level_value_above. - destruct level_value => //. - destruct Z.leb => //. -Qed. - -Lemma valid_update_value {W m cl} : - valid_clause m cl -> - match update_value (W, m) cl with - | VacuouslyTrue | Holds => true - | DoesntHold _ => false - end. -Proof. - unfold update_value, valid_clause. - destruct cl as [prem [l k]]; cbn. - destruct min_premise => //. - unfold level_value_above. - destruct level_value => //. - destruct Z.leb => //. -Qed. - -Lemma check_model_aux_false {cls acc acc'} : check_model_aux cls acc = (false, acc') -> acc = acc'. -Proof. - unfold check_model_aux, check_clause_model. - eapply ClausesProp.fold_rec. - - intros s emp [=] => //. - - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. - intros IH. - destruct update_value eqn:upd => //. -Qed. - -(* Lemma check_model_aux_true {cls acc acc'} : check_model_aux cls acc = (true, acc') -> acc = acc'. -Proof. - unfold check_model_aux. - eapply ClausesProp.fold_rec. - - intros s emp [=] => //. - - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. - intros IH. - destruct update_value eqn:upd => //. -Qed. *) - -Lemma check_model_aux_model {cls acc} : - check_model_aux cls acc = (false, acc) <-> is_model cls acc.2. -Proof. - unfold check_model_aux, check_clause_model. - unfold is_model. - unfold is_true; rewrite -ClausesFact.for_all_iff. - eapply ClausesProp.fold_rec. - - intros s emp. - split => //. - intros [=] x hx. clsets. - - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. - intros IH. - split. - * move: (@update_value_valid w' m' cl). - destruct update_value eqn:upd => //; intros vcl [= -> <-] ; - destruct IH as [IH _]; specialize (IH eq_refl). - intros x hx; apply incls'' in hx as []; subst. exact vcl. now apply IH. - intros x hx; apply incls'' in hx as []; subst. exact vcl. now apply IH. - * intros hf. - assert (valid_clause acc.2 cl). - { apply hf. apply incls''. intuition auto. } - destruct IH as [_ IH]. forward IH. - { intros x hx. apply hf. apply incls''. now right. } - noconf IH. - move: (@valid_update_value w' m' cl H). - destruct update_value eqn:upd => //. -Qed. - -Lemma clauses_for_all_neg {p s}: - ~~ Clauses.for_all p s <-> ~ Clauses.For_all p s. -Proof. - intuition auto. - rewrite ClausesFact.for_all_iff in H0. red in H. now rewrite H0 in H. - revert H. apply contra_notN. - rewrite ClausesFact.for_all_iff //. -Qed. - -Lemma clauses_for_all_exists {p s}: - ~~ Clauses.for_all p s <-> Clauses.exists_ (fun x => ~~ p x) s. -Proof. - rewrite ClausesFact.for_all_b ClausesFact.exists_b. - induction (Clauses.elements s). - - cbn; auto. reflexivity. - - cbn. rewrite negb_and. intuition auto. - move/orP: H1 => [->|] //. move/H. intros ->. now rewrite orb_true_r. - move/orP: H1 => [->|] //. move/H0. intros ->. now rewrite orb_true_r. -Qed. -#[local] Instance model_le_refl : Reflexive model_le. -Proof. intros x l k map. exists k; split => //. reflexivity. Qed. - -#[local] Instance model_le_trans : Transitive model_le. -Proof. intros m m' m'' mm' m'm'' l k map. - apply mm' in map as [k' [map ?]]. - apply m'm'' in map as [k'' [map ?]]. exists k''. split => //. - now transitivity k'. -Qed. - -Lemma update_model_monotone m l k : level_value m l ≤ Some k -> m ⩽ update_model m l k. -Proof. - intros hl. - intros l' k' maps. - unfold update_model. cbn. - destruct (eqb_spec l l'). - - subst l'. exists (Some k). move: hl. - unfold level_value. - rewrite (LevelMap.find_1 maps). - intros hle. - split => //. eapply LevelMap.add_1. eapply LevelMap.OT.eq_refl. - - exists k'. split => //. apply LevelMap.add_2 => //. reflexivity. -Qed. - -Lemma update_model_not_above m l k : level_value_above m l k = false -> m ⩽ update_model m l k. -Proof. - unfold level_value_above. - intros hlev. - apply update_model_monotone. - destruct level_value as [v|] eqn:hv; constructor; lia. -Qed. - -Lemma check_clause_model_inv {cl modified w m b wm'} : - check_clause_model cl (modified, (w, m)) = (b, wm') -> - m ⩽ wm'.2. -Proof. - unfold check_clause_model. - destruct (update_value (w, m) cl) eqn:upd. - * now intros [= <- <-]. - * now intros [= <- <-]. - * intros [= <- <-]. - move: upd. - unfold update_value. - destruct cl as [prem [l k]] => /=. - destruct min_premise as [k0|] eqn:hmin => //. - destruct level_value_above eqn:hval => //. - intros [= <-]. cbn. - now eapply update_model_not_above. -Qed. - -Lemma check_clause_model_intact {cl modified w m wm'} : - check_clause_model cl (modified, (w, m)) = (false, wm') -> valid_clause m cl /\ wm' = (w, m). -Proof. - unfold check_clause_model. - move: (@update_value_valid w m cl). - destruct (update_value (w, m) cl) eqn:upd. - * intros valid [= -> <-]. split => //. - * intros valid [= -> <-]. split => //. - * intros _ [=]. -Qed. - -Lemma check_clause_model_modify {cl w m wm'} : - check_clause_model cl (false, (w, m)) = (true, wm') -> ~~ valid_clause m cl. -Proof. - unfold check_clause_model. - destruct (update_value (w, m) cl) eqn:upd. - * now intros [= <- <-]. - * now intros [= <- <-]. - * intros [= <-]. - move: upd. - unfold update_value, valid_clause. - destruct min_premise as [k0|] eqn:hmin => //. - destruct cl as [prem [l k]] => /=. - unfold level_value_above. - destruct level_value as [val|] eqn:hval => //. - case: Z.leb_spec => //. -Qed. - -Lemma check_model_aux_model_le {cls acc acc' b} : - check_model_aux cls acc = (b, acc') -> acc.2 ⩽ acc'.2. -Proof. - unfold check_model_aux. - revert b acc'. - eapply ClausesProp.fold_rec. - - intros s emp b acc'. intros [=]. subst. reflexivity. - - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. - intros IH b acc'. - move/check_clause_model_inv. - specialize (IH _ _ eq_refl). cbn in IH. now intros; transitivity m'. -Qed. - -Lemma level_value_update_model m l k : - level_value (update_model m l k) l = Some k. -Proof. - unfold level_value, update_model. - cbn -[LevelMap.find LevelMap.add]. - rewrite LevelMapFact.F.add_o. - destruct LevelMap.OT.eq_dec => //. - exfalso. now apply n. -Qed. - - -Lemma model_map_outside_weaken {W W'} {m m' : model} : - model_map_outside W m m' -> - W ⊂_lset W' -> - model_map_outside W' m m'. -Proof. - intros hm sub x hin k. - apply hm. intros hin'. apply sub in hin'. now apply hin. -Qed. - -Lemma is_model_union {cls cls' m} : - is_model cls m -> is_model cls' m -> is_model (Clauses.union cls cls') m. -Proof. - rewrite /is_model. rewrite /is_true -!ClausesFact.for_all_iff. - now move=> ism ism' x /Clauses.union_spec []. -Qed. - -#[local] Instance Clauses_For_All_proper : Proper (eq ==> Clauses.Equal ==> iff) Clauses.For_all. -Proof. - intros x y -> cl cl' eqcl. - unfold Clauses.For_all. now setoid_rewrite eqcl. -Qed. - -#[local] Instance Clauses_for_all_proper : Proper (eq ==> Clauses.Equal ==> eq) Clauses.for_all. -Proof. - intros x y -> cl cl' eqcl. - apply iff_is_true_eq_bool. - rewrite /is_true -!ClausesFact.for_all_iff. now rewrite eqcl. -Qed. - -#[local] Instance is_model_proper : Proper (Clauses.Equal ==> eq ==> eq) is_model. -Proof. - intros cl cl' eqcl x y ->. unfold is_model. now rewrite eqcl. -Qed. - -Lemma model_le_values {m m' : model} x : m ⩽ m' -> level_value m x ≤ level_value m' x. -Proof. - intros lem. specialize (lem x). - unfold level_value. - destruct LevelMap.find eqn:hl => //. - - apply LevelMap.find_2 in hl. specialize (lem _ hl) as [k' [mapsto leq]]. - now rewrite (LevelMap.find_1 mapsto). - - constructor. -Qed. - -Lemma level_value_MapsTo {l k} {m : model} : - LevelMap.MapsTo l k m -> level_value m l = k. -Proof. - unfold level_value. - move=> mapto; rewrite (LevelMap.find_1 mapto) //. -Qed. - -Infix "⊂_clset" := Clauses.Subset (at level 70). - -Lemma max_gain_in cl cls : - Clauses.In cl cls -> - (Z.to_nat (gain cl) <= max_gain cls)%nat. -Proof. - intros hin. - unfold max_gain. revert cl hin. - eapply ClausesProp.fold_rec. - - intros s' ise hin. firstorder eauto. - - intros x a s' s'' xs nxs' hadd IH cl' hin'. - eapply hadd in hin' as []. - * subst x. lia. - * specialize (IH _ H). lia. -Qed. - -Definition max_gain_subset (cls cls' : Clauses.t) : - cls ⊂_clset cls' -> - (max_gain cls <= max_gain cls')%nat. -Proof. - unfold max_gain at 1. - revert cls'. - eapply ClausesProp.fold_rec. - - intros s' ise sub. lia. - - intros x a s' s'' xs nxs' hadd IH cls'' hs. - specialize (IH cls''). forward IH. transitivity s'' => //. - intros ??. now apply hadd. - assert (incls'' : Clauses.In x cls''). - { now apply hs, hadd. } - apply max_gain_in in incls''. lia. -Qed. - -Notation cls_diff cls W := (Clauses.diff (cls ↓ W) (cls ⇂ W)) (only parsing). - -(* - Equations? extend_model {W cls} (m : valid_model W (cls ⇂ W)) - (r : result W (Clauses.diff (cls ↓ W) (cls ⇂ W))) - : result W (cls ↓ W) := - extend_model _ Loop := Loop; - extend_model m (Model w m' sub) := - Model w {| model_model := m'.(model_model) |} _. - Proof. - - apply LevelSet.subset_spec in sub. now apply clauses_conclusions_clauses_with_concl in H. - - eapply sub. now eapply m.(model_clauses_conclusions). - - apply m. - - eapply LevelSet.subset_spec. eapply LevelSet.subset_spec in sub. - now transitivity V. - Qed. - - *) - -Lemma not_mem l s : ~~ LevelSet.mem l s <-> ~ LevelSet.In l s. -Proof. - split. apply contraNnot. apply LevelSet.mem_spec. - eapply contra_notN; tea. now move/LevelSet.mem_spec. -Qed. - -Lemma v_minus_w_bound_irrel {W} m m' : - model_map_outside W m m' -> - v_minus_w_bound W m = v_minus_w_bound W m'. -Proof. - unfold v_minus_w_bound. - intros out. eapply LevelMapFact.fold_Equal. tc. cbn. - { intros x y eq. cbn. solve_proper. } - { intros x y. cbn. intros e e' a neq. lia. } - apply LevelMapFact.F.Equal_mapsto_iff. - intros k e. rewrite -> LevelMapFact.filter_iff. - 2:{ intros x y eq. red in eq. subst; solve_proper. } - rewrite -> LevelMapFact.filter_iff. - 2:{ move=> x y ->. solve_proper. } - rewrite [_ = true]not_mem. intuition auto. - - now apply out. - - now apply out. -Qed. - -Definition max_premise_value (m : model) (l : nonEmptyLevelExprSet) : option Z := - let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (fun min atom => option_map2 Z.max (levelexpr_value m atom) min) tl (levelexpr_value m hd). - -Definition non_W_atoms W (l : LevelExprSet.t) := - LevelExprSet.filter (fun lk => ~~ LevelSet.mem lk.1 W) l. - -Lemma non_W_atoms_spec W l : forall x, LevelExprSet.In x (non_W_atoms W l) <-> LevelExprSet.In x l /\ ~ LevelSet.In x.1 W. -Proof. - intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec -not_mem. -Qed. - -Lemma non_W_atoms_subset W l : non_W_atoms W l ⊂_leset l. -Proof. intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec. Qed. - -Lemma levelexprset_levels_spec_aux l (e : LevelExprSet.t) acc : - LevelSet.In l (LevelExprSet.fold (fun le : LevelExprSet.elt => LevelSet.add (level le)) e acc) <-> - (exists k, LevelExprSet.In (l, k) e) \/ LevelSet.In l acc. -Proof. - eapply LevelExprSetProp.fold_rec. - - intros. - intuition auto. destruct H1 as [k hin]. lesets. - - intros x a s' s'' hin nin hadd ih. - rewrite LevelSet.add_spec. - split. - * intros [->|]. - left. exists (levelexpr_k x). - apply hadd. cbn. left. now destruct x. - apply ih in H. - intuition auto. - left. destruct H0 as [k Hk]. exists k. apply hadd. now right. - * intros [[k ins'']|inacc]. - eapply hadd in ins''. destruct ins''; subst. - + now left. - + right. apply ih. now left; exists k. - + right. intuition auto. -Qed. - -Lemma levelexprset_levels_spec l (e : LevelExprSet.t) : - LevelSet.In l (levels e) <-> exists k, LevelExprSet.In (l, k) e. -Proof. - rewrite levelexprset_levels_spec_aux. intuition auto. lsets. -Qed. - -Lemma levels_exprs_non_W_atoms {W prem} : - LevelSet.Equal (levels (non_W_atoms W prem)) (LevelSet.diff (levels prem) W). -Proof. - intros e. unfold non_W_atoms. - rewrite levelexprset_levels_spec LevelSet.diff_spec levelexprset_levels_spec. - firstorder eauto. - rewrite LevelExprSet.filter_spec in H. now exists x. - rewrite LevelExprSet.filter_spec in H. destruct H. - rewrite LevelSetFact.not_mem_iff. - destruct LevelSet.mem => //. - exists x. - rewrite LevelExprSet.filter_spec. split => //. - rewrite LevelSetFact.not_mem_iff in H0. now rewrite H0. -Qed. - -Lemma levelexprset_empty_levels x : LevelExprSet.Empty x <-> LevelSet.Empty (levels x). -Proof. - split. - - intros he. - intros l hin. - eapply levelexprset_levels_spec in hin as [k hin]. lesets. - - intros emp l hin. eapply emp. eapply (levelexprset_levels_spec l.1). exists l.2. - now destruct l. -Qed. - -Lemma non_W_atoms_ne W cl cls : - Clauses.In cl (cls_diff cls W) -> - LevelExprSet.is_empty (non_W_atoms W (premise cl)) = false. -Proof. - intros x. - apply Clauses.diff_spec in x as [clw clr]. - eapply in_clauses_with_concl in clw as [clw incls]. - apply/negbTE. - apply/(contra_notN _ clr). - intros he. rewrite in_restrict_clauses. split => //. - epose proof (@levels_exprs_non_W_atoms W (premise cl)). - eapply LevelExprSetFact.is_empty_2 in he. - intros x hin. eapply levelexprset_empty_levels in he. rewrite H in he. - specialize (he x). rewrite LevelSet.diff_spec in he. intuition auto. - rewrite -LevelSet.mem_spec in H1 |- *. destruct LevelSet.mem; intuition auto. -Qed. - -Local Open Scope Z_scope. - -Section MoreNonEmpty. - - Import LevelExprSet. - Import NonEmptySetFacts. - - Lemma In_elements {x} {s : nonEmptyLevelExprSet} : In x s <-> List.In x (elements s). - Proof. - split. now move/LevelExprSetFact.elements_1/InA_In_eq. - now move/InA_In_eq/LevelExprSetFact.elements_2. - Qed. - - Notation min_opt := (option_map2 Z.min). - Lemma Zmin_opt_left x y : min_opt x y ≤ x. - Proof. - destruct x as [x|], y as [y|]; constructor. lia. - Qed. - - Lemma Zmin_opt_right x y : min_opt x y ≤ y. - Proof. - destruct x as [x|], y as [y|]; constructor. lia. - Qed. - - Lemma min_opt_spec x y z : min_opt x y = z -> (z = y \/ z = x). - Proof. - destruct x as [x|], y as [y|], z as [z|]; cbn; intuition auto. - - noconf H. pose proof (Zmin_irreducible x y). destruct H; intuition (f_equal; auto). - - noconf H. - Qed. - - Lemma min_premise_spec_aux (m : model) s k : - min_premise m s = k -> - (forall x, LevelExprSet.In x s -> (k ≤ min_atom_value m x)%Z) /\ - (exists x, LevelExprSet.In x s /\ k = min_atom_value m x). - Proof. - unfold min_premise. - move: (to_nonempty_list_spec s). - destruct (to_nonempty_list s). intros heq. - setoid_rewrite In_elements. rewrite -heq. clear s heq. - intros <-. - induction l. - - cbn. - split. intros x [->|] => //. reflexivity. - now exists t0; split => //. - - destruct IHl as [ha hex]. - split. - * intros x hin. - eapply (in_elt_inv x a [t0]) in hin as [<-|inih]. - { cbn. rewrite fold_left_comm. - { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } - apply Zmin_opt_left. } - specialize (ha _ inih). - cbn. rewrite fold_left_comm. - { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } - etransitivity; [apply Zmin_opt_right|assumption]. - * destruct hex as [minval [inmin ih]]. - cbn. rewrite fold_left_comm. - { intros x' y z. rewrite assoc. now rewrite (comm (min_atom_value m y)) -assoc. } - rewrite ih. - destruct (min_opt_spec (min_atom_value m a) (min_atom_value m minval) _ eq_refl). - { rewrite H. exists minval. cbn in inmin. split; [intuition|reflexivity]. } - { rewrite H. exists a. cbn in inmin. split; [intuition|reflexivity]. } - Qed. - - Lemma min_premise_spec (m : model) (s : nonEmptyLevelExprSet) : - (forall x, LevelExprSet.In x s -> min_premise m s ≤ min_atom_value m x) /\ - (exists x, LevelExprSet.In x s /\ min_premise m s = min_atom_value m x). - Proof. - now apply min_premise_spec_aux. - Qed. - - Lemma min_premise_subset (m : model) (s s' : nonEmptyLevelExprSet) : - LevelExprSet.Subset s s' -> - min_premise m s' ≤ min_premise m s. - Proof. - intros sub. - have [has [mins [ins eqs]]] := min_premise_spec m s. - have [has' [mins' [ins' eqs']]] := min_premise_spec m s'. - specialize (sub _ ins). specialize (has' _ sub). - now rewrite eqs. - Qed. - - Lemma premise_min_spec_aux s k : - premise_min s = k -> - (forall x, LevelExprSet.In x s -> (k <= x)%nat) /\ - (exists x, LevelExprSet.In x s /\ k = x). - Proof. - unfold premise_min. - move: (to_nonempty_list_spec s). - destruct (to_nonempty_list s). intros heq. - setoid_rewrite In_elements. rewrite -heq. clear s heq. - intros <-. - induction l. - - cbn. - split. intros x [->|] => //. - now exists t0; split => //. - - destruct IHl as [ha hex]. - split; intros. - eapply (in_elt_inv x a [t0]) in H as [<-|inih]. - cbn. rewrite fold_left_comm. unfold level_expr_elt in *; lia. unfold level_expr_elt in *; lia. - specialize (ha _ inih). - cbn. rewrite fold_left_comm. lia. lia. - destruct hex as [minval [inmin ih]]. - cbn. rewrite fold_left_comm. lia. - destruct (Nat.leb_spec a minval). - exists a. split; [intuition|]. rewrite -ih in H. unfold level_expr_elt in *; lia. - exists minval. - cbn in inmin; split; [intuition auto|]. lia. - Qed. - - Lemma premise_min_spec (s : nonEmptyLevelExprSet) : - (forall x, LevelExprSet.In x s -> premise_min s <= x)%nat /\ - (exists x, LevelExprSet.In x s /\ premise_min s = x). - Proof. - now apply premise_min_spec_aux. - Qed. - - Lemma premise_min_subset (s s' : nonEmptyLevelExprSet) : - LevelExprSet.Subset s s' -> - (premise_min s' <= premise_min s)%nat. - Proof. - intros sub. - have [has [mins [ins eqs]]] := premise_min_spec s. - have [has' [mins' [ins' eqs']]] := premise_min_spec s'. - specialize (sub _ ins). specialize (has' _ sub). - lia. - Qed. - - Lemma fold_comm_assoc x y z : option_map2 Z.max x (option_map2 Z.max y z) = - option_map2 Z.max y (option_map2 Z.max x z). - Proof. - now rewrite (assoc (f := option_map2 Z.max)) (comm (f := option_map2 Z.max) x y) -assoc. - Qed. - Notation max_opt := (option_map2 Z.max). - - Lemma max_opt_spec x y z : max_opt x y = Some z -> exists x' y', x = Some x' /\ y = Some y' /\ z = Z.max x' y'. - Proof. - destruct x as [x|], y as [y|]; cbn; intuition eauto; try noconf H. - exists x, y. auto. - Qed. - - (* Lemma Zmax_opt_left x y : x ≤ max_opt x y. *) - (* Proof. *) - (* destruct x as [x|], y as [y|]; try constructor. lia. *) - (* Qed. *) -(* - Lemma Zmax_opt_right x y : min_opt x y ≤ y. - Proof. - destruct x as [x|], y as [y|]; constructor. lia. - Qed. *) - - - Lemma max_premise_value_spec_aux (m : model) s k : - max_premise_value m s = Some k -> - (forall x, LevelExprSet.In x s -> exists k', levelexpr_value m x = Some k' /\ Some k' ≤ Some k) /\ - (exists x, LevelExprSet.In x s /\ Some k = levelexpr_value m x). - Proof. - unfold max_premise_value. - move: (to_nonempty_list_spec s). - destruct (to_nonempty_list s). intros heq. - setoid_rewrite In_elements. rewrite -heq. clear s heq. - induction l in k |- *. - - cbn. - intros eq. - split. intros x [->|] => //. exists k. split => //. reflexivity. - now exists t0; split => //. - - cbn. rewrite fold_left_comm. intros; apply fold_comm_assoc. - intros heq. apply max_opt_spec in heq as [y' [z' [eqa [eqf ->]]]]. - specialize (IHl _ eqf). destruct IHl as [ha hex]. - split; intros. - eapply (in_elt_inv x a [t0]) in H as [<-|inih]. - { exists y'; intuition eauto. constructor; lia. } - { specialize (ha _ inih) as [k' []]. exists k'; intuition eauto. constructor. depelim H0; lia. } - destruct hex as [maxval [inmax ih]]. - cbn. - destruct (Z.leb_spec z' y'). - exists a. split; [intuition|]. rewrite eqa. f_equal. lia. - exists maxval. cbn in inmax; split; [intuition auto|]. rewrite -ih. f_equal; lia. - Qed. - - Lemma max_premise_value_spec (m : model) (s : nonEmptyLevelExprSet) k : - max_premise_value m s = Some k -> - (forall x, LevelExprSet.In x s -> exists k', levelexpr_value m x = Some k' /\ Some k' ≤ Some k) /\ - (exists x, LevelExprSet.In x s /\ Some k = levelexpr_value m x). - Proof. - apply (max_premise_value_spec_aux m s). - Qed. -End MoreNonEmpty. - -Lemma min_premise_pos_spec {m prem k} : - min_premise m prem = Some k -> - forall x, LevelExprSet.In x prem -> Some (Z.of_nat (levelexpr_k x) + k)%Z ≤ levelexpr_value m x. -Proof. - pose proof (min_premise_spec m prem) as [amin [exmin [inminpre eqminpre]]]. - intros hprem x hin. - specialize (amin _ hin). - unfold min_atom_value in amin. - destruct x as [l k']; cbn in *. unfold levelexpr_value; cbn. - destruct (level_value m l) eqn:he. - - depelim amin. - rewrite H0 in hprem. depelim hprem. constructor. lia. - constructor. - rewrite H in hprem; depelim hprem. - - depelim amin. rewrite H in hprem. depelim hprem. -Qed. - -Definition equal_model (m m' : model) := LevelMap.Equal m m'. - -#[local] Instance equal_model_equiv : Equivalence equal_model. -Proof. unfold equal_model. - split; try econstructor; eauto. - red. intros. now symmetry. - red; intros. now transitivity y. -Qed. - -#[local] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. -Proof. - intros x y eqm l ? <-. unfold level_value. - unfold equal_model in eqm. - destruct LevelMap.find eqn:hl. - - eapply LevelMap.find_2 in hl. - rewrite eqm in hl. - eapply LevelMap.find_1 in hl. now rewrite hl. - - eapply LevelMapFact.F.not_find_in_iff in hl. - rewrite eqm in hl. - eapply LevelMapFact.F.not_find_in_iff in hl. - now rewrite hl. -Qed. - -Lemma v_minus_w_bound_spec W m : - forall x, ~ LevelSet.In x W -> level_value m x ≤ Some (v_minus_w_bound W m). -Proof. - intros x him. - unfold v_minus_w_bound. - set (fm := LevelMapFact.filter _ _). - replace (level_value m x) with (level_value fm x). - 2:{ unfold level_value. - destruct LevelMap.find eqn:hl => //. - eapply LevelMap.find_2 in hl. - subst fm. cbn in hl. - eapply LevelMapFact.filter_iff in hl as []. 2:tc. - rewrite (LevelMap.find_1 H) //. - destruct (LevelMap.find _ m) eqn:hl' => //. - eapply LevelMap.find_2 in hl'. - assert (LevelMap.MapsTo x o fm). - eapply LevelMapFact.filter_iff. tc. - split => //. now rewrite [_ = true]not_mem. - now rewrite (LevelMap.find_1 H) in hl. } - clearbody fm. - eapply LevelMapFact.fold_rec. - - intros m' em. unfold level_value. - destruct LevelMap.find eqn:hl => //. - eapply LevelMap.find_2 in hl. - now apply em in hl. constructor. - - intros k e a m' m'' map nin hadd. - red in hadd. - unfold level_value. cbn. - rewrite hadd LevelMapFact.F.add_o. - destruct LevelMap.OT.eq_dec. do 2 red in e0. subst x. - intros hf. destruct e; cbn; constructor. lia. - destruct LevelMap.find => hf; depelim hf; constructor; lia. -Qed. - -Lemma clauses_levels_restrict_clauses cls W : - LevelSet.Subset (clauses_levels (cls ⇂ W)) W. -Proof. - intros x [cl []] % clauses_levels_spec. - eapply in_restrict_clauses in H as [hconc hprem incl]. - eapply clause_levels_spec in H0 as []. apply hprem, H. now subst x. -Qed. - -Lemma clauses_conclusions_levels cls : - clauses_conclusions cls ⊂_lset clauses_levels cls. -Proof. - intros x. - rewrite clauses_conclusions_spec clauses_levels_spec. - setoid_rewrite clause_levels_spec. - firstorder auto. -Qed. - -Record model_extension W m m' := - { model_ext_le : m ⩽ m'; - model_ext_same_domain : model_same_domain m m'; - model_ext_same_outside : model_map_outside W m m' }. - -#[local] Instance model_ext_reflexive W : Reflexive (model_extension W). -Proof. - intros m; split; reflexivity. -Qed. - -#[local] Instance model_ext_transitive W : Transitive (model_extension W). -Proof. - intros m m' m'' h h'; split; (etransitivity; [apply h|apply h']). -Qed. - -Lemma model_extension_weaken W W' m m' : - W ⊂_lset W' -> - model_extension W m m' -> - model_extension W' m m'. -Proof. - intros leW []; split => //. - eapply model_map_outside_weaken; tea. -Qed. - -Lemma model_ext_trans_weaken W W' m m' m'' : - W ⊂_lset W' -> - model_extension W m m' -> - model_extension W' m' m'' -> - model_extension W' m m''. -Proof. - intros leW mext mext'. eapply model_extension_weaken in mext; tea. - now etransitivity; tea. -Qed. - -Definition check_model_invariants cls w m w' m' (modified : bool) := - if modified then - [/\ w ⊂_lset w', - w' ⊂_lset (LevelSet.union w (clauses_conclusions cls)), - exists cl, - let cll := (levelexpr_level (concl cl)) in - [/\ Clauses.In cl cls, ~~ valid_clause m cl, - LevelSet.In cll w' & - opt_le Z.lt (level_value m cll) (level_value m' cll)] & - model_extension w' m m'] - else (w, m) = (w', m'). - -#[local] Instance clauses_conclusions_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_conclusions. -Proof. - intros cls cls' eq x. - rewrite !clauses_conclusions_spec. now setoid_rewrite eq. -Qed. - -#[local] Instance And3P_proper : Proper (iff ==> iff ==> iff ==> iff) ssrbool.and3. -Proof. - repeat intro. split; intros []; split; intuition auto. -Qed. - -#[local] Instance And4P_proper : Proper (iff ==> iff ==> iff ==> iff ==> iff) ssrbool.and4. -Proof. - repeat intro. split; intros []; split; intuition auto. -Qed. - -#[local] Instance check_model_invariants_proper : - Proper (Clauses.Equal ==> eq ==> eq ==> eq ==> eq ==> eq ==> iff) check_model_invariants. -Proof. - intros cls cls' eqcls. - repeat intro; subst. - unfold check_model_invariants. - destruct y3 => //. - now setoid_rewrite <-eqcls. -Qed. - -Lemma min_atom_value_levelexpr_value m l a lv : min_atom_value m l = Some a -> levelexpr_value m l = Some lv -> (a <= (lv - Z.of_nat l))%Z. -Proof. - destruct l as [l k]; cbn. unfold levelexpr_value. cbn. destruct level_value => //. - intros [= <-] [= <-]. lia. -Qed. - -Lemma clauses_conclusions_add cl cls : - clauses_conclusions (Clauses.add cl cls) =_lset - (LevelSet.singleton (level (concl cl)) ∪ - clauses_conclusions cls). -Proof. - intros x. - rewrite LevelSet.union_spec !clauses_conclusions_spec. - setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.singleton_spec. - firstorder eauto. subst. now left. -Qed. - -Definition declared_model_level (m : model) l := LevelMap.In l m. - -Definition clause_conclusion cl := levelexpr_level (concl cl). - -Definition update_model_same_domain {m l k} : - declared_model_level m l -> - model_same_domain m (update_model m l k). -Proof. - unfold update_model, declared_model_level. - intros hin x. - rewrite LevelMapFact.F.add_in_iff. intuition auto. now subst. -Qed. - -Definition update_model_outside {m w l k} : - model_map_outside (LevelSet.add l w) m (update_model m l k). -Proof. - unfold update_model, model_map_outside. - intros l'. rewrite LevelSet.add_spec. - intros hin k'. - rewrite LevelMapFact.F.add_neq_mapsto_iff //. - intros heq. red in heq; subst l'. apply hin. now left. -Qed. - -Lemma opt_lt_le_trans x y z : - opt_le Z.lt x y -> - opt_le Z.le y z -> - opt_le Z.lt x z. -Proof. - intros [] H'; depelim H'; constructor. lia. -Qed. - -Lemma level_value_not_above_spec m l k : level_value_above m l k = false -> opt_le Z.lt (level_value m l) (Some k). -Proof. - unfold level_value_above; destruct level_value => // hlt; constructor. lia. -Qed. - -Lemma check_clause_model_modify' {cl cls w m w' m' w'' m'' modified modified'} : - check_model_invariants cls w m w' m' modified -> - declared_model_level m (clause_conclusion cl) -> - check_clause_model cl (modified, (w', m')) = (modified', (w'', m'')) -> - check_model_invariants (Clauses.add cl cls) w m w'' m'' modified'. -Proof. - intros inv declcl. - unfold check_clause_model. - destruct (update_value (w', m') cl) eqn:upd. - * intros [= <- <-]. subst. - destruct modified. 2:{ noconf inv. reflexivity. } - destruct inv. - split => //. - + rewrite clauses_conclusions_add; lsets. - + destruct H1 as [cl' []]. - exists cl'; split => //. now rewrite Clauses.add_spec. - * intros [= <- <-]. subst. - destruct modified. 2:{ noconf inv. reflexivity. } - destruct inv. - split => //. - + rewrite clauses_conclusions_add; lsets. - + destruct H1 as [cl' []]. - exists cl'; split => //. now rewrite Clauses.add_spec. - * intros [= <- ->]. - move: upd. - unfold update_value. - destruct min_premise as [hmin|] eqn:eqmin => //. - destruct cl as [prem [l k]] => /=. - destruct level_value_above eqn:hval => //. - intros [= <- <-]. - destruct modified; noconf inv. - { destruct inv. - split => //. - + lsets. - + rewrite clauses_conclusions_add. - intros x. rewrite LevelSet.add_spec !LevelSet.union_spec LevelSet.singleton_spec. - intuition eauto. cbn. apply H0 in H4. lsets. - + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. - destruct H1 as [cl []]; exists cl; split => //. eauto. eauto. - destruct (level_value m (concl cl)) as [vconcl|] eqn:hconcl; [|constructor]. - eapply opt_lt_le_trans; tea. - eapply model_le_values. - now eapply update_model_not_above. - + transitivity m'. - { eapply model_extension_weaken; tea. lsets. } - split. - { now eapply update_model_not_above. } - { eapply update_model_same_domain. - eapply H2, declcl. } - { eapply update_model_outside. } } - { split => //. - + lsets. - + rewrite clauses_conclusions_add. - intros x. rewrite LevelSet.add_spec !LevelSet.union_spec LevelSet.singleton_spec. - intuition eauto. - + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. - exists (prem, (l, k)). - split; tea; eauto. - - unfold valid_clause. cbn. now rewrite eqmin hval /=. - - cbn. rewrite level_value_update_model. now apply level_value_not_above_spec. - + split. - { now eapply update_model_not_above. } - { eapply update_model_same_domain. - eapply declcl. } - { eapply update_model_outside. } } -Qed. - -Definition model_of V (m : model) := - forall k, LevelSet.In k V -> LevelMap.In k m. - -Lemma model_of_subset V V' m : - model_of V m -> V' ⊂_lset V -> model_of V' m. -Proof. - rewrite /model_of. intros ih hv k. specialize (ih k). - now move/hv. -Qed. - -Definition total_model_of V (m : model) := - forall k, LevelSet.In k V -> exists x, LevelMap.MapsTo k (Some x) m. - -Lemma total_model_of_subset V V' m : - total_model_of V m -> V' ⊂_lset V -> total_model_of V' m. -Proof. - intros ih hv k. specialize (ih k). - now move/hv. -Qed. - -Lemma total_model_of_sub V m : total_model_of V m -> model_of V m. -Proof. - rewrite /total_model_of /model_of. - intros H k hin. specialize (H k hin) as [? ?]. - now exists (Some x). -Qed. -Coercion total_model_of_sub : total_model_of >-> model_of. - -Lemma clauses_conclusions_subset {cls cls'} : - Clauses.Subset cls cls' -> - clauses_conclusions cls ⊂_lset clauses_conclusions cls'. -Proof. - intros hsub x. rewrite !clauses_conclusions_spec. - intuition eauto. destruct H as [cl []]; exists cl; split; try clsets; auto. -Qed. - -Lemma check_model_aux_spec {cls w m w' m' modified} : - model_of (clauses_conclusions cls) m -> - check_model_aux cls (w, m) = (modified, (w', m')) -> - check_model_invariants cls w m w' m' modified. -Proof. - rewrite /check_model_aux /is_model. - revert modified w' m'. - eapply ClausesProp.fold_rec. - - intros s' e modified w' m' mof [= <- <- <-]. - split. - - intros x ? s' s'' inx nins' hadd ih modified w' m' mof. - destruct a as [modified'' [w'' m'']]. - assert (ms' : model_of (clauses_conclusions s') m). - { eapply model_of_subset; tea. - eapply clauses_conclusions_subset. red in hadd. intros ?. - specialize (hadd a). intuition auto. } - specialize (ih _ _ _ ms' eq_refl). - apply ClausesProp.Add_Equal in hadd. rewrite hadd. - eapply check_clause_model_modify' => //. - red. apply mof. - apply clauses_conclusions_spec. exists x; split => //. - apply hadd. clsets. -Qed. - -Lemma check_model_spec {cls w m w' m'} : - model_of (clauses_conclusions cls) m -> - check_model cls (w, m) = Some (w', m') -> - check_model_invariants cls w m w' m' true. -Proof. - intros mof. - unfold check_model. - destruct check_model_aux eqn:cm. - destruct p as []. - eapply check_model_aux_spec in cm => //. - destruct b => //. now intros [= <- <-]. -Qed. - -Lemma check_model_aux_not_model {cls w m w' m'} : - model_of (clauses_conclusions cls) m -> - check_model_aux cls (w, m) = (true, (w', m')) -> - ~~ is_model cls m. -Proof. - intros mof. - move/(check_model_aux_spec mof) => [] _ _ [cl [incl inval]] _ _ _. - unfold is_model. - apply clauses_for_all_neg. - intros hf. specialize (hf cl incl). cbn in hf. - rewrite /is_true hf in inval => //. -Qed. - -Lemma check_model_is_model {W cls m} : - model_of (clauses_conclusions cls) m -> - check_model cls (W, m) = None <-> is_model cls m. -Proof. - intros mof; unfold check_model, is_model. - destruct check_model_aux eqn:caux. - destruct b => //. intuition auto. congruence. - { destruct p; eapply check_model_aux_not_model in caux => //. - rewrite /is_model /= // in caux. now rewrite H in caux. } - intuition auto. - pose proof (check_model_aux_false caux). subst p. - now rewrite check_model_aux_model in caux. -Qed. - -Lemma check_model_update {W cls m wm'} : - model_of (clauses_conclusions cls) m -> - check_model cls (W, m) = Some wm' -> ~~ is_model cls m /\ m ⩽ wm'.2. -Proof. - intros mof; unfold check_model, is_model. - destruct check_model_aux eqn:caux. - destruct b => //. intros [= <-]. intuition auto. - destruct p. - now eapply check_model_aux_not_model in caux. - now eapply check_model_aux_model_le in caux. -Qed. - -Definition level_value_default m l := - match level_value m l with Some x => x | None => 0 end%Z. - -Definition measure_w W cls m w := - let bound := v_minus_w_bound W m in - let maxgain := max_gain (cls_diff cls W) in - (bound + Z.of_nat maxgain - level_value_default m w)%Z. - -Lemma min_premise_max_premise m prem k : - min_premise m prem = Some k -> - exists k', max_premise_value m prem = Some k'. -Proof. - unfold min_premise, max_premise_value. - destruct to_nonempty_list. - assert (forall l k, fold_left - (fun (min : option Z) (atom : LevelExpr.t) => - option_map2 Z.min (let '(l0, k0) := atom in match level_value m l0 with - | Some val => Some (val - Z.of_nat k0)%Z - | None => None - end) min) - l None = - Some k -> False). - { clear. induction l; cbn => //. cbn in *. - destruct a, level_value; cbn; auto. } - assert - (forall x y, fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.min (min_atom_value m atom) min) l (Some x) = Some k -> -exists k' : Z, - fold_left (fun (min : option Z) (atom : LevelExpr.t) => option_map2 Z.max (levelexpr_value m atom) min) l (Some y) = Some k'). - { induction l; cbn. - - intros x y [= <-]. now eexists. - - intros x y. - unfold min_atom_value, levelexpr_value, levelexpr_level. destruct a; cbn. - destruct level_value => //=. eapply IHl. cbn. intros H'. exfalso. - eapply H; eauto. } - - unfold min_atom_value, levelexpr_value, levelexpr_level. destruct t; cbn. - destruct level_value => //=. apply H0. - intros; exfalso. now eapply H. -Qed. - -Lemma total_model_of_value_None W m l : - total_model_of W m -> - LevelSet.In l W -> - level_value m l = None -> False. -Proof. - intros tm inw. specialize (tm l inw) as [v hm]. - rewrite /level_value. - now rewrite (LevelMap.find_1 hm). -Qed. - -Lemma invalid_clause_measure W cls cl m : - total_model_of W m -> - ~~ valid_clause m cl -> - Clauses.In cl (cls_diff cls W) -> - (0 < measure_w W cls m (concl cl))%Z. -Proof. - intros hwv. unfold valid_clause. - (* case: Z.ltb_spec => // hprem. *) - destruct cl as [prem [l k]]; cbn. - destruct min_premise eqn:hmin => //. - move/negbTE/level_value_not_above_spec => hlt hin. - have hne := (non_W_atoms_ne _ _ _ hin). - cbn. unfold measure_w. unfold gain. - set (clsdiff := Clauses.diff _ _). - set (bound := v_minus_w_bound W m). - enough (level_value_default m l < bound + Z.of_nat (max_gain clsdiff))%Z. lia. - set (prem' := non_W_atoms W prem). - set (preml := {| t_set := prem'; t_ne := hne |}). - assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff)%nat. - { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. - unfold gain. cbn. - pose proof (premise_min_subset preml prem). - rewrite !Z2Nat.inj_sub //; try lia. rewrite !Nat2Z.id. - forward H. eapply non_W_atoms_subset. lia. } - eapply Z.lt_le_trans with (bound + Z.of_nat (Z.to_nat (gain (preml, (l, k)))))%Z; try lia. - unfold gain; cbn. - enough (level_value_default m l < v_minus_w_bound W m + Z.of_nat (k - premise_min preml))%Z. lia. - unfold level_value_default. destruct (level_value m l) as [vl|] eqn:hl; revgoals. - { eapply total_model_of_value_None in hl; tea => //. - eapply Clauses.diff_spec in hin as [hin _]. - now apply in_clauses_with_concl in hin as [hin _]. } - depelim hlt. - enough (Z.of_nat k + z <= v_minus_w_bound W m + Z.of_nat (k - premise_min preml))%Z. lia. - assert (min_premise m prem ≤ min_premise m preml)%Z. - { eapply min_premise_subset. eapply non_W_atoms_subset. } - rewrite hmin in H1. depelim H1. - transitivity (Z.of_nat k + y)%Z. lia. - pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. - have [maxpreml eqmax] := min_premise_max_premise m preml _ H2. - pose proof (max_premise_value_spec m preml _ eqmax) as [amax [exmax [inmaxpre eqmaxpre]]]. - pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. - assert (premise_min prem <= premise_min preml)%nat. - { eapply premise_min_subset. eapply non_W_atoms_subset. } - (* transitivity (v_minus_w_bound W m + (k - premise_min preml)). 2:lia. *) - assert (y <= maxpreml - Z.of_nat (premise_min preml))%Z. - { rewrite eqpminpre. rewrite H2 in eqminpre; symmetry in eqminpre. - (* eqmaxpre eqminpre. *) - pose proof (min_atom_value_levelexpr_value m exmin). - specialize (amax _ inminpre) as amax'. rewrite eqmaxpre in amax'. - destruct amax' as [vexmin [eqexmin ltexmin]]. - assert (expmin <= exmin)%nat. specialize (apmin _ inminpre). lia. - specialize (H4 _ _ eqminpre eqexmin). depelim ltexmin. etransitivity; tea. - rewrite -eqmaxpre in H6. noconf H6. - unfold level_expr_elt in *. lia. } - transitivity (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)))%Z. lia. - (* assert (Z.of_nat (premise_min preml) <= maxpreml)%Z. - { rewrite eqmaxpre. - move/min_premise_pos_spec: hprem => hprem. - transitivity exmax. apply apmin => //. eapply hprem. - now apply (non_W_atoms_subset W prem). } *) - assert (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)) = - (maxpreml + Z.of_nat k - Z.of_nat (premise_min preml)))%Z as ->. lia. - enough (maxpreml <= v_minus_w_bound W m)%Z. lia. - { have vm := v_minus_w_bound_spec W m exmax. unfold levelexpr_value in eqmaxpre. - rewrite -eqmaxpre in vm. - have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). - rewrite levelexprset_levels_spec in hlevels. - forward hlevels. - exists exmax.2. now destruct exmax. - rewrite LevelSet.diff_spec in hlevels. - destruct hlevels as [_ nw]. specialize (vm nw). now depelim vm. } -Qed. - -Definition levelset_m_eq : LevelSet.t × model -> LevelSet.t × model -> Prop := - fun x y => LevelSet.Equal x.1 y.1 /\ LevelMap.Equal x.2 y.2. - -#[local] Instance lmeq_eq : Equivalence levelset_m_eq. -Proof. - split. intros x. split => //. - intros x y []; split => //. now rewrite H. - intros x y z [] []; split => //. - all:etransitivity; tea. -Qed. - -Definition modified_levelset_m_eq : bool × LevelSet.t × model -> bool × LevelSet.t × model -> Prop := - fun x y => x.1 = y.1 /\ levelset_m_eq x.2 y.2. - -#[local] Instance mlm_eq : Equivalence modified_levelset_m_eq. -Proof. - split. intros x. split => //. - intros x y []; split => //. now symmetry. - intros x y z [] []; split => //. all:etransitivity; tea. -Qed. - -#[local] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. -Proof. - intros m m' eqm ? ? ->. unfold min_atom_value. - destruct y => //. - now rewrite eqm. -Qed. - -#[local] Instance fold_left_ext {A B} : Proper (`≐2` ==> eq ==> eq ==> eq) (@fold_left A B). -Proof. - intros f g hfg ? ? -> ? ? ->. - induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). -Qed. - -#[local] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. -Proof. - intros m m' eq ? ? ->. - unfold min_premise. - destruct to_nonempty_list. - now setoid_rewrite eq. -Qed. - -#[local] Instance update_model_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> LevelMap.Equal) update_model. -Proof. - intros m m' hm ? ? -> ? ? ->. - unfold update_model. - now rewrite hm. -Qed. - -#[local] Instance level_value_above_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> eq) level_value_above. -Proof. - intros m m' hm ? ? -> ? ? ->. - unfold level_value_above. - now rewrite hm. -Qed. - -#[local] Instance check_clause_model_proper : Proper (eq ==> modified_levelset_m_eq ==> modified_levelset_m_eq) check_clause_model. -Proof. - intros x y eq [? []] [? []] []; cbn in *; subst. - unfold levelset_m_eq in H0. destruct H0; cbn in *; subst. - replace (min_premise m (premise y)) with (min_premise m0 (premise y)). - 2: now rewrite H0. - destruct min_premise. - destruct concl => //. - replace (level_value_above m t1 (Z.of_nat n + z)) with (level_value_above m0 t1 (Z.of_nat n + z)). - 2:now rewrite H0. - destruct level_value_above => //. - red. cbn. split => //. - red. cbn; split => //. now rewrite H. now rewrite H0. - red. cbn. split => //. -Qed. - -Module ClausesOrd := OrdProperties Clauses. - - -#[local] Instance check_model_aux_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model_aux. -Proof. - intros cls cls' eq. - intros wm wm' eq'. subst wm'. - unfold check_model_aux. - now eapply ClausesOrd.fold_equal; tc. -Qed. - -#[local] Instance check_model_aux_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> modified_levelset_m_eq) check_model_aux. -Proof. - intros cls cls' eq. - intros wm wm' eq'. - transitivity (check_model_aux cls' wm). - 2:{ unfold check_model_aux. - eapply (ClausesProp.fold_init (eqA := modified_levelset_m_eq)); tc. - red. cbn => //. } - unfold check_model_aux. - now eapply ClausesOrd.fold_equal; tc. -Qed. - -#[local] Instance check_model_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> R_opt levelset_m_eq) check_model. -Proof. - intros cls cls' eq. - intros wm wm' eq'. - unfold check_model. - destruct (check_model_aux cls wm) eqn:eqc. - destruct (check_model_aux cls' wm') eqn:eqc' => //. - pose proof (check_model_aux_proper cls cls' eq wm wm' eq'). - rewrite eqc eqc' in H. destruct H; cbn in *; subst. - red in H0. destruct H0. - destruct b0 => //. -Qed. - -#[local] Instance check_model_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model. -Proof. - intros cls cls' eq. - intros wm wm' eq'. - unfold check_model. - now subst wm'; rewrite eq. -Qed. - -Record valid_model_def (V : LevelSet.t) (m : model) (cls : clauses) := - { model_model : model; - model_of_V :> model_of V model_model; - model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; - model_ok :> is_model cls model_model; - model_extends : model_extension V m model_model; - }. -Arguments model_model {V m cls}. -Arguments model_of_V {V m cls}. -Arguments model_clauses_conclusions {V m cls}. -Arguments model_ok {V m cls}. -Arguments model_extends {V m cls}. -Extraction Inline model_model. - -Definition valid_model := valid_model_def. - -Inductive entails (cls : clauses) : clause -> Prop := -| clause_in (prems : nonEmptyLevelExprSet) (cl : LevelExpr.t) : LevelExprSet.In cl prems -> entails cls (prems, cl) -| clause_cut prems' concl' prems concl : - Clauses.In (prems', concl') cls -> - entails cls (add concl' prems, concl) -> - LevelExprSet.Subset prems' prems -> - entails cls (prems, concl). - -(* Definition succ_expr '((l, k) : LevelExpr.t) := (l, k + 1). -Definition succ_prems s := map (fun '(l, k) => (l, k + 1)) s. -Definition succ_clause '((prems, concl) : clause) := (succ_prems prems, succ_expr concl). -Lemma succ_clause_inj x y : succ_clause x = succ_clause y -> x = y. -Proof. Admitted. -Definition succ_clauses cls := ClausesProp.of_list (List.map (fun cl => succ_clause cl) (ClausesProp.to_list cls)). -Import SetoidList. -Lemma succ_clauses_spec cl cls : Clauses.In cl cls <-> Clauses.In (succ_clause cl) (succ_clauses cls). -Proof. - unfold succ_clauses. - rewrite ClausesProp.of_list_1 InA_In_eq in_map_iff. - firstorder eauto. - - exists cl; split => //. unfold ClausesProp.to_list. now eapply Clauses_In_elements. - - eapply Clauses_In_elements in H0. apply succ_clause_inj in H. now subst. -Qed. - -Lemma entails_plus cls c : entails cls c -> entails (succ_clauses cls) (succ_clause c). -Proof. - induction 1. - - constructor. apply map_spec. exists cl. split => //. - - eapply clause_cut with (succ_prems prems') (succ_expr concl'). - + now rewrite -(succ_clauses_spec (prems', concl')). - + admit. - + admit. -Admitted. - -Definition to_clauses (prems : nonEmptyLevelExprSet) (concl : nonEmptyLevelExprSet) : clauses := - LevelExprSet.fold (fun lk cls => Clauses.add (prems, lk) cls) concl Clauses.empty. - -Definition is_loop (cls : clauses) (t : nonEmptyLevelExprSet) := - let cls' := to_clauses t (succ_prems t) in - Clauses.For_all (fun cl' => entails cls cl') cls'. - *) -(* Definition is_looping (w : LevelSet.t) n (cls : clauses) := - let preml := LevelSet.elements w in - let prem := List.map (fun e => (e, n)) preml in - is_loop cls prem. *) - -Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := - | Loop - (* (w : LevelSet.t) (n : nat) (islooping : loop_on w n cls) *) - | Model (w : LevelSet.t) (m : valid_model V m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). -Arguments Loop {V U cls m}. -Arguments Model {V U cls m}. -Arguments lexprod {A B}. - -Definition option_of_result {V U m cls} (r : result V U m cls) : option model := - match r with - | Loop => None - | Model w m sub => Some m.(model_model) - end. - -Definition extends_model {W U cls m m'} : - m' ⩽ m -> - model_same_domain m' m -> - model_map_outside W m' m -> - result W U cls m -> result W U cls m'. -Proof. - intros leq ldom lout []. exact Loop. - econstructor 2; tea. - destruct m0. econstructor; tea. - - now transitivity m. -Qed. - -(* #[tactic="idtac"] -Equations? result_inclusion {V U m cls V'} (r : result V U cls m) - (prf : LevelSet.Subset V V') : result V' U cls m := - result_inclusion Loop _ := Loop; - result_inclusion (Model w m' sub) sub' := - Model w {| model_model := m'.(model_model) |} _. -Proof. - - - - transitivity V => //. now eapply m'.(model_clauses_conclusions). - - apply m'. - - apply m'. - - apply m'. - - intros x hin. apply m'. intros hv. - apply sub' in hv. now apply hin. - - intuition lsets. -Qed. *) - -Notation "#| V |" := (LevelSet.cardinal V). - -Notation loop_measure V W := (#|V|, #|V| - #|W|)%nat. - -Definition lexprod_rel := lexprod lt lt. - -#[local] Instance lexprod_rel_wf : WellFounded lexprod_rel. -Proof. - eapply (Acc_intro_generator 1000). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. -Defined. - -Section InnerLoop. - Context (V : LevelSet.t) (U : LevelSet.t) - (loop : forall (V' U' : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V', U' ⊂_lset V' & model_of V' m]), - lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls m). - - Definition sum_W W (f : LevelSet.elt -> nat) : nat := - LevelSet.fold (fun w acc => acc + f w)%nat W 0%nat. - - Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := - sum_W W (fun w => Z.to_nat (measure_w W cls m w)). - - Lemma maps_to_value_default {x k m} : LevelMap.MapsTo x k m -> level_value m x = k. - Proof. - intros h; apply LevelMap.find_1 in h. - now rewrite /level_value h. - Qed. - - Lemma measure_model W cls m : - total_model_of W m -> - let clsdiff := cls_diff cls W in - measure W cls m = 0%nat -> is_model clsdiff m. - Proof using. - clear loop V U. - unfold measure, sum_W, measure_w, is_model. - set (clsdiff := Clauses.diff _ _). - intros hv hm. - assert (LevelSet.For_all (fun w => Some (v_minus_w_bound W m + Z.of_nat (max_gain clsdiff)) ≤ level_value m w)%Z W). - { move: hm. - generalize (v_minus_w_bound W m) => vbound. - eapply LevelSetProp.fold_rec. - intros. intros x hin. firstorder eauto. - intros x a s' s'' inw nins' hadd ih heq. - forward ih by lia. - intros l hin. - specialize (hv _ inw) as [k lv]. rewrite /level_value_default (maps_to_value_default lv) in heq. - apply hadd in hin as []. - * subst x. rewrite (maps_to_value_default lv). constructor. lia. - * now apply ih. } - clear hm. - eapply ClausesFact.for_all_iff. tc. - intros cl hl. - unfold valid_clause. - destruct min_premise as [k0|] eqn:hk0 => //. - destruct cl as [prem [l k]] => /=. cbn in hk0. - rewrite /clsdiff in hl. - destruct (proj1 (Clauses.diff_spec _ _ _) hl) as [hlcls hl']. - eapply in_clauses_with_concl in hlcls as [lW incls]. - specialize (H _ lW). cbn -[clsdiff] in H. cbn in lW. - specialize (hv _ lW) as [vl hvl]. rewrite /level_value_above (maps_to_value_default hvl). - rewrite (maps_to_value_default hvl) in H; depelim H. - (* etransitivity; tea. *) - set (prem' := non_W_atoms W prem). - assert (ne : LevelExprSet.is_empty prem' = false). - { now eapply (non_W_atoms_ne W (prem, (l, k)) cls). } - set (preml := {| t_set := prem'; t_ne := ne |}). - assert (min_premise m prem ≤ min_premise m preml). - { eapply min_premise_subset. eapply non_W_atoms_subset. } - (* min_i (f(x_i)-k_i) <= max_i(f(x_i)) - min(k_i) *) - pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. - rewrite hk0 in H0. depelim H0. rename y into minpreml. - pose proof (min_premise_max_premise _ _ _ H1) as [maxpreml eqmaxp]. - pose proof (max_premise_value_spec m preml _ eqmaxp) as [amax [exmax [inmaxpre eqmaxpre]]]. - rewrite -eqmaxp in eqmaxpre. - pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. - assert (min_premise m preml ≤ Some (maxpreml - Z.of_nat (premise_min preml)))%Z. - { rewrite eqminpre in H1. - specialize (amax _ inminpre). destruct amax as [k' [lk' hk']]. - depelim hk'. - pose proof (min_atom_value_levelexpr_value m exmin _ _ H2 lk'). - rewrite eqminpre H2. constructor. etransitivity; tea. - rewrite eqmaxpre in eqmaxp. - assert (expmin <= exmin)%nat. specialize (apmin _ inminpre). lia. - unfold level_expr_elt in *. lia. } - apply Z.leb_le. rewrite H1 in H2. depelim H2. - transitivity (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)))%Z. lia. - assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff)%nat. - { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. - unfold gain. cbn. - pose proof (premise_min_subset preml prem). - rewrite !Z2Nat.inj_sub //; try lia. rewrite !Nat2Z.id. - forward H3. eapply non_W_atoms_subset. lia. } - transitivity (v_minus_w_bound W m + (gain (preml, (l, k))))%Z. - 2:lia. - unfold gain. cbn -[max_premise_value premise_min]. - (* assert (Z.of_nat (premise_min preml) <= maxpreml)%Z. - { - (* rewrite eqmaxpre. *) - move/min_premise_pos_spec: hk0 => hprem. - transitivity (Z.of_nat (levelexpr_k exmax)). - specialize (apmin _ inmaxpre). now apply inj_le. - rewrite eqmaxp in eqmaxpre. unfold levelexpr_value in eqmaxpre. - unfold levelexpr_k. - specialize (amax _ inmaxpre) as [k' [eqk' k'max]]. - eapply hprem. - now apply (non_W_atoms_subset W prem). } *) - assert (Z.of_nat k + (maxpreml - Z.of_nat (premise_min preml)) = - (maxpreml + Z.of_nat k - Z.of_nat (premise_min preml)))%Z as ->. lia. - (* rewrite Z2Nat.inj_sub. lia. *) - (* rewrite !Nat2Z.id. *) - assert (maxpreml <= v_minus_w_bound W m)%Z. - { pose proof (v_minus_w_bound_spec W m exmax). - have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). - rewrite levelexprset_levels_spec in hlevels. - forward hlevels. - exists exmax.2. now destruct exmax. - rewrite LevelSet.diff_spec in hlevels. - destruct hlevels. - forward H4 by auto. - rewrite eqmaxp in eqmaxpre. unfold levelexpr_value in eqmaxpre. rewrite -eqmaxpre in H4. - now depelim H4. - } - lia. - Qed. - - Lemma level_value_default_def {m x v} : level_value m x = Some v -> level_value_default m x = v. - Proof. unfold level_value_default. now intros ->. Qed. - - Lemma w_values_ext m m' W : - m ⩽ m' -> total_model_of W m -> total_model_of W m'. - Proof. - intros ext hf x hin. - specialize (hf x hin) as [k hl]. - specialize (ext _ _ hl) as [? []]. - depelim H0. now exists y. - Qed. - - Lemma level_values_in_W m m' W x : - total_model_of W m -> - m ⩽ m' -> - LevelSet.In x W -> level_value m x ≤ level_value m' x -> - exists k k', level_value m x = Some k /\ level_value m' x = Some k' /\ (k <= k')%Z. - Proof. - intros hwv ext hin hleq. - specialize (hwv _ hin) as x'. destruct x' as [k hl]. rewrite (maps_to_value_default hl) in hleq. - eapply w_values_ext in hwv; tea. - specialize (hwv _ hin) as [k' hl']. - rewrite (maps_to_value_default hl') in hleq. depelim hleq. - do 2 eexists. intuition eauto. - now rewrite (maps_to_value_default hl). - now rewrite (maps_to_value_default hl'). - Qed. - - Lemma measure_le {W cls m m'} : - total_model_of W m -> - model_map_outside W m m' -> - m ⩽ m' -> - (measure W cls m' <= measure W cls m)%nat. - Proof. - intros hwv hout hle. - unfold measure, measure_w, sum_W. - rewrite (v_minus_w_bound_irrel _ _ hout). - rewrite !LevelSet.fold_spec. unfold flip. - eapply fold_left_le; unfold flip. 2:lia. - - intros. rewrite LevelSet_In_elements in H. - have lexx' := (model_le_values x hle). - eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. - erewrite !level_value_default_def; tea. lia. - Qed. - - Lemma measure_lt {W cls m m'} : - total_model_of W m -> - model_map_outside W m m' -> - m ⩽ m' -> - (exists l, [/\ LevelSet.In l W, (0 < measure_w W cls m l)%Z & - opt_le Z.lt (level_value m l) (level_value m' l)])%Z -> - (measure W cls m' < measure W cls m)%nat. - Proof. - intros hwv hout hle. - unfold measure, measure_w, sum_W. - rewrite (v_minus_w_bound_irrel _ _ hout). - intros hlt. - rewrite !LevelSet.fold_spec. unfold flip. - eapply fold_left_ne_lt; unfold flip. - - unfold flip. intros; lia. - - unfold flip; intros; lia. - - destruct hlt as [l [hin _]]. intros he. rewrite -LevelSetProp.elements_Empty in he. lsets. - - intros. rewrite LevelSet_In_elements in H. - have lexx' := (model_le_values x hle). - eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. - erewrite !level_value_default_def; tea. lia. - - intros. rewrite LevelSet_In_elements in H. - have lexx' := (model_le_values x hle). - eapply level_values_in_W in lexx' as [k [k' [hk [hk' leq]]]]; tea. - erewrite !level_value_default_def; tea. lia. - - destruct hlt as [l [hinl hbound hlev]]. - exists l. rewrite LevelSet_In_elements. split => //. - intros acc acc' accle. - eapply Nat.add_le_lt_mono => //. - depelim hlev. rewrite /level_value_default ?H0 ?H1 in hbound |- *. - lia. now eapply total_model_of_value_None in H; tea. - Qed. - - Lemma is_model_equal {cls cls' m} : Clauses.Equal cls cls' -> is_model cls m -> is_model cls' m. - Proof. now intros ->. Qed. - - Lemma union_diff_eq {cls cls'} : Clauses.Equal (Clauses.union cls (Clauses.diff cls' cls)) - (Clauses.union cls cls'). - Proof. clsets. Qed. - - Lemma union_restrict_with_concl {cls W} : - Clauses.Equal (Clauses.union (cls ⇂ W) (cls ↓ W)) (cls ↓ W). - Proof. - intros cl. rewrite Clauses.union_spec. - intuition auto. - eapply in_clauses_with_concl. - now eapply in_restrict_clauses in H0 as []. - Qed. - - Lemma maps_to_level_value x (m m' : model) : - (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> - level_value m x = level_value m' x. - Proof. - intros heq. - unfold level_value. - destruct LevelMap.find eqn:hl. - apply LevelMap.find_2 in hl. rewrite heq in hl. - rewrite (LevelMap.find_1 hl) //. - destruct (LevelMap.find x m') eqn:hl' => //. - apply LevelMap.find_2 in hl'. rewrite -heq in hl'. - now rewrite (LevelMap.find_1 hl') in hl. - Qed. - - Lemma measure_Z_lt x y : - (x < y)%Z -> - (0 < y)%Z -> - (Z.to_nat x < Z.to_nat y)%nat. - Proof. intros. lia. Qed. - - Lemma sum_pos W f : - (0 < sum_W W f)%nat -> - exists w, LevelSet.In w W /\ (0 < f w)%nat. - Proof. - unfold sum_W. - eapply LevelSetProp.fold_rec => //. - intros. lia. - intros. - destruct (Nat.ltb_spec 0 a). - - destruct (H2 H4) as [w [hin hlt]]. exists w. split => //. apply H1. now right. - - exists x. split => //. apply H1. now left. lia. - Qed. - - Lemma measure_pos {W cls m} : - (0 < measure W cls m)%nat -> - exists l, LevelSet.In l W /\ (0 < measure_w W cls m l)%Z. - Proof. - unfold measure. - move/sum_pos => [w [hin hlt]]. - exists w. split => //. lia. - Qed. - - Lemma model_of_diff cls W m : - model_of W m -> model_of (clauses_conclusions (cls_diff cls W)) m. - Proof. - intros; eapply model_of_subset; tea. - eapply clauses_conclusions_diff_left. - Qed. - Hint Resolve model_of_diff : core. - - Lemma check_model_spec_diff {cls w m w' m' w''} : - model_of w m -> - let cls := (cls_diff cls w) in - check_model cls (w'', m) = Some (w', m') -> - [/\ w'' ⊂_lset w', w' ⊂_lset (w'' ∪ w), - exists cl : clause, - let cll := levelexpr_level (concl cl) in - [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' - & (opt_le Z.lt (level_value m cll) (level_value m' cll))%Z] - & model_extension w' m m']. - Proof. - cbn; intros mof cm. - pose proof (clauses_conclusions_diff_left cls w (cls ⇂ w)). - apply check_model_spec in cm as []. - split => //. lsets. - eapply model_of_subset; tea. - Qed. - - Lemma model_of_ext {W W' m m'} : - model_of W m -> model_extension W' m m' -> model_of W m'. - Proof. - intros mof [_ dom _]. - intros k hin. apply dom. now apply mof. - Qed. - - Lemma total_model_of_ext {W W' m m'} : - total_model_of W m -> model_extension W' m m' -> total_model_of W m'. - Proof. - intros mof [_ dom _]. - intros k hin. destruct (mof k hin). destruct (dom k). - unfold LevelMap.In in H0. apply H0. apply dom. now apply mof. - Qed. - - Lemma clauses_partition_spec {cls W allW conclW} : - clauses_conclusions cls ⊂_lset W -> - Clauses.partition (premise_restricted_to W) cls = (allW, conclW) -> - (Clauses.Equal allW (cls ⇂ W)) /\ - (Clauses.Equal conclW (Clauses.diff cls (cls ⇂ W))). - Proof. - intros clW. - destruct Clauses.partition eqn:eqp. - intros [= <- <-]. - change t with (t, t0).1. - change t0 with (t, t0).2 at 2. - rewrite -eqp. clear t t0 eqp. - split. - - intros cl. rewrite Clauses.partition_spec1. - rewrite in_restrict_clauses Clauses.filter_spec. - rewrite /premise_restricted_to LevelSet.subset_spec. firstorder eauto. - apply clW, clauses_conclusions_spec. now exists cl. - - intros cl. rewrite Clauses.partition_spec2. - rewrite Clauses.filter_spec Clauses.diff_spec. - rewrite /premise_restricted_to. intuition auto. - move/negbTE: H1. eapply eq_true_false_abs. - eapply LevelSet.subset_spec. - now eapply in_restrict_clauses in H as []. - apply eq_true_not_negb. move/LevelSet.subset_spec => he. - apply H1. apply in_restrict_clauses. split => //. - apply clW, clauses_conclusions_spec. now exists cl. - Qed. - - Lemma clauses_conclusions_eq cls W : - clauses_conclusions cls ⊂_lset W -> - Clauses.Equal cls (cls ↓ W). - Proof. - intros cl x. - rewrite in_clauses_with_concl. intuition auto. - apply cl, clauses_conclusions_spec. now exists x. - Qed. - - Section innerloop_partition. - Context (W : LevelSet.t) (cls : clauses). - Context (premconclW conclW : clauses). - Context (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W, - Clauses.Equal premconclW (cls ⇂ W) & Clauses.Equal conclW (Clauses.diff (cls ↓ W) (cls ⇂ W))]). - - #[tactic="idtac"] - Equations? inner_loop_partition (m : model) (mW : total_model_of W m) : result W U cls m - by wf (measure W cls m) lt := - inner_loop_partition m mW with loop W LevelSet.empty premconclW m _ _ := { - (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) - | Loop => Loop - (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). - By invariant Wr ⊂ W *) - | Model Wr mr hsub with inspect (check_model conclW (Wr, model_model mr)) := { - | exist None eqm => Model W {| model_model := model_model mr |} _ - | exist (Some (Wconcl, mconcl)) eqm with inner_loop_partition mconcl _ := { - (* Here Wconcl ⊂ Wr by invariant *) - | Loop => Loop - | Model Wr' mr' hsub' => Model Wr' {| model_model := model_model mr' |} hsub' } - (* Here Wr' ⊂ W by invariant *) - (* We check if the new model [mr] for (cls ⇂ W) extends to a model of (cls ↓ W). *) - (* We're entitled to recursively compute a better model starting with mconcl, - as we have made the measure decrease: - some atom in W has been strictly updated in Wconcl. *) - } }. - Proof. - all:cbn [model_model]; clear loop inner_loop_partition. - all:try solve [try apply LevelSet.subset_spec; try reflexivity]. - all:try apply LevelSet.subset_spec in hsub. - all:auto. - all:try destruct prf as [WV neW UW clsW eqprem eqconcl]. - all:try solve [intuition auto]. - all:try rewrite eqconcl in eqm. - - split => //. rewrite eqprem. apply clauses_conclusions_restrict_clauses. lsets. exact mW. - - left. now eapply strict_subset_cardinal. - - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. - eapply model_of_ext. 2:tea. apply mr. - - eapply (check_model_spec_diff mr) in eqm as [subwwconcl subwconcl hm hext] => //. - pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). - destruct hm as [cll [hind nvalid inwconcl hl]]. - eapply Nat.lt_le_trans. - 2:{ eapply measure_le; eauto; try eapply mr. } - eapply measure_lt. - { eapply mr. } - { eapply model_map_outside_weaken. eapply hext. lsets. } - { apply hext. } - eapply invalid_clause_measure in nvalid; tea. - exists (levelexpr_level (concl cll)). - split => //. - eapply clauses_conclusions_diff_left; tea. - eapply clauses_conclusions_spec. exists cll; split => //. exact hind. apply mr. - - apply mr'. - (* - apply clauses_conclusions_clauses_with_concl. *) - - apply mr'. - - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. - eapply model_ext_trans_weaken. 2:apply mr. lsets. - transitivity mconcl. eapply model_extension_weaken. 2:tea. lsets. apply mr'. - - apply mr. - (* - eapply clauses_conclusions_clauses_with_concl. *) - - rewrite check_model_is_model in eqm. - 1:{ eapply model_of_diff, mr. } - have okm := (model_ok mr). - have mu := is_model_union okm eqm. - rewrite {1}eqprem in mu. - rewrite union_diff_eq in mu. - rewrite union_restrict_with_concl in mu. - now rewrite (clauses_conclusions_eq _ _ clsW). - - apply mr. - - split; lsets. - Qed. - End innerloop_partition. - - (* We first partition the clauses among those that mention only W and the ones that can mention other atoms. - We then call the loop on these two sets of clauses, which not need to change during the recursive calls. - *) - #[tactic="idtac"] - Equations? inner_loop (W : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & model_of W m]) : - result W U cls m := - inner_loop W cls m prf with inspect (Clauses.partition (premise_restricted_to W) cls) := - | exist (premconclW, conclW) eqp => inner_loop_partition W cls premconclW conclW _ m _. - Proof. - - destruct prf as [subWV neW UW clsW mW]. - eapply (clauses_partition_spec clsW) in eqp as [eqprem eqconcl]. - split => //. now rewrite -(clauses_conclusions_eq _ _ clsW). - - apply prf. - Qed. - -End InnerLoop. - -Local Open Scope nat_scope. -Lemma diff_cardinal_inter V W : #|LevelSet.diff V W| = #|V| - #|LevelSet.inter V W|. -Proof. - pose proof (LevelSetProp.diff_inter_cardinal V W). lia. -Qed. - -Lemma diff_cardinal V W : W ⊂_lset V -> #|LevelSet.diff V W| = #|V| - #|W|. -Proof. - intros hsub. - rewrite diff_cardinal_inter LevelSetProp.inter_sym LevelSetProp.inter_subset_equal //. -Qed. - -Lemma is_modelP m cls : reflect (Clauses.For_all (valid_clause m) cls) (is_model cls m). -Proof. - case E: is_model; constructor. - - now move: E; rewrite /is_model -ClausesFact.for_all_iff. - - intros hf. apply ClausesFact.for_all_iff in hf; tc. unfold is_model in E; congruence. -Qed. - -Lemma is_model_invalid_clause cl cls m : is_model cls m -> ~~ valid_clause m cl -> ~ Clauses.In cl cls. -Proof. - move/is_modelP => ism /negP valid hin. - now specialize (ism _ hin). -Qed. - -Lemma strict_subset_leq_right U V W : - strict_subset U V -> V ⊂_lset W -> strict_subset U W. -Proof. - intros [] le. split. lsets. intros eq. rewrite -eq in le. - apply H0. lsets. -Qed. - -Lemma strict_subset_diff_incl V W W' : - strict_subset W' W -> - W ⊂_lset V -> - W' ⊂_lset V -> - strict_subset (LevelSet.diff V W) (LevelSet.diff V W'). -Proof. - intros [] lew lew'. - split. lsets. - intros eq. - apply H0. lsets. -Qed. - -(* To help equations *) -Opaque lexprod_rel_wf. - -Lemma check_model_spec_V {V cls w m w' m'} : - model_of V m -> clauses_conclusions cls ⊂_lset V -> - check_model cls (w, m) = Some (w', m') -> - check_model_invariants cls w m w' m' true. -Proof. - cbn; intros mof incl cm. - apply check_model_spec in cm => //. - eapply model_of_subset; tea. -Qed. - -Lemma valid_model_of {V W m cls} (m' : valid_model W m cls) : - model_of V m -> model_of V (model_model m'). -Proof. - intros mof. eapply model_of_ext; tea. eapply m'. -Qed. - -#[tactic="idtac"] -Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V, U ⊂_lset V & model_of V m]) : result V U cls m - by wf (loop_measure V U) lexprod_rel := - loop V U cls m prf with inspect (check_model cls (U, m)) := - | exist None eqm => Model U {| model_model := m |} _ - | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { - | exist true eq := Loop - (* Loop on cls ↓ W, with |W| < |V| *) - | exist false neq with inner_loop V U loop W (cls ↓ W) m' _ := - { | Loop := Loop - | Model Wc mwc hsub' - (* We get a model for (cls ↓ W), we check if it extends to all clauses. - By invariant |Wc| cannot be larger than |W|. *) - with inspect (check_model cls (Wc, mwc.(model_model))) := - { | exist None eqm' => Model Wc {| model_model := mwc.(model_model) |} _ - | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { - | exist true _ := Loop - | exist false neq' with loop V Wcls cls mcls _ := { - (* Here Wcls < V, we've found a model for all of the clauses with conclusion - in W, which can now be fixed. We concentrate on the clauses whose - conclusion is different. Clearly |W| < |V|, but |Wcls| is not - necessarily < |V| *) - | Loop := Loop - | Model Wvw mcls' hsub'' := Model Wvw {| model_model := model_model mcls' |} _ } } } - } - } - . -Proof. - all:clear loop. - all:try solve [intuition auto]. - all:try eapply levelset_neq in neq. - all:have cls_sub := clauses_conclusions_levels cls. - all:destruct prf as [clsV UV mof]. - - apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. - split => //. split => //. lsets. - destruct hcl as [l [hl _]]. intros he. lsets. - apply clauses_conclusions_clauses_with_concl. - eapply model_of_ext; tea. eapply model_of_subset; tea. lsets. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - eapply check_model_spec in eqm' as []. - 2:{ eapply model_of_subset. 2:exact clsV. - exact (valid_model_of mwc (model_of_ext mof ext)). } - split. lsets. lsets. - exact (model_of_ext (valid_model_of mwc (model_of_ext mof ext)) H2). - - right. - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - eapply check_model_spec in eqm' as []. - 2:{ eapply model_of_subset. 2:exact clsV. - exact (valid_model_of mwc (model_of_ext mof ext)). } - destruct hsub' as [UWc WcW]. - assert (Wcls ⊂_lset V). lsets. - rewrite -!diff_cardinal //. - eapply strict_subset_cardinal. - assert (strict_subset Wc Wcls). - { split => //. - destruct H1 as [cl [clcls nvalid hcll hv]]. - pose proof (model_ok mwc). - eapply is_model_invalid_clause in H1; tea. - assert (~ LevelSet.In (levelexpr_level (concl cl)) W). - { intros hin. rewrite in_clauses_with_concl in H1. intuition auto. } - move/(_ (levelexpr_level (concl cl))) => [] wcwcls wclswc. - now apply H4, WcW, wclswc. } - eapply (strict_subset_leq_right _ (LevelSet.diff V Wc)). - 2:{ clear -UWc WcW UW WU H3 H4. lsets. } - apply strict_subset_diff_incl => //. clear -H H3; lsets. - - eapply mcls'. - - auto. - - exact mcls'. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - eapply check_model_spec in eqm' as []. - 2:{ eapply model_of_subset. 2:exact clsV. - exact (valid_model_of mwc (model_of_ext mof ext)). } - assert (WV : W ⊂_lset V). - { clear -UV clsV WU; lsets. } - eapply model_ext_trans_weaken => //. 2:tea. auto. - transitivity mcls; [|apply mcls']. - transitivity (model_model mwc). 2:{ eapply model_extension_weaken; [|tea]. lsets. } - eapply model_extension_weaken. 2:apply mwc. auto. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - eapply check_model_spec in eqm' as []. - 2:{ eapply model_of_subset. 2:exact clsV. - exact (valid_model_of mwc (model_of_ext mof ext)). } - split. lsets. lsets. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - refine (valid_model_of mwc _). - refine (model_of_ext mof ext). - - auto. - - rewrite check_model_is_model // in eqm'. - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - refine (valid_model_of mwc _). - eapply model_of_subset. - refine (model_of_ext mof ext). auto. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - transitivity m'. eapply model_extension_weaken; [|tea]. lsets. - eapply model_extension_weaken. 2:apply mwc. lsets. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - split; lsets. - - exact mof. - - exact clsV. - - apply check_model_is_model in eqm; eauto. - eapply model_of_subset; tea. - - reflexivity. - - split; lsets. -Qed. - -Transparent lexprod_rel_wf. - -Definition zero_model levels := - LevelSet.fold (fun l acc => LevelMap.add l 0 acc) levels (LevelMap.empty _). - -Definition add_max l k m := - match LevelMap.find l m with - | Some k' => - if (k' LevelMap.add l k m - end. - -#[local] Instance proper_levelexprset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) - levels. -Proof. - intros s s' eq l. - rewrite !levelexprset_levels_spec. - firstorder eauto. -Qed. - -Lemma In_add_max l l' k acc : - LevelMap.In (elt:=Z) l (add_max l' k acc) <-> - (l = l' \/ LevelMap.In l acc). -Proof. - unfold add_max. - destruct LevelMap.find eqn:hl. - case: Z.ltb_spec. - - rewrite LevelMapFact.F.add_in_iff /Level.eq. - firstorder eauto. - - intros. intuition auto. subst. - now rewrite LevelMapFact.F.in_find_iff hl. - - LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. -Qed. - -Lemma In_fold_add_max k n a : - LevelMap.In (elt:=Z) k - (LevelExprSet.fold - (fun '(l, k0) (acc : LevelMap.t Z) => add_max l (Z.of_nat k0) acc) n a) <-> - (LevelSet.In k (levels n)) \/ LevelMap.In k a. -Proof. - eapply LevelExprSetProp.fold_rec. - - intros s' he. - rewrite (LevelExprSetProp.empty_is_empty_1 he). - cbn. unfold levels. rewrite LevelExprSetProp.fold_empty. rewrite LevelSetFact.empty_iff. intuition auto. - - intros. - destruct x as [l k']. - rewrite In_add_max. - rewrite H2 !levelexprset_levels_spec. - split. - * intros []; subst. - left. exists k'. apply H1. now left. - destruct H3 as [[k'' ?]|?]. left; exists k''. apply H1. now right. - now right. - * red in H1. setoid_rewrite H1. - intros [[k'' []]|]. noconf H3. now left. - right. now left; exists k''. right; right. apply H3. -Qed. - - -(* To handle the constraint inference problem, - we must start with a model where all atoms [l + k] - appearing in premises are true. Otherwise the - [l := 0] model is minimal for [l+1-> l+2]. - Starting with [l := 1], we see that the minimal model above it - has [l := ∞]. - We also ensure that all levels in the conclusions are in the model. - - *) - -Definition min_model_map (m : LevelMap.t Z) cls : LevelMap.t Z := - Clauses.fold (fun '(cl, concl) acc => - LevelExprSet.fold (fun '(l, k) acc => - add_max l (Z.of_nat k) acc) cl (add_max (levelexpr_level concl) 0%Z acc)) cls m. - -Lemma min_model_map_levels m cls k : - LevelMap.In k (min_model_map m cls) <-> - LevelSet.In k (clauses_levels cls) \/ LevelMap.In k m. -Proof. - rewrite /min_model_map. - rewrite clauses_levels_spec. - eapply ClausesProp.fold_rec. - - intros s' he. intuition auto. - destruct H0 as [cl []]. - clsets. - - intros x a s' s'' inx ninx hadd ih. - destruct x as [cl k']. - rewrite In_fold_add_max In_add_max. rewrite ih. - intuition auto. left. exists (cl, k'); intuition auto. - apply hadd. now left. - rewrite clause_levels_spec. now left. - subst. left. exists (cl, k'). split. apply hadd; now left. - rewrite clause_levels_spec. now right. - destruct H as [cl'' []]. left. exists cl''. - intuition auto. apply hadd. now right. - destruct H3 as [cl'' []]. - apply hadd in H0 as []; subst. - rewrite clause_levels_spec in H3. destruct H3; subst. - cbn in H0. now left. right. now left. - right. right. left; exists cl''. split => //. -Qed. - -Definition min_model m cls : model := min_model_map m cls. - -Definition init_model cls := min_model (LevelMap.empty _) cls. - -Lemma init_model_levels cls k : - LevelMap.In k (init_model cls) <-> LevelSet.In k (clauses_levels cls). -Proof. - rewrite min_model_map_levels. intuition auto. - now rewrite LevelMapFact.F.empty_in_iff in H0. -Qed. - -Definition init_w (levels : LevelSet.t) : LevelSet.t := LevelSet.empty. - -(* We don't need predecessor clauses as they are trivially satisfied *) -(* Definition add_predecessors (V : LevelSet.t) cls := - LevelSet.fold (fun l acc => - Clauses.add (NonEmptySetFacts.singleton (l, 1), (l, 0)) acc) V cls. *) - -Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). - -Equations? infer (cls : clauses) : infer_result (clauses_levels cls) cls := - infer cls := loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (And3 _ _ _). -Proof. - - now eapply clauses_conclusions_levels. - - lsets. - - red. now eapply init_model_levels. -Qed. - -Local Open Scope Z_scope. -Lemma max_min max min k : min <= 0 -> max >= 0 -> k <= max -> k >= min -> (max - k - min) >= 0. -Proof. lia. Qed. - -Definition valuation_of_model (m : model) : LevelMap.t nat := - let '(min, max) := LevelMap.fold (fun l k '(min, max) => (Z.min min k, Z.max k max)) m (0, 0)%Z in - LevelMap.fold (fun l k acc => LevelMap.add l (Z.to_nat (max - k - min)) acc) m (LevelMap.empty _). -Close Scope Z_scope. - -Local Open Scope string_scope2. - -Definition print_level_Z_map (m : LevelMap.t Z) := - let list := LevelMap.elements m in - print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_Z w) nl list. - -Definition print_result {V cls} (m : infer_result V cls) := - match m return string with - | Loop => "looping" - | Model w m _ => "satisfiable with model: " ^ print_level_Z_map m.(model_model) ^ nl ^ " W = " ^ - print_lset w - ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model m.(model_model)) - end. - -Definition valuation_of_result {V cls} (m : infer_result V cls) := - match m with - | Loop => "looping" - | Model w m _ => print_level_nat_map (valuation_of_model m.(model_model)) - end. - -Definition to_string_expr (e : LevelExpr.t) : string := - let '(l, n) := e in Level.to_string l ^ (if n is 0 then "" else "+" ^ string_of_nat n). - -Definition print_premise (l : nonEmptyLevelExprSet) : string := - let (e, exprs) := NonEmptySetFacts.to_nonempty_list l in - to_string_expr e ^ - match exprs with - | [] => "" - | l => ", " ^ print_list to_string_expr ", " exprs - end. - -Definition print_clauses (cls : clauses) := - let list := Clauses.elements cls in - print_list (fun '(l, r) => - print_premise l ^ " → " ^ to_string_expr r) nl list. - -Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) - (prf : clauses_conclusions cls ⊂_lset V /\ clauses_conclusions cls' ⊂_lset V /\ model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := - | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m _. -Proof. - split. 2:lsets. - intros x. rewrite clauses_conclusions_spec. - intros [cl [hcl hl]]. - rewrite Clauses.union_spec in hcl. destruct hcl. - - apply H, clauses_conclusions_spec. exists cl => //. - - apply H0, clauses_conclusions_spec. exists cl => //. - - exact H1. -Qed. - -(* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by - setting a minimal value for the new atoms in [clauses_levels cls \ V] - such that the new clauses [cls] do not hold vacuously. -*) -Equations? infer_extension {V init cls} (m : valid_model V init cls) (cls' : clauses) : - result (LevelSet.union (clauses_levels cls') V) LevelSet.empty (Clauses.union cls cls') (min_model m.(model_model) cls') := - infer_extension m cls' := - infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model m.(model_model) cls') cls cls' _. -Proof. - repeat split. - - pose proof (model_clauses_conclusions m). lsets. - - pose proof (clauses_conclusions_levels cls'). lsets. - - red. intros. - unfold min_model. rewrite min_model_map_levels. - pose proof (model_of_V m k). - apply LevelSet.union_spec in H as []; auto. -Qed. - -Definition enforce_clauses {V init cls} (m : valid_model V init cls) cls' : option model := - match infer_extension m cls' with - | Loop => None - | Model w m _ => Some m.(model_model) - end. - -Definition enforce_clause {V init cls} (m : valid_model V init cls) cl : option model := - enforce_clauses m (Clauses.singleton cl). - -Inductive constraint_type := UnivEq | UnivLe. - -Notation constraint := (nonEmptyLevelExprSet * constraint_type * nonEmptyLevelExprSet)%type. - -Definition enforce_constraint (cstr : constraint) (cls : clauses) : clauses := - let '(l, d, r) := cstr in - match d with - | UnivLe => - LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) l cls - | UnivEq => - let cls := - LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) l cls - in - let cls' := - LevelExprSet.fold (fun rk acc => Clauses.add (l, rk) acc) r cls - in cls' - end. - -Definition clauses_of_list := ClausesProp.of_list. -Definition list_of_clauses := Clauses.elements. -Definition valuation := LevelMap.t nat. - -Definition premises_model_map (m : LevelMap.t Z) cls : LevelMap.t Z := - Clauses.fold (fun '(cl, concl) acc => - LevelExprSet.fold (fun '(l, k) acc => - add_max l (Z.of_nat k) acc) cl acc) cls m. - -Definition clauses_premises_levels (cls : clauses) : LevelSet.t := - Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls LevelSet.empty. - -Lemma clauses_premises_levels_spec_aux l cls acc : - LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (levels (premise cl)) acc) cls acc) <-> - (exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl))) \/ LevelSet.In l acc. -Proof. - eapply ClausesProp.fold_rec. - - intros. - intuition auto. destruct H1 as [k [hin hl]]. clsets. - - intros x a s' s'' hin nin hadd ih. - rewrite LevelSet.union_spec. - split. - * intros [hin'|]. - left. exists x. split => //. - apply hadd. now left. - apply ih in H. - intuition auto. - left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. - * intros [[k [ins'' ?]]|inacc]. - eapply hadd in ins''. destruct ins''; subst. - + now left. - + right. apply ih. now left; exists k. - + right. intuition auto. -Qed. - -Lemma clauses_premises_levels_spec l cls : - LevelSet.In l (clauses_premises_levels cls) <-> - exists cl, Clauses.In cl cls /\ LevelSet.In l (levels (premise cl)). -Proof. - unfold clauses_premises_levels. - rewrite clauses_premises_levels_spec_aux. - intuition auto. lsets. -Qed. - -Lemma premises_model_map_levels m cls k : - LevelMap.In k (premises_model_map m cls) <-> - LevelSet.In k (clauses_premises_levels cls) \/ LevelMap.In k m. -Proof. - rewrite /premises_model_map. - rewrite clauses_premises_levels_spec. - eapply ClausesProp.fold_rec. - - intros s' he. intuition auto. - destruct H0 as [cl []]. - clsets. - - intros x a s' s'' inx ninx hadd ih. - destruct x as [cl k']. - rewrite In_fold_add_max ih. - intuition auto. - * left. exists (cl, k'); intuition auto. - apply hadd. now left. - * destruct H as [cl'' []]. left. exists cl''. - intuition auto. apply hadd. now right. - * destruct H3 as [cl'' []]. - apply hadd in H0 as []; subst. - now left. right. now left. -Qed. - -Definition premises_model m cls : model := premises_model_map m cls. - -Variant checking_result (cls : clauses) (cl : clause) : Type := - | DoesNotHold : ~ entails cls cl -> checking_result cls cl - | Entails : entails cls cl -> checking_result cls cl. - -Equations? check {V init cls} (m : valid_model V init cls) (cl : clause) : - checking_result cls cls := - check m cl := - infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model m.(model_model) cls') cls cls' _. -Proof. - repeat split. - - pose proof (model_clauses_conclusions m). lsets. - - pose proof (clauses_conclusions_levels cls'). lsets. - - red. intros. - unfold min_model. rewrite min_model_map_levels. - pose proof (model_of_V m k). - apply LevelSet.union_spec in H as []; auto. -Qed. - - -End LoopChecking. diff --git a/template-rocq/theories/LoopCheckingNat.v b/template-rocq/theories/LoopCheckingNat.v deleted file mode 100644 index b1e755af1..000000000 --- a/template-rocq/theories/LoopCheckingNat.v +++ /dev/null @@ -1,2823 +0,0 @@ -(* Distributed under the terms of the MIT license. *) -From Stdlib Require Import ssreflect ssrbool. -From Stdlib Require Import Program RelationClasses Morphisms. -From Stdlib Require Import Orders OrderedTypeAlt OrderedTypeEx MSetList MSetInterface MSetAVL MSetFacts FMapInterface MSetProperties MSetDecide. -From MetaRocq.Utils Require Import utils. -From MetaRocq.Common Require Universes. -From Equations Require Import Equations. -Set Equations Transparent. - -(* TODO move *) -Arguments exist {A P}. -Definition inspect {A} (x : A) : { y : A | x = y } := exist x eq_refl. - -Module FMapOrderedType_from_UsualOrderedType (O : UsualOrderedType). - Import O. - Definition t := O.t. - Definition eq : O.t -> O.t -> Prop := O.eq. - Definition lt : O.t -> O.t -> Prop := O.lt. - Definition eq_refl : forall x : O.t, eq x x := reflexivity. - Definition eq_sym : forall x y : O.t, eq x y -> eq y x := fun x y H => symmetry H. - - Lemma eq_trans : forall x y z, O.eq x y -> O.eq y z -> O.eq x z. - Proof. intros x y z. unfold O.eq. apply transitivity. Qed. - Lemma lt_trans : forall x y z, O.lt x y -> O.lt y z -> O.lt x z. - Proof. intros. eapply O.lt_strorder; tea. Qed. - - Lemma lt_not_eq : forall x y : O.t, lt x y -> ~ eq x y. - Proof. - intros x y H eq. do 2 red in eq. subst x. now eapply lt_strorder in H. - Qed. - - Definition compare : forall x y : O.t, Compare lt eq x y. - Proof. - intros. - case_eq (compare x y); intros. - apply EQ. abstract (destruct (compare_spec x y) => //). - apply LT. abstract (destruct (compare_spec x y) => //). - apply GT. abstract (destruct (compare_spec x y) => //). - Defined. - - Definition eq_dec : forall x y : O.t, {eq x y} + {~ eq x y} := eq_dec. -End FMapOrderedType_from_UsualOrderedType. - -Module Type LevelOrderedType. - Include UsualOrderedType. - - Parameter reflect_eq : ReflectEq t. - #[local] Existing Instance reflect_eq. - - Parameter to_string : t -> string. - -End LevelOrderedType. - -Module Type FMapOTInterface (E : UsualOrderedType). - Module OT := FMapOrderedType_from_UsualOrderedType E. - Include FMapInterface.Sfun OT. -End FMapOTInterface. - -Module Type LevelExprItf (Level : LevelOrderedType). - Include UsualOrderedType with Definition t := (Level.t * nat)%type. - Parameter eq_leibniz : forall (x y : t), eq x y -> x = y. -End LevelExprItf. - -Module Type LevelExprSet_fun (Level : LevelOrderedType) (LevelExpr : LevelExprItf Level). - Include SWithLeibniz with Module E := LevelExpr. - - Record nonEmptyLevelExprSet - := { t_set : t ; - t_ne : is_empty t_set = false }. - -End LevelExprSet_fun. - -Module Type LoopCheckingItf (Level : LevelOrderedType) - (LevelSet : MSetInterface.SetsOn Level) - (LevelExpr : LevelExprItf Level) - (LevelExprSet : LevelExprSet_fun Level LevelExpr) - (LevelMap : FMapOTInterface Level). - - Definition model := LevelMap.t nat. - Definition valuation := LevelMap.t nat. - - Definition clause : Type := LevelExprSet.nonEmptyLevelExprSet × LevelExpr.t. - - Parameter clauses : Type. - Parameter clauses_of_list : list clause -> clauses. - Parameter list_of_clauses : clauses -> list clause. - - Inductive constraint_type := UnivEq | UnivLe. - Notation constraint := (LevelExprSet.nonEmptyLevelExprSet * constraint_type * LevelExprSet.nonEmptyLevelExprSet). - - Parameter enforce_constraint : forall (cstr : constraint) (cls : clauses), clauses. - - Parameter valid_model : forall (V : LevelSet.t) (m : model) (cls : clauses), Type. - - Parameter model_model : forall V m cls, valid_model V m cls -> model. - - (* { model_model : model; - model_of_V :> model_of V model_model; - model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; - model_ok :> is_model cls model_model; - model_extends : model_extension V m model_model; - }. *) - - Infix "⊂_lset" := LevelSet.Subset (at level 70). - - Parameter enforce_clauses : forall {V init cls} (m : valid_model V init cls) (cls' : clauses), option model. - - Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := - | Loop - | Model (w : LevelSet.t) (m : valid_model V m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). - - Parameter init_model : clauses -> model. - Parameter clauses_levels : clauses -> LevelSet.t. - - Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). - - Parameter infer : forall (cls : clauses), infer_result (clauses_levels cls) cls. - -End LoopCheckingItf. - -Module LoopChecking - (* Signature of levels: decidable, ordered type *) - (Level : LevelOrderedType) - (LevelSet : MSetInterface.SetsOn Level) - (LevelExpr : LevelExprItf Level) - (LevelExprSet : LevelExprSet_fun Level LevelExpr) - (LevelMap : FMapOTInterface Level) <: LoopCheckingItf Level LevelSet LevelExpr LevelExprSet LevelMap. - -Definition level (e : LevelExpr.t) : Level.t := fst e. -Definition levels (e : LevelExprSet.t) := - LevelExprSet.fold (fun le => LevelSet.add (level le)) e LevelSet.empty. - -Import LevelExprSet (nonEmptyLevelExprSet, t_set, t_ne). - -Local Existing Instance Level.reflect_eq. - -Module LevelSetFact := WFactsOn Level LevelSet. -Module LevelSetProp := WPropertiesOn Level LevelSet. -Module LevelSetDecide := LevelSetProp.Dec. -Module LevelMapFact := FMapFacts.WProperties_fun LevelMap.OT LevelMap. - -Ltac lsets := LevelSetDecide.fsetdec. -Notation "(=_lset)" := LevelSet.Equal (at level 0). -Infix "=_lset" := LevelSet.Equal (at level 30). -Infix "⊂_lset" := LevelSet.Subset (at level 70). -Infix "∪" := LevelSet.union (at level 70). - -Definition print_level_nat_map (m : LevelMap.t nat) := - let list := LevelMap.elements m in - print_list (fun '(l, w) => Level.to_string l ^ " -> " ^ string_of_nat w) nl list. - -Definition print_lset (l : LevelSet.t) := - let list := LevelSet.elements l in - print_list Level.to_string " " list. - -Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. -Module LevelExprSetProp := WPropertiesOn LevelExpr LevelExprSet. - -(* We have decidable equality w.r.t leibniz equality for sets of levels. *) -#[global, program] Instance levelexprset_reflect : ReflectEq LevelExprSet.t := - { eqb := LevelExprSet.equal }. -Next Obligation. - destruct (LevelExprSet.equal x y) eqn:e; constructor. - eapply LevelExprSet.equal_spec in e. - now eapply LevelExprSet.eq_leibniz. - intros e'. - subst y. - pose proof (@LevelExprSetFact.equal_1 x x). - forward H. reflexivity. congruence. -Qed. - -#[global] Instance levelexprset_eq_dec : Classes.EqDec LevelExprSet.t := Classes.eq_dec. - -Derive NoConfusion for LevelExprSet.nonEmptyLevelExprSet. - -(* We use uip on the is_empty condition *) -#[global, program] Instance nonEmptyLevelExprSet_reflect : ReflectEq nonEmptyLevelExprSet := - { eqb x y := eqb x.(t_set) y.(t_set) }. -Next Obligation. - destruct (eqb_spec (t_set x) (t_set y)); constructor. - destruct x, y; cbn in *. subst. - now rewrite (uip t_ne0 t_ne1). - intros e; subst x; apply H. - reflexivity. -Qed. - -(** This coercion allows to see the non-empty set as a regular [LevelExprSet.t] *) -Coercion t_set : nonEmptyLevelExprSet >-> LevelExprSet.t. -Module LevelExprSetDecide := WDecide (LevelExprSet). -Ltac lesets := LevelExprSetDecide.fsetdec. -Infix "⊂_leset" := LevelExprSet.Subset (at level 70). - -Module NonEmptySetFacts. - #[program] Definition singleton (e : LevelExpr.t) : nonEmptyLevelExprSet - := {| t_set := LevelExprSet.singleton e |}. - Next Obligation. - apply negbTE. - eapply (contra_notN (P := LevelExprSet.Empty (LevelExprSet.singleton e))). - apply LevelExprSetFact.is_empty_2. intros ne. red in ne. specialize (ne e). lesets. - Qed. - - Lemma not_Empty_is_empty s : - ~ LevelExprSet.Empty s -> LevelExprSet.is_empty s = false. - Proof. - intro H. apply not_true_is_false. intro H'. - apply H. now apply LevelExprSetFact.is_empty_2 in H'. - Qed. - - Program Definition add (e : LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet - := {| t_set := LevelExprSet.add e u |}. - Next Obligation. - apply not_Empty_is_empty; intro H. - eapply H. eapply LevelExprSet.add_spec. - left; reflexivity. - Qed. - - Lemma add_spec e u e' : - LevelExprSet.In e' (add e u) <-> e' = e \/ LevelExprSet.In e' u. - Proof. - apply LevelExprSet.add_spec. - Qed. - - Definition add_list : list LevelExpr.t -> nonEmptyLevelExprSet -> nonEmptyLevelExprSet - := List.fold_left (fun u e => add e u). - - Lemma add_list_spec l u e : - LevelExprSet.In e (add_list l u) <-> In e l \/ LevelExprSet.In e u. - Proof. - unfold add_list. rewrite <- fold_left_rev_right. - etransitivity. 2:{ eapply or_iff_compat_r. etransitivity. - 2: apply @InA_In_eq with (A:=LevelExpr.t). - eapply InA_rev. } - induction (List.rev l); cbn. - - split. intuition. intros [H|H]; tas. invs H. - - split. - + intro H. apply add_spec in H. destruct H as [H|H]. - * left. now constructor. - * apply IHl0 in H. destruct H as [H|H]; [left|now right]. - now constructor 2. - + intros [H|H]. inv H. - * apply add_spec; now left. - * apply add_spec; right. apply IHl0. now left. - * apply add_spec; right. apply IHl0. now right. - Qed. - - Lemma elements_not_empty {u : nonEmptyLevelExprSet} : LevelExprSet.elements u <> []. - Proof. - rewrite -LevelExprSetProp.elements_Empty. - move/LevelExprSetFact.is_empty_1. - destruct u as [u1 u2]; cbn in *. congruence. - Qed. - - Equations to_nonempty_list (u : nonEmptyLevelExprSet) : LevelExpr.t * list LevelExpr.t := - | u with inspect (LevelExprSet.elements u) := { - | exist [] eqel => False_rect _ (elements_not_empty eqel) - | exist (e :: l) _ => (e, l) }. - - Lemma singleton_to_nonempty_list e : to_nonempty_list (singleton e) = (e, []). - Proof. - funelim (to_nonempty_list (singleton e)). bang. - clear H. - pose proof (LevelExprSet.singleton_spec e1 e). - rewrite LevelExprSetFact.elements_iff in H. - rewrite InA_In_eq in H. rewrite e0 in H. - destruct H. forward H. now left. noconf H. f_equal. - pose proof (LevelExprSet.cardinal_spec (LevelExprSet.singleton e1)). rewrite e0 in H. cbn in H. - rewrite LevelExprSetProp.singleton_cardinal in H. - destruct l => //. - Qed. - - Lemma to_nonempty_list_spec u : - let '(e, u') := to_nonempty_list u in - e :: u' = LevelExprSet.elements u. - Proof. - funelim (to_nonempty_list u). bang. now rewrite e0. - Qed. - - Lemma to_nonempty_list_spec' u : - (to_nonempty_list u).1 :: (to_nonempty_list u).2 = LevelExprSet.elements u. - Proof. - pose proof (to_nonempty_list_spec u). - now destruct (to_nonempty_list u). - Qed. - - Lemma In_to_nonempty_list (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : - LevelExprSet.In e u - <-> e = (to_nonempty_list u).1 \/ In e (to_nonempty_list u).2. - Proof. - etransitivity. symmetry. apply LevelExprSet.elements_spec1. - pose proof (to_nonempty_list_spec' u) as H. - destruct (to_nonempty_list u) as [e' l]; cbn in *. - rewrite <- H; clear. etransitivity. apply InA_cons. - eapply or_iff_compat_l. apply InA_In_eq. - Qed. - - Lemma In_to_nonempty_list_rev (u : nonEmptyLevelExprSet) (e : LevelExpr.t) : - LevelExprSet.In e u - <-> e = (to_nonempty_list u).1 \/ In e (List.rev (to_nonempty_list u).2). - Proof. - etransitivity. eapply In_to_nonempty_list. - apply or_iff_compat_l. apply in_rev. - Qed. - - Definition map (f : LevelExpr.t -> LevelExpr.t) (u : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := - let '(e, l) := to_nonempty_list u in - add_list (List.map f l) (singleton (f e)). - - Lemma map_spec f u e : - LevelExprSet.In e (map f u) <-> exists e0, LevelExprSet.In e0 u /\ e = (f e0). - Proof. - unfold map. symmetry. etransitivity. - { eapply iff_ex; intro. eapply and_iff_compat_r. eapply In_to_nonempty_list. } - destruct (to_nonempty_list u) as [e' l]; cbn in *. - symmetry. etransitivity. eapply add_list_spec. - etransitivity. eapply or_iff_compat_l. apply LevelExprSet.singleton_spec. - etransitivity. eapply or_iff_compat_r. - apply in_map_iff. clear u. split. - - intros [[e0 []]|H]. - + exists e0. split. right; tas. congruence. - + exists e'. split; tas. left; reflexivity. - - intros [xx [[H|H] ?]]. - + right. congruence. - + left. exists xx. split; tas; congruence. - Qed. - - Program Definition non_empty_union (u v : nonEmptyLevelExprSet) : nonEmptyLevelExprSet := - {| t_set := LevelExprSet.union u v |}. - Next Obligation. - apply not_Empty_is_empty; intro H. - assert (HH: LevelExprSet.Empty u). { - intros x Hx. apply (H x). - eapply LevelExprSet.union_spec. now left. } - apply LevelExprSetFact.is_empty_1 in HH. - rewrite t_ne in HH; discriminate. - Qed. - - - Lemma eq_univ (u v : nonEmptyLevelExprSet) : - u = v :> LevelExprSet.t -> u = v. - Proof. - destruct u as [u1 u2], v as [v1 v2]; cbn. intros X; destruct X. - now rewrite (uip_bool _ _ u2 v2). - Qed. - - Lemma eq_univ' (u v : nonEmptyLevelExprSet) : - LevelExprSet.Equal u v -> u = v. - Proof. - intro H. now apply eq_univ, LevelExprSet.eq_leibniz. - Qed. - - Lemma eq_univ'' (u v : nonEmptyLevelExprSet) : - LevelExprSet.elements u = LevelExprSet.elements v -> u = v. - Proof. - intro H. apply eq_univ. - destruct u as [u1 u2], v as [v1 v2]; cbn in *; clear u2 v2. - eapply LevelExprSet.eq_leibniz. red. - intros x. rewrite -!LevelExprSet.elements_spec1 H //. - Qed. - - Lemma univ_expr_eqb_true_iff (u v : nonEmptyLevelExprSet) : - LevelExprSet.equal u v <-> u = v. - Proof. - split. - - intros. - apply eq_univ'. now apply LevelExprSet.equal_spec. - - intros ->. now apply LevelExprSet.equal_spec. - Qed. - - Lemma univ_expr_eqb_comm (u v : nonEmptyLevelExprSet) : - LevelExprSet.equal u v <-> LevelExprSet.equal v u. - Proof. - transitivity (u = v). 2: transitivity (v = u). - - apply univ_expr_eqb_true_iff. - - split; apply eq_sym. - - split; apply univ_expr_eqb_true_iff. - Qed. - - - Lemma LevelExprSet_for_all_false f u : - LevelExprSet.for_all f u = false -> LevelExprSet.exists_ (negb ∘ f) u. - Proof. - intro H. rewrite LevelExprSetFact.exists_b. - rewrite LevelExprSetFact.for_all_b in H. - all: try now intros x y []. - induction (LevelExprSet.elements u); cbn in *; [discriminate|]. - apply andb_false_iff in H; apply orb_true_iff; destruct H as [H|H]. - left; now rewrite H. - right; now rewrite IHl. - Qed. - - Lemma LevelExprSet_For_all_exprs (P : LevelExpr.t -> Prop) (u : nonEmptyLevelExprSet) - : LevelExprSet.For_all P u - <-> P (to_nonempty_list u).1 /\ Forall P (to_nonempty_list u).2. - Proof. - etransitivity. - - eapply iff_forall; intro e. eapply imp_iff_compat_r. - apply In_to_nonempty_list. - - cbn; split. - + intro H. split. apply H. now left. - apply Forall_forall. intros x H0. apply H; now right. - + intros [H1 H2] e [He|He]. subst e; tas. - eapply Forall_forall in H2; tea. - Qed. - -End NonEmptySetFacts. -Import NonEmptySetFacts. - -Definition clause : Type := nonEmptyLevelExprSet × LevelExpr.t. - -Module Clause. - Definition t := clause. - - Definition eq : t -> t -> Prop := eq. - - Definition eq_equiv : RelationClasses.Equivalence eq := _. - - Inductive lt_ : t -> t -> Prop := - | lt_clause1 l e e' : LevelExpr.lt e e' -> lt_ (l, e) (l, e') - | lt_clause2 l l' b b' : LevelExprSet.lt l.(t_set) l'.(t_set) -> lt_ (l, b) (l', b'). - - Definition lt := lt_. - - Global Instance lt_strorder : RelationClasses.StrictOrder lt. - Proof. - constructor. - - intros x X; inversion X; subst. now eapply LevelExpr.lt_strorder in H1. - eapply LevelExprSet.lt_strorder; eassumption. - - intros x y z X1 X2; invs X1; invs X2; constructor; tea. - etransitivity; tea. - etransitivity; tea. - Qed. - - Definition lt_compat : Proper (Logic.eq ==> Logic.eq ==> iff) lt. - intros x x' H1 y y' H2. unfold lt. subst. reflexivity. - Qed. - - Definition compare (x y : t) : comparison := - match x, y with - | (l1, b1), (l2, b2) => - match LevelExprSet.compare l1.(t_set) l2.(t_set) with - | Eq => LevelExpr.compare b1 b2 - | x => x - end - end. - - Definition compare_spec : - forall x y : t, CompareSpec (x = y) (lt x y) (lt y x) (compare x y). - Proof. - intros [? ?] [? ?]; cbn; repeat constructor. - destruct (LevelExprSet.compare_spec n n0); repeat constructor; tas. - eapply LevelExprSet.eq_leibniz in H. apply NonEmptySetFacts.eq_univ in H. - subst. cbn in *. - destruct (LevelExpr.compare_spec t0 t1); repeat constructor; tas. now subst. - Qed. - - Global Instance reflect_t : ReflectEq t := reflect_prod _ _ . - - Definition eq_dec : forall (l1 l2 : t), {l1 = l2} + {l1 <> l2} := Classes.eq_dec. - - Definition eq_leibniz (x y : t) : eq x y -> x = y := id. -End Clause. - -Module Clauses := MSetAVL.Make Clause. -Module ClausesFact := WFactsOn Clause Clauses. -Module ClausesProp := WPropertiesOn Clause Clauses. -Module ClausesDecide := WDecide (Clauses). -Ltac clsets := ClausesDecide.fsetdec. - -Definition clauses := Clauses.t. - -Lemma filter_add {p x s} : Clauses.Equal (Clauses.filter p (Clauses.add x s)) (if p x then Clauses.add x (Clauses.filter p s) else Clauses.filter p s). -Proof. - intros i. - rewrite Clauses.filter_spec. - destruct (eqb_spec i x); subst; - destruct (p x) eqn:px; rewrite !Clauses.add_spec !Clauses.filter_spec; intuition auto || congruence. -Qed. - -Local Instance proper_fold_transpose {A} (f : Clauses.elt -> A -> A) : - transpose eq f -> - Proper (Clauses.Equal ==> eq ==> eq) (Clauses.fold f). -Proof. - intros hf s s' Hss' x ? <-. - eapply ClausesProp.fold_equal; tc; tea. -Qed. -Existing Class transpose. - -Lemma clauses_fold_filter {A} (f : Clauses.elt -> A -> A) (p : Clauses.elt -> bool) cls acc : - transpose Logic.eq f -> - Clauses.fold f (Clauses.filter p cls) acc = - Clauses.fold (fun elt acc => if p elt then f elt acc else acc) cls acc. -Proof. - intros hf. - symmetry. eapply ClausesProp.fold_rec_bis. - - intros s s' a eq. intros ->. - eapply ClausesProp.fold_equal; tc. auto. - intros x. - rewrite !Clauses.filter_spec. - now rewrite eq. - - now cbn. - - intros. - rewrite H1. - rewrite filter_add. - destruct (p x) eqn:px => //. - rewrite ClausesProp.fold_add //. - rewrite Clauses.filter_spec. intuition auto. -Qed. - -Definition levelexpr_level : LevelExpr.t -> Level.t := fst. -Coercion levelexpr_level : LevelExpr.t >-> Level.t. -Extraction Inline levelexpr_level. - -Definition strict_subset (s s' : LevelSet.t) := - LevelSet.Subset s s' /\ ~ LevelSet.Equal s s'. - -Lemma strict_subset_incl (x y z : LevelSet.t) : LevelSet.Subset x y -> strict_subset y z -> strict_subset x z. -Proof. - intros hs []. split => //. lsets. - intros heq. apply H0. lsets. -Qed. - -Lemma strict_subset_cardinal s s' : strict_subset s s' -> LevelSet.cardinal s < LevelSet.cardinal s'. -Proof. - intros []. - assert (LevelSet.cardinal s <> LevelSet.cardinal s'). - { intros heq. apply H0. - intros x. split; intros. now apply H. - destruct (LevelSet.mem x s) eqn:hin. - eapply LevelSet.mem_spec in hin. - auto. eapply LevelSetProp.FM.not_mem_iff in hin. - exfalso. - eapply LevelSetProp.subset_cardinal_lt in hin; tea. - lia. } - enough (LevelSet.cardinal s <= LevelSet.cardinal s') by lia. - now eapply LevelSetProp.subset_cardinal. -Qed. - -Definition premise (cl : clause) := fst cl. -Definition concl (cl : clause) := snd cl. -Extraction Inline premise concl. - -Definition clause_levels cl := - LevelSet.union (levels (premise cl)) (LevelSet.singleton (levelexpr_level (concl cl))). - -Definition clauses_levels (cls : clauses) : LevelSet.t := - Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls LevelSet.empty. - -Lemma Clauses_In_elements l s : - In l (Clauses.elements s) <-> Clauses.In l s. -Proof. - rewrite ClausesFact.elements_iff. - now rewrite InA_In_eq. -Qed. - -Lemma clauses_levels_spec_aux l cls acc : - LevelSet.In l (Clauses.fold (fun cl acc => LevelSet.union (clause_levels cl) acc) cls acc) <-> - (exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl)) \/ LevelSet.In l acc. -Proof. - eapply ClausesProp.fold_rec. - - intros. - intuition auto. destruct H1 as [k [hin hl]]. clsets. - - intros x a s' s'' hin nin hadd ih. - rewrite LevelSet.union_spec. - split. - * intros [hin'|]. - left. exists x. split => //. - apply hadd. now left. - apply ih in H. - intuition auto. - left. destruct H0 as [k Hk]. exists k. intuition auto. apply hadd. now right. - * intros [[k [ins'' ?]]|inacc]. - eapply hadd in ins''. destruct ins''; subst. - + now left. - + right. apply ih. now left; exists k. - + right. intuition auto. -Qed. - -Lemma clauses_levels_spec l cls : - LevelSet.In l (clauses_levels cls) <-> - exists cl, Clauses.In cl cls /\ LevelSet.In l (clause_levels cl). -Proof. - unfold clauses_levels. - rewrite clauses_levels_spec_aux. - intuition auto. lsets. -Qed. - -Lemma clause_levels_spec l cl : - LevelSet.In l (clause_levels cl) <-> - LevelSet.In l (levels (premise cl)) \/ l = levelexpr_level (concl cl). -Proof. - unfold clause_levels. - now rewrite LevelSet.union_spec LevelSet.singleton_spec. -Qed. - -Definition model := LevelMap.t nat. - -Definition level_value (m : model) (level : Level.t) : nat := - match LevelMap.find level m with - | Some val => val - | None => 0 - end. - -Definition levelexpr_value (m : model) (atom : LevelExpr.t) := - level_value m (levelexpr_level atom). - -Extraction Inline levelexpr_value. - -Definition min_atom_value (m : model) (atom : LevelExpr.t) := - let '(l, k) := atom in - (Z.of_nat (level_value m l) - Z.of_nat k)%Z. - -Definition min_premise (m : model) (l : nonEmptyLevelExprSet) : Z := - let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (fun min atom => Z.min (min_atom_value m atom) min) tl (min_atom_value m hd). - -Definition satisfiable_atom (m : model) (atom : Level.t * nat) : bool := - let '(l, k) := atom in - match LevelMap.find l m with - | Some val => k <=? val - | None => false - end. - -Definition satisfiable_premise (m : model) (l : nonEmptyLevelExprSet) := - LevelExprSet.for_all (satisfiable_atom m) l. - -(* Definition valid_clause (m : model) (cl : clause) := *) - (* implb (satisfiable_premise m (premise cl)) (satisfiable_atom m (concl cl)). *) - -Definition valid_clause (m : model) (cl : clause) := - let k0 := min_premise m (premise cl) in - if (k0 (modified, wm) - | DoesntHold wm' => (true, wm') - | Holds => (modified, wm) - end. - -Definition check_model_aux (cls : clauses) (wm : LevelSet.t × model) : bool × (LevelSet.t × model) := - Clauses.fold check_clause_model cls (false, wm). - -(* If check_model = None then we have a model of all clauses, - othewise, we return Some (W', m') where W ⊂ W' and the model has - been updated for at least one atom l ∈ W'. *) -Definition check_model (cls : clauses) (wm : LevelSet.t × model) := - let '(modified, wm) := check_model_aux cls wm in - if modified then Some wm else None. - -Lemma check_model_aux_subset {cls w v} : - forall b w' v', check_model_aux cls (w, v) = (b, (w', v')) -> LevelSet.Subset w w'. -Proof. - intros w' v'. - unfold check_model, check_model_aux, check_clause_model. revert w' v'. - eapply ClausesProp.fold_rec => //. - { intros. noconf H0. reflexivity. } - intros x a s' s'' hin nin hadd IH. - intros b w' v'. destruct a. - destruct p as []. - unfold update_value. - destruct Z.ltb. intros [= -> -> ->] => //. - now eapply IH. - destruct x as [prem [l k]]; cbn. - destruct Nat.leb. intros [= -> -> ->] => //. now eapply IH. - intros [= <- <- <-]. intros x inx. - eapply LevelSet.add_spec. - specialize (IH _ _ _ eq_refl). - now right. -Qed. - -Lemma check_model_subset {cls w v} : - forall w' v', check_model cls (w, v) = Some (w', v') -> LevelSet.Subset w w'. -Proof. - intros w' v'. unfold check_model. - destruct check_model_aux eqn:cm. - destruct p as [W m]. - eapply check_model_aux_subset in cm. - destruct b => //. now intros [= <- <-]. -Qed. - -Definition premise_restricted_to W cl := - LevelSet.subset (levels (premise cl)) W. - -Definition clause_restricted_to W cl := - LevelSet.subset (levels (premise cl)) W && - LevelSet.mem (level (concl cl)) W. - -Definition restrict_clauses (cls : clauses) (W : LevelSet.t) := - Clauses.filter (clause_restricted_to W) cls. - -Lemma in_restrict_clauses (cls : clauses) (concls : LevelSet.t) cl : - Clauses.In cl (restrict_clauses cls concls) <-> - [/\ LevelSet.In (level (concl cl)) concls, - LevelSet.Subset (levels (premise cl)) concls & - Clauses.In cl cls]. -Proof. - unfold restrict_clauses. - rewrite Clauses.filter_spec. - destruct cl. cbn. - rewrite andb_true_iff LevelSet.subset_spec LevelSet.mem_spec. - firstorder auto. -Qed. - -Definition clauses_with_concl (cls : clauses) (concl : LevelSet.t) := - Clauses.filter (fun '(prem, concla) => LevelSet.mem (level concla) concl) cls. - -Lemma in_clauses_with_concl (cls : clauses) (concls : LevelSet.t) cl : - Clauses.In cl (clauses_with_concl cls concls) <-> - LevelSet.In (level (concl cl)) concls /\ Clauses.In cl cls. -Proof. - unfold clauses_with_concl. - rewrite Clauses.filter_spec. - destruct cl. rewrite LevelSet.mem_spec. cbn. firstorder eauto. -Qed. - -Definition clauses_conclusions (cls : clauses) : LevelSet.t := - Clauses.fold (fun cl acc => LevelSet.add (level (concl cl)) acc) cls LevelSet.empty. - -Lemma clauses_conclusions_spec a cls : - LevelSet.In a (clauses_conclusions cls) <-> - exists cl, Clauses.In cl cls /\ level (concl cl) = a. -Proof. - unfold clauses_conclusions. - eapply ClausesProp.fold_rec; clear. - - move=> s' he /=. rewrite LevelSetFact.empty_iff. - firstorder auto. - - move=> cl ls cls' cls'' hin hnin hadd ih. - rewrite LevelSet.add_spec. firstorder eauto. - specialize (H0 x). cbn in H0. - apply hadd in H1. firstorder eauto. - subst. left. now destruct x. -Qed. - -Lemma clauses_conclusions_clauses_with_concl cls concl : - LevelSet.Subset (clauses_conclusions (clauses_with_concl cls concl)) concl. -Proof. - intros x [cl []] % clauses_conclusions_spec. - eapply in_clauses_with_concl in H as []. - now rewrite H0 in H. -Qed. - -Lemma clauses_conclusions_restrict_clauses cls W : - LevelSet.Subset (clauses_conclusions (restrict_clauses cls W)) W. -Proof. - intros x [cl []] % clauses_conclusions_spec. - eapply in_restrict_clauses in H as []. - now rewrite H0 in H. -Qed. - -Definition in_clauses_conclusions (cls : clauses) (x : Level.t): Prop := - exists cl, Clauses.In cl cls /\ (level cl.2) = x. - -Definition v_minus_w_bound (W : LevelSet.t) (m : model) := - LevelMap.fold (fun w v acc => Nat.max v acc) - (LevelMapFact.filter (fun l _ => ~~ LevelSet.mem l W) m) 0. - -Definition levelexpr_k : LevelExpr.t -> nat := snd. -Coercion levelexpr_k : LevelExpr.t >-> nat. - -Definition level_expr_elt : LevelExprSet.elt -> LevelExpr.t := fun x => x. -Coercion level_expr_elt : LevelExprSet.elt >-> LevelExpr.t. - -Definition premise_min (l : nonEmptyLevelExprSet) : nat := - let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (B:=LevelExpr.t) (fun min atom => Nat.min atom min) tl hd. - -Definition gain (cl : clause) : Z := - Z.of_nat (levelexpr_k (concl cl)) - Z.of_nat (premise_min (premise cl)). - -Definition max_gain (cls : clauses) := - Clauses.fold (fun cl acc => Nat.max (Z.to_nat (gain cl)) acc) cls 0. - -Definition model_same_domain (m m' : model) := - forall l, LevelMap.In l m <-> LevelMap.In l m'. - -#[local] Instance model_same_domain_refl : Reflexive model_same_domain. -Proof. intros m l. reflexivity. Qed. - -#[local] Instance model_same_domain_trans : Transitive model_same_domain. -Proof. intros m m' m'' h h' l. rewrite (h l). apply h'. Qed. - -Definition model_le (m m' : model) := - forall l k, LevelMap.MapsTo l k m -> - exists k', LevelMap.MapsTo l k' m' /\ k <= k'. - -Infix "⩽" := model_le (at level 70). (* \leqslant *) - -Definition model_map_outside V (m m' : model) := - forall l, ~ LevelSet.In l V -> - forall k, LevelMap.MapsTo l k m <-> LevelMap.MapsTo l k m'. - -#[local] Instance model_map_outside_refl V : Reflexive (model_map_outside V). -Proof. intros m l. reflexivity. Qed. - -#[local] Instance model_map_outside_trans V : Transitive (model_map_outside V). -Proof. - intros m m' m'' h h' l hnin k. - rewrite (h l hnin k). now apply h'. -Qed. - -(** The termination proof relies on the correctness of check_model: - it does strictly increase a value but not above [max_gain cls]. -*) - -Lemma clauses_conclusions_diff cls s : - clauses_conclusions (Clauses.diff cls (clauses_with_concl cls s)) ⊂_lset - LevelSet.diff (clauses_conclusions cls) s. -Proof. - intros a. rewrite LevelSet.diff_spec !clauses_conclusions_spec. - firstorder eauto. - exists x; split => //. - now rewrite Clauses.diff_spec in H. - intros ha. - rewrite Clauses.diff_spec in H; destruct H as []. - apply H1. - rewrite in_clauses_with_concl. split => //. - now rewrite H0. -Qed. - -Lemma diff_eq U V : LevelSet.diff V U =_lset V <-> LevelSet.inter V U =_lset LevelSet.empty. -Proof. split. lsets. lsets. Qed. - -Lemma levelset_neq U V : LevelSet.equal U V = false -> ~ LevelSet.Equal U V. -Proof. intros eq heq % LevelSet.equal_spec. congruence. Qed. - -Lemma levelset_union_same U : LevelSet.union U U =_lset U. -Proof. lsets. Qed. - -Lemma fold_left_comm {A B} (f : B -> A -> B) (l : list A) (x : A) (acc : B) : - (forall x y z, f (f z x) y = f (f z y) x) -> - fold_left f l (f acc x) = f (fold_left f l acc) x. -Proof. - intros. - induction l in acc, x |- *; cbn. auto. - rewrite -IHl. f_equal. now rewrite H. -Qed. - -Lemma fold_left_le (f g : nat -> LevelSet.elt -> nat) l : - (forall acc acc' x, In x l -> acc <= acc' -> f acc x <= g acc' x) -> - forall acc acc', acc <= acc' -> - fold_left f l acc <= fold_left g l acc'. -Proof. - intros hfg. - induction l => //. cbn. intros. - apply IHl. intros. apply hfg => //. now right. apply hfg => //. now left. -Qed. - -Lemma fold_left_ne_lt (f g : nat -> LevelSet.elt -> nat) l acc : - (forall (x y : LevelSet.elt) z, f (f z x) y = f (f z y) x) -> - (forall (x y : LevelSet.elt) z, g (g z x) y = g (g z y) x) -> - l <> [] -> - (forall acc acc' x, In x l -> (acc <= acc') -> (f acc x <= g acc' x)) -> - (forall acc acc' x, In x l -> (acc < acc') -> (f acc x < g acc' x)) -> - (exists x, In x l /\ forall acc acc', (acc <= acc') -> (f acc x < g acc' x)) -> - fold_left f l acc < fold_left g l acc. -Proof. - intros hf hg. - generalize (Nat.le_refl acc). - generalize acc at 2 4. - induction l in acc |- * => //. - intros. - destruct l; cbn. - { destruct H3 as [x []]. cbn in H3. destruct H3; subst => //. - now eapply (H4 acc acc0). } - cbn in IHl. - rewrite hf hg. - rewrite fold_left_comm //. rewrite (fold_left_comm g) //. - destruct H3 as [min [hmin hfg]]. - destruct hmin as [<-|hel]. - - apply hfg. apply fold_left_le => //. intros; eapply H1 => //. now right; right. - apply H1 => //. now right; left. - - apply H2. now left. eapply IHl => //. - * intros acc1 acc' x hin. apply (H1 acc1 acc' x). now right. - * intros acc1 acc' x hin. apply (H2 acc1 acc' x). now right. - * exists min. split => //. -Qed. - -Infix "↓" := clauses_with_concl (at level 70). (* \downarrow *) -Infix "⇂" := restrict_clauses (at level 70). (* \downharpoonright *) - -Lemma clauses_conclusions_diff_left cls W cls' : - clauses_conclusions (Clauses.diff (cls ↓ W) cls') ⊂_lset W. -Proof. - intros l. - rewrite clauses_conclusions_spec. - move=> [] cl. rewrite Clauses.diff_spec => [] [] []. - move/in_clauses_with_concl => [] hin ? ? eq. - now rewrite eq in hin. -Qed. - -Lemma clauses_conclusions_diff_restrict cls W cls' : - clauses_conclusions (Clauses.diff (cls ⇂ W) cls') ⊂_lset W. -Proof. - intros l. - rewrite clauses_conclusions_spec. - move=> [] cl. rewrite Clauses.diff_spec => [] [] []. - move/in_restrict_clauses => [] hin ? ? ? eq. - now rewrite eq in hin. -Qed. - -Lemma LevelSet_In_elements l s : - In l (LevelSet.elements s) <-> LevelSet.In l s. -Proof. - rewrite LevelSetFact.elements_iff. - now rewrite InA_In_eq. -Qed. - -Lemma clauses_empty_eq {s} : Clauses.Empty s -> Clauses.Equal s Clauses.empty. -Proof. clsets. Qed. - -Lemma update_value_valid {W m cl} : - match update_value (W, m) cl with - | VacuouslyTrue | Holds => valid_clause m cl - | DoesntHold _ => ~~ valid_clause m cl - end. -Proof. - unfold update_value, valid_clause. - destruct Z.ltb => //. - destruct cl as [prem [l k]]; cbn. - destruct Nat.leb => //. -Qed. - -Lemma valid_update_value {W m cl} : - valid_clause m cl -> - match update_value (W, m) cl with - | VacuouslyTrue | Holds => true - | DoesntHold _ => false - end. -Proof. - unfold update_value, valid_clause. - destruct Z.ltb => //. - destruct cl as [prem [l k]]; cbn. - destruct Nat.leb => //. -Qed. - -Lemma check_model_aux_false {cls acc acc'} : check_model_aux cls acc = (false, acc') -> acc = acc'. -Proof. - unfold check_model_aux, check_clause_model. - eapply ClausesProp.fold_rec. - - intros s emp [=] => //. - - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. - intros IH. - destruct update_value eqn:upd => //. -Qed. - -(* Lemma check_model_aux_true {cls acc acc'} : check_model_aux cls acc = (true, acc') -> acc = acc'. -Proof. - unfold check_model_aux. - eapply ClausesProp.fold_rec. - - intros s emp [=] => //. - - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. - intros IH. - destruct update_value eqn:upd => //. -Qed. *) - -Lemma check_model_aux_model {cls acc} : - check_model_aux cls acc = (false, acc) <-> is_model cls acc.2. -Proof. - unfold check_model_aux, check_clause_model. - unfold is_model. - unfold is_true; rewrite -ClausesFact.for_all_iff. - eapply ClausesProp.fold_rec. - - intros s emp. - split => //. - intros [=] x hx. clsets. - - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. - intros IH. - split. - * move: (@update_value_valid w' m' cl). - destruct update_value eqn:upd => //; intros vcl [= -> <-] ; - destruct IH as [IH _]; specialize (IH eq_refl). - intros x hx; apply incls'' in hx as []; subst. exact vcl. now apply IH. - intros x hx; apply incls'' in hx as []; subst. exact vcl. now apply IH. - * intros hf. - assert (valid_clause acc.2 cl). - { apply hf. apply incls''. intuition auto. } - destruct IH as [_ IH]. forward IH. - { intros x hx. apply hf. apply incls''. now right. } - noconf IH. - move: (@valid_update_value w' m' cl H). - destruct update_value eqn:upd => //. -Qed. - -Lemma clauses_for_all_neg {p s}: - ~~ Clauses.for_all p s <-> ~ Clauses.For_all p s. -Proof. - intuition auto. - rewrite ClausesFact.for_all_iff in H0. red in H. now rewrite H0 in H. - revert H. apply contra_notN. - rewrite ClausesFact.for_all_iff //. -Qed. - -Lemma clauses_for_all_exists {p s}: - ~~ Clauses.for_all p s <-> Clauses.exists_ (fun x => ~~ p x) s. -Proof. - rewrite ClausesFact.for_all_b ClausesFact.exists_b. - induction (Clauses.elements s). - - cbn; auto. reflexivity. - - cbn. rewrite negb_and. intuition auto. - move/orP: H1 => [->|] //. move/H. intros ->. now rewrite orb_true_r. - move/orP: H1 => [->|] //. move/H0. intros ->. now rewrite orb_true_r. -Qed. -#[local] Instance model_le_refl : Reflexive model_le. -Proof. intros x l k map. exists k; split => //. Qed. - -#[local] Instance model_le_trans : Transitive model_le. -Proof. intros m m' m'' mm' m'm'' l k map. - apply mm' in map as [k' [map ?]]. - apply m'm'' in map as [k'' [map ?]]. exists k''. split => //. lia. -Qed. - -Lemma update_model_monotone m l k : level_value m l <= k -> m ⩽ update_model m l k. -Proof. - intros hl. - intros l' k' maps. - unfold update_model. cbn. - destruct (eqb_spec l l'). - - exists k. move: hl. subst l'. - unfold level_value. - rewrite (LevelMap.find_1 maps). - intros hle. - split => //. eapply LevelMap.add_1. eapply LevelMap.OT.eq_refl. - - exists k'. split => //. apply LevelMap.add_2 => //. -Qed. - -Lemma check_clause_model_inv {cl modified w m b wm'} : - check_clause_model cl (modified, (w, m)) = (b, wm') -> - m ⩽ wm'.2. -Proof. - unfold check_clause_model. - destruct (update_value (w, m) cl) eqn:upd. - * now intros [= <- <-]. - * now intros [= <- <-]. - * intros [= <- <-]. - move: upd. - unfold update_value. - case: Z.ltb_spec => //. - destruct cl as [prem [l k]] => /=. - intros hprem. - case: Nat.leb_spec => // hlt. - intros [= <-]. cbn. - eapply update_model_monotone. lia. -Qed. - -Lemma check_clause_model_intact {cl modified w m wm'} : - check_clause_model cl (modified, (w, m)) = (false, wm') -> valid_clause m cl /\ wm' = (w, m). -Proof. - unfold check_clause_model. - move: (@update_value_valid w m cl). - destruct (update_value (w, m) cl) eqn:upd. - * intros valid [= -> <-]. split => //. - * intros valid [= -> <-]. split => //. - * intros _ [=]. -Qed. - -Lemma check_clause_model_modify {cl w m wm'} : - check_clause_model cl (false, (w, m)) = (true, wm') -> ~~ valid_clause m cl. -Proof. - unfold check_clause_model. - destruct (update_value (w, m) cl) eqn:upd. - * now intros [= <- <-]. - * now intros [= <- <-]. - * intros [= <-]. - move: upd. - unfold update_value, valid_clause. - case: Z.ltb_spec => //. - destruct cl as [prem [l k]] => /=. - intros hprem. - case: Nat.leb_spec => // hlt. -Qed. - -Lemma check_model_aux_model_le {cls acc acc' b} : - check_model_aux cls acc = (b, acc') -> acc.2 ⩽ acc'.2. -Proof. - unfold check_model_aux. - revert b acc'. - eapply ClausesProp.fold_rec. - - intros s emp b acc'. intros [=]. subst. reflexivity. - - intros cl [modified [w' m']] cls' cls'' incl nincls' incls''. - intros IH b acc'. - move/check_clause_model_inv. - specialize (IH _ _ eq_refl). cbn in IH. now intros; transitivity m'. -Qed. - -Lemma level_value_update_model m l k : - level_value (update_model m l k) l = k. -Proof. - unfold level_value, update_model. - cbn -[LevelMap.find LevelMap.add]. - rewrite LevelMapFact.F.add_o. - destruct LevelMap.OT.eq_dec => //. - exfalso. now apply n. -Qed. - - -Lemma model_map_outside_weaken {W W'} {m m' : model} : - model_map_outside W m m' -> - W ⊂_lset W' -> - model_map_outside W' m m'. -Proof. - intros hm sub x hin k. - apply hm. intros hin'. apply sub in hin'. now apply hin. -Qed. - -Lemma is_model_union {cls cls' m} : - is_model cls m -> is_model cls' m -> is_model (Clauses.union cls cls') m. -Proof. - rewrite /is_model. rewrite /is_true -!ClausesFact.for_all_iff. - now move=> ism ism' x /Clauses.union_spec []. -Qed. - -#[local] Instance Clauses_For_All_proper : Proper (eq ==> Clauses.Equal ==> iff) Clauses.For_all. -Proof. - intros x y -> cl cl' eqcl. - unfold Clauses.For_all. now setoid_rewrite eqcl. -Qed. - -#[local] Instance Clauses_for_all_proper : Proper (eq ==> Clauses.Equal ==> eq) Clauses.for_all. -Proof. - intros x y -> cl cl' eqcl. - apply iff_is_true_eq_bool. - rewrite /is_true -!ClausesFact.for_all_iff. now rewrite eqcl. -Qed. - -#[local] Instance is_model_proper : Proper (Clauses.Equal ==> eq ==> eq) is_model. -Proof. - intros cl cl' eqcl x y ->. unfold is_model. now rewrite eqcl. -Qed. - -Lemma model_le_values {m m' : model} x : m ⩽ m' -> level_value m x <= level_value m' x. -Proof. - intros lem. specialize (lem x). - unfold level_value. - destruct LevelMap.find eqn:hl => //. 2:lia. - apply LevelMap.find_2 in hl. specialize (lem _ hl) as [k' [mapsto leq]]. - now rewrite (LevelMap.find_1 mapsto). -Qed. - -Lemma level_value_MapsTo {k e} {m : model} : - LevelMap.MapsTo k e m -> level_value m k = e. -Proof. - unfold level_value. - move=> mapto; rewrite (LevelMap.find_1 mapto) //. -Qed. - -Infix "⊂_clset" := Clauses.Subset (at level 70). - -Lemma max_gain_in cl cls : - Clauses.In cl cls -> - Z.to_nat (gain cl) <= max_gain cls. -Proof. - intros hin. - unfold max_gain. revert cl hin. - eapply ClausesProp.fold_rec. - - intros s' ise hin. firstorder eauto. - - intros x a s' s'' xs nxs' hadd IH cl' hin'. - eapply hadd in hin' as []. - * subst x. lia. - * specialize (IH _ H). lia. -Qed. - -Definition max_gain_subset (cls cls' : Clauses.t) : - cls ⊂_clset cls' -> - max_gain cls <= max_gain cls'. -Proof. - unfold max_gain at 1. - revert cls'. - eapply ClausesProp.fold_rec. - - intros s' ise sub. lia. - - intros x a s' s'' xs nxs' hadd IH cls'' hs. - specialize (IH cls''). forward IH. transitivity s'' => //. - intros ??. now apply hadd. - assert (incls'' : Clauses.In x cls''). - { now apply hs, hadd. } - apply max_gain_in in incls''. lia. -Qed. - -Notation cls_diff cls W := (Clauses.diff (cls ↓ W) (cls ⇂ W)) (only parsing). - -(* - Equations? extend_model {W cls} (m : valid_model W (cls ⇂ W)) - (r : result W (Clauses.diff (cls ↓ W) (cls ⇂ W))) - : result W (cls ↓ W) := - extend_model _ Loop := Loop; - extend_model m (Model w m' sub) := - Model w {| model_model := m'.(model_model) |} _. - Proof. - - apply LevelSet.subset_spec in sub. now apply clauses_conclusions_clauses_with_concl in H. - - eapply sub. now eapply m.(model_clauses_conclusions). - - apply m. - - eapply LevelSet.subset_spec. eapply LevelSet.subset_spec in sub. - now transitivity V. - Qed. - - *) - -Lemma not_mem l s : ~~ LevelSet.mem l s <-> ~ LevelSet.In l s. -Proof. - split. apply contraNnot. apply LevelSet.mem_spec. - eapply contra_notN; tea. now move/LevelSet.mem_spec. -Qed. - -Lemma v_minus_w_bound_irrel {W} m m' : - model_map_outside W m m' -> - v_minus_w_bound W m = v_minus_w_bound W m'. -Proof. - unfold v_minus_w_bound. - intros out. eapply LevelMapFact.fold_Equal. tc. cbn. - { intros x y eq. cbn. solve_proper. } - { intros x y. cbn. intros e e' a neq. lia. } - apply LevelMapFact.F.Equal_mapsto_iff. - intros k e. rewrite -> LevelMapFact.filter_iff. - 2:{ intros x y eq. red in eq. subst; solve_proper. } - rewrite -> LevelMapFact.filter_iff. - 2:{ move=> x y ->. solve_proper. } - rewrite [_ = true]not_mem. intuition auto. - - now apply out. - - now apply out. -Qed. - -Definition max_premise_value (m : model) (l : nonEmptyLevelExprSet) : nat := - let (hd, tl) := NonEmptySetFacts.to_nonempty_list l in - fold_left (fun min atom => Nat.max (levelexpr_value m atom) min) tl (levelexpr_value m hd). - -Definition non_W_atoms W (l : LevelExprSet.t) := - LevelExprSet.filter (fun lk => ~~ LevelSet.mem lk.1 W) l. - -Lemma non_W_atoms_spec W l : forall x, LevelExprSet.In x (non_W_atoms W l) <-> LevelExprSet.In x l /\ ~ LevelSet.In x.1 W. -Proof. - intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec -not_mem. -Qed. - -Lemma non_W_atoms_subset W l : non_W_atoms W l ⊂_leset l. -Proof. intros x. now rewrite /non_W_atoms LevelExprSet.filter_spec. Qed. - -Lemma levelexprset_levels_spec_aux l (e : LevelExprSet.t) acc : - LevelSet.In l (LevelExprSet.fold (fun le : LevelExprSet.elt => LevelSet.add (level le)) e acc) <-> - (exists k, LevelExprSet.In (l, k) e) \/ LevelSet.In l acc. -Proof. - eapply LevelExprSetProp.fold_rec. - - intros. - intuition auto. destruct H1 as [k hin]. lesets. - - intros x a s' s'' hin nin hadd ih. - rewrite LevelSet.add_spec. - split. - * intros [->|]. - left. exists (levelexpr_k x). - apply hadd. cbn. left. now destruct x. - apply ih in H. - intuition auto. - left. destruct H0 as [k Hk]. exists k. apply hadd. now right. - * intros [[k ins'']|inacc]. - eapply hadd in ins''. destruct ins''; subst. - + now left. - + right. apply ih. now left; exists k. - + right. intuition auto. -Qed. - -Lemma levelexprset_levels_spec l (e : LevelExprSet.t) : - LevelSet.In l (levels e) <-> exists k, LevelExprSet.In (l, k) e. -Proof. - rewrite levelexprset_levels_spec_aux. intuition auto. lsets. -Qed. - -Lemma levels_exprs_non_W_atoms {W prem} : - LevelSet.Equal (levels (non_W_atoms W prem)) (LevelSet.diff (levels prem) W). -Proof. - intros e. unfold non_W_atoms. - rewrite levelexprset_levels_spec LevelSet.diff_spec levelexprset_levels_spec. - firstorder eauto. - rewrite LevelExprSet.filter_spec in H. now exists x. - rewrite LevelExprSet.filter_spec in H. destruct H. - rewrite LevelSetFact.not_mem_iff. - destruct LevelSet.mem => //. - exists x. - rewrite LevelExprSet.filter_spec. split => //. - rewrite LevelSetFact.not_mem_iff in H0. now rewrite H0. -Qed. - -Lemma levelexprset_empty_levels x : LevelExprSet.Empty x <-> LevelSet.Empty (levels x). -Proof. - split. - - intros he. - intros l hin. - eapply levelexprset_levels_spec in hin as [k hin]. lesets. - - intros emp l hin. eapply emp. eapply (levelexprset_levels_spec l.1). exists l.2. - now destruct l. -Qed. - -Lemma non_W_atoms_ne W cl cls : - Clauses.In cl (cls_diff cls W) -> - LevelExprSet.is_empty (non_W_atoms W (premise cl)) = false. -Proof. - intros x. - apply Clauses.diff_spec in x as [clw clr]. - eapply in_clauses_with_concl in clw as [clw incls]. - apply/negbTE. - apply/(contra_notN _ clr). - intros he. rewrite in_restrict_clauses. split => //. - epose proof (@levels_exprs_non_W_atoms W (premise cl)). - eapply LevelExprSetFact.is_empty_2 in he. - intros x hin. eapply levelexprset_empty_levels in he. rewrite H in he. - specialize (he x). rewrite LevelSet.diff_spec in he. intuition auto. - rewrite -LevelSet.mem_spec in H1 |- *. destruct LevelSet.mem; intuition auto. -Qed. - -Section MoreNonEmpty. - - Import LevelExprSet. - Import NonEmptySetFacts. - - Lemma In_elements {x} {s : nonEmptyLevelExprSet} : In x s <-> List.In x (elements s). - Proof. - split. now move/LevelExprSetFact.elements_1/InA_In_eq. - now move/InA_In_eq/LevelExprSetFact.elements_2. - Qed. - - Lemma min_premise_spec_aux (m : model) s k : - min_premise m s = k -> - (forall x, LevelExprSet.In x s -> (k <= min_atom_value m x)%Z) /\ - (exists x, LevelExprSet.In x s /\ k = min_atom_value m x). - Proof. - unfold min_premise. - move: (to_nonempty_list_spec s). - destruct (to_nonempty_list s). intros heq. - setoid_rewrite In_elements. rewrite -heq. clear s heq. - intros <-. - induction l. - - cbn. - split. intros x [->|] => //. reflexivity. - now exists t0; split => //. - - destruct IHl as [ha hex]. - split; intros. - eapply (in_elt_inv x a [t0]) in H as [<-|inih]. - cbn. rewrite fold_left_comm. lia. lia. - specialize (ha _ inih). - cbn. rewrite fold_left_comm. lia. lia. - destruct hex as [minval [inmin ih]]. - cbn. rewrite fold_left_comm. lia. - destruct (Z.leb_spec (min_atom_value m a) (min_atom_value m minval)). - exists a. split; [intuition|]. lia. exists minval. - cbn in inmin; split; [intuition auto|]. lia. - Qed. - - Lemma min_premise_spec (m : model) (s : nonEmptyLevelExprSet) : - (forall x, LevelExprSet.In x s -> (min_premise m s <= min_atom_value m x)%Z) /\ - (exists x, LevelExprSet.In x s /\ min_premise m s = min_atom_value m x). - Proof. - now apply min_premise_spec_aux. - Qed. - - Lemma min_premise_subset (m : model) (s s' : nonEmptyLevelExprSet) : - LevelExprSet.Subset s s' -> - (min_premise m s' <= min_premise m s)%Z. - Proof. - intros sub. - have [has [mins [ins eqs]]] := min_premise_spec m s. - have [has' [mins' [ins' eqs']]] := min_premise_spec m s'. - specialize (sub _ ins). specialize (has' _ sub). - lia. - Qed. - - Lemma premise_min_spec_aux s k : - premise_min s = k -> - (forall x, LevelExprSet.In x s -> (k <= x)) /\ - (exists x, LevelExprSet.In x s /\ k = x). - Proof. - unfold premise_min. - move: (to_nonempty_list_spec s). - destruct (to_nonempty_list s). intros heq. - setoid_rewrite In_elements. rewrite -heq. clear s heq. - intros <-. - induction l. - - cbn. - split. intros x [->|] => //. - now exists t0; split => //. - - destruct IHl as [ha hex]. - split; intros. - eapply (in_elt_inv x a [t0]) in H as [<-|inih]. - cbn. rewrite fold_left_comm. unfold level_expr_elt in *; lia. unfold level_expr_elt in *; lia. - specialize (ha _ inih). - cbn. rewrite fold_left_comm. lia. lia. - destruct hex as [minval [inmin ih]]. - cbn. rewrite fold_left_comm. lia. - destruct (Nat.leb_spec a minval). - exists a. split; [intuition|]. rewrite -ih in H. unfold level_expr_elt in *; lia. - exists minval. - cbn in inmin; split; [intuition auto|]. lia. - Qed. - - Lemma premise_min_spec (s : nonEmptyLevelExprSet) : - (forall x, LevelExprSet.In x s -> premise_min s <= x) /\ - (exists x, LevelExprSet.In x s /\ premise_min s = x). - Proof. - now apply premise_min_spec_aux. - Qed. - - Lemma premise_min_subset (s s' : nonEmptyLevelExprSet) : - LevelExprSet.Subset s s' -> - premise_min s' <= premise_min s. - Proof. - intros sub. - have [has [mins [ins eqs]]] := premise_min_spec s. - have [has' [mins' [ins' eqs']]] := premise_min_spec s'. - specialize (sub _ ins). specialize (has' _ sub). - lia. - Qed. - - Lemma max_premise_value_spec_aux (m : model) s k : - max_premise_value m s = k -> - (forall x, LevelExprSet.In x s -> levelexpr_value m x <= k) /\ - (exists x, LevelExprSet.In x s /\ k = levelexpr_value m x). - Proof. - unfold max_premise_value. - move: (to_nonempty_list_spec s). - destruct (to_nonempty_list s). intros heq. - setoid_rewrite In_elements. rewrite -heq. clear s heq. - intros <-. - induction l. - - cbn. - split. intros x [->|] => //. - now exists t0; split => //. - - destruct IHl as [ha hex]. - split; intros. - eapply (in_elt_inv x a [t0]) in H as [<-|inih]. - cbn. rewrite fold_left_comm. lia. lia. - specialize (ha _ inih). - cbn. rewrite fold_left_comm. lia. lia. - destruct hex as [maxval [inmax ih]]. - cbn. rewrite fold_left_comm. lia. - destruct (Nat.leb_spec (levelexpr_value m maxval) (levelexpr_value m a)). - exists a. split; [intuition|]. lia. exists maxval. - cbn in inmax; split; [intuition auto|]. lia. - Qed. - - Lemma max_premise_value_spec (m : model) (s : nonEmptyLevelExprSet) : - (forall x, LevelExprSet.In x s -> levelexpr_value m x <= max_premise_value m s) /\ - (exists x, LevelExprSet.In x s /\ max_premise_value m s = levelexpr_value m x). - Proof. - now apply max_premise_value_spec_aux. - Qed. -End MoreNonEmpty. - -Lemma min_premise_pos_spec {m prem} : - (0 <= min_premise m prem)%Z -> - forall x, LevelExprSet.In x prem -> levelexpr_k x <= levelexpr_value m x. -Proof. - pose proof (min_premise_spec m prem) as [amin [exmin [inminpre eqminpre]]]. - intros hprem x hin. - specialize (amin _ hin). - unfold min_atom_value in amin. - destruct x as [l k]; cbn in *. unfold levelexpr_value; cbn. - lia. -Qed. - -Definition equal_model (m m' : model) := LevelMap.Equal m m'. - -#[local] Instance equal_model_equiv : Equivalence equal_model. -Proof. unfold equal_model. - split; try econstructor; eauto. - red. intros. now symmetry. - red; intros. now transitivity y. -Qed. - -#[local] Instance level_value_proper : Proper (equal_model ==> eq ==> eq) level_value. -Proof. - intros x y eqm l ? <-. unfold level_value. - unfold equal_model in eqm. - destruct LevelMap.find eqn:hl. - - eapply LevelMap.find_2 in hl. - rewrite eqm in hl. - eapply LevelMap.find_1 in hl. now rewrite hl. - - eapply LevelMapFact.F.not_find_in_iff in hl. - rewrite eqm in hl. - eapply LevelMapFact.F.not_find_in_iff in hl. - now rewrite hl. -Qed. - -Lemma v_minus_w_bound_spec W m : - forall x, ~ LevelSet.In x W -> level_value m x <= v_minus_w_bound W m. -Proof. - intros x him. - unfold v_minus_w_bound. - set (fm := LevelMapFact.filter _ _). - replace (level_value m x) with (level_value fm x). - 2:{ unfold level_value. - destruct LevelMap.find eqn:hl => //. - eapply LevelMap.find_2 in hl. - subst fm. cbn in hl. - eapply LevelMapFact.filter_iff in hl as []. 2:tc. - rewrite (LevelMap.find_1 H) //. - destruct (LevelMap.find _ m) eqn:hl' => //. - eapply LevelMap.find_2 in hl'. - assert (LevelMap.MapsTo x n fm). - eapply LevelMapFact.filter_iff. tc. - split => //. now rewrite [_ = true]not_mem. - now rewrite (LevelMap.find_1 H) in hl. } - clearbody fm. - eapply LevelMapFact.fold_rec. - - intros m' em. unfold level_value. - destruct LevelMap.find eqn:hl => //. - eapply LevelMap.find_2 in hl. - now apply em in hl. - - intros k e a m' m'' map nin hadd. - red in hadd. - unfold level_value. cbn. - rewrite hadd LevelMapFact.F.add_o. - destruct LevelMap.OT.eq_dec. do 2 red in e0. subst x. lia. - destruct LevelMap.find; lia. -Qed. - -Lemma clauses_levels_restrict_clauses cls W : - LevelSet.Subset (clauses_levels (cls ⇂ W)) W. -Proof. - intros x [cl []] % clauses_levels_spec. - eapply in_restrict_clauses in H as [hconc hprem incl]. - eapply clause_levels_spec in H0 as []. apply hprem, H. now subst x. -Qed. - -Lemma clauses_conclusions_levels cls : - clauses_conclusions cls ⊂_lset clauses_levels cls. -Proof. - intros x. - rewrite clauses_conclusions_spec clauses_levels_spec. - setoid_rewrite clause_levels_spec. - firstorder auto. -Qed. - -Record model_extension W m m' := - { model_ext_le : m ⩽ m'; - model_ext_same_domain : model_same_domain m m'; - model_ext_same_outside : model_map_outside W m m' }. - -#[local] Instance model_ext_reflexive W : Reflexive (model_extension W). -Proof. - intros m; split; reflexivity. -Qed. - -#[local] Instance model_ext_transitive W : Transitive (model_extension W). -Proof. - intros m m' m'' h h'; split; (etransitivity; [apply h|apply h']). -Qed. - -Lemma model_extension_weaken W W' m m' : - W ⊂_lset W' -> - model_extension W m m' -> - model_extension W' m m'. -Proof. - intros leW []; split => //. - eapply model_map_outside_weaken; tea. -Qed. - -Lemma model_ext_trans_weaken W W' m m' m'' : - W ⊂_lset W' -> - model_extension W m m' -> - model_extension W' m' m'' -> - model_extension W' m m''. -Proof. - intros leW mext mext'. eapply model_extension_weaken in mext; tea. - now etransitivity; tea. -Qed. - -Definition check_model_invariants cls w m w' m' (modified : bool) := - if modified then - [/\ w ⊂_lset w', - w' ⊂_lset (LevelSet.union w (clauses_conclusions cls)), - exists cl, - let cll := (levelexpr_level (concl cl)) in - [/\ Clauses.In cl cls, ~~ valid_clause m cl, - LevelSet.In cll w' & - level_value m cll < level_value m' cll] & - model_extension w' m m'] - else (w, m) = (w', m'). - -#[local] Instance clauses_conclusions_proper : Proper (Clauses.Equal ==> LevelSet.Equal) clauses_conclusions. -Proof. - intros cls cls' eq x. - rewrite !clauses_conclusions_spec. now setoid_rewrite eq. -Qed. - -#[local] Instance And3P_proper : Proper (iff ==> iff ==> iff ==> iff) ssrbool.and3. -Proof. - repeat intro. split; intros []; split; intuition auto. -Qed. - -#[local] Instance And4P_proper : Proper (iff ==> iff ==> iff ==> iff ==> iff) ssrbool.and4. -Proof. - repeat intro. split; intros []; split; intuition auto. -Qed. - -#[local] Instance check_model_invariants_proper : - Proper (Clauses.Equal ==> eq ==> eq ==> eq ==> eq ==> eq ==> iff) check_model_invariants. -Proof. - intros cls cls' eqcls. - repeat intro; subst. - unfold check_model_invariants. - destruct y3 => //. - now setoid_rewrite <-eqcls. -Qed. - -Lemma min_atom_value_levelexpr_value m l : Z.to_nat (min_atom_value m l) <= levelexpr_value m l - l. -Proof. - destruct l as [l k]; cbn. unfold levelexpr_value. cbn. lia. -Qed. - -Lemma clauses_conclusions_add cl cls : - clauses_conclusions (Clauses.add cl cls) =_lset - (LevelSet.singleton (level (concl cl)) ∪ - clauses_conclusions cls). -Proof. - intros x. - rewrite LevelSet.union_spec !clauses_conclusions_spec. - setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.singleton_spec. - firstorder eauto. subst. now left. -Qed. - -Definition declared_model_level (m : model) l := LevelMap.In l m. - -Definition clause_conclusion cl := levelexpr_level (concl cl). - -Definition update_model_same_domain {m l k} : - declared_model_level m l -> - model_same_domain m (update_model m l k). -Proof. - unfold update_model, declared_model_level. - intros hin x. - rewrite LevelMapFact.F.add_in_iff. intuition auto. now subst. -Qed. - -Definition update_model_outside {m w l k} : - model_map_outside (LevelSet.add l w) m (update_model m l k). -Proof. - unfold update_model, model_map_outside. - intros l'. rewrite LevelSet.add_spec. - intros hin k'. - rewrite LevelMapFact.F.add_neq_mapsto_iff //. - intros heq. red in heq; subst l'. apply hin. now left. -Qed. - -Lemma check_clause_model_modify' {cl cls w m w' m' w'' m'' modified modified'} : - check_model_invariants cls w m w' m' modified -> - declared_model_level m (clause_conclusion cl) -> - check_clause_model cl (modified, (w', m')) = (modified', (w'', m'')) -> - check_model_invariants (Clauses.add cl cls) w m w'' m'' modified'. -Proof. - intros inv declcl. - unfold check_clause_model. - destruct (update_value (w', m') cl) eqn:upd. - * intros [= <- <-]. subst. - destruct modified. 2:{ noconf inv. reflexivity. } - destruct inv. - split => //. - + rewrite clauses_conclusions_add; lsets. - + destruct H1 as [cl' []]. - exists cl'; split => //. now rewrite Clauses.add_spec. - * intros [= <- <-]. subst. - destruct modified. 2:{ noconf inv. reflexivity. } - destruct inv. - split => //. - + rewrite clauses_conclusions_add; lsets. - + destruct H1 as [cl' []]. - exists cl'; split => //. now rewrite Clauses.add_spec. - * intros [= <- ->]. - move: upd. - unfold update_value. - case: Z.ltb_spec => //. - destruct cl as [prem [l k]] => /=. - intros hprem. - case: Nat.leb_spec => // hlt. - intros [= <- <-]. - destruct modified; noconf inv. - { destruct inv. - split => //. - + lsets. - + rewrite clauses_conclusions_add. - intros x. rewrite LevelSet.add_spec !LevelSet.union_spec LevelSet.singleton_spec. - intuition eauto. cbn. apply H0 in H4. lsets. - + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. - destruct H1 as [cl []]; exists cl; split => //. eauto. eauto. - eapply Nat.lt_le_trans; tea. - eapply model_le_values. - now eapply update_model_monotone. - + transitivity m'. - { eapply model_extension_weaken; tea. lsets. } - split. - { now eapply update_model_monotone. } - { eapply update_model_same_domain. - eapply H2, declcl. } - { eapply update_model_outside. } } - { split => //. - + lsets. - + rewrite clauses_conclusions_add. - intros x. rewrite LevelSet.add_spec !LevelSet.union_spec LevelSet.singleton_spec. - intuition eauto. - + setoid_rewrite Clauses.add_spec; setoid_rewrite LevelSet.add_spec. - exists (prem, (l, k)). - split; tea; eauto. - - unfold valid_clause. cbn. - case: Z.ltb_spec => //. cbn. lia. intros _. - rewrite -Nat.ltb_antisym. apply Nat.ltb_lt; lia. - - cbn. now rewrite level_value_update_model. - + split. - { now eapply update_model_monotone. } - { eapply update_model_same_domain. - eapply declcl. } - { eapply update_model_outside. } } -Qed. - -Definition model_of V (m : model) := - forall k, LevelSet.In k V -> LevelMap.In k m. - -Lemma model_of_subset V V' m : - model_of V m -> V' ⊂_lset V -> model_of V' m. -Proof. - rewrite /model_of. intros ih hv k. specialize (ih k). - now move/hv. -Qed. - -Lemma clauses_conclusions_subset {cls cls'} : - Clauses.Subset cls cls' -> - clauses_conclusions cls ⊂_lset clauses_conclusions cls'. -Proof. - intros hsub x. rewrite !clauses_conclusions_spec. - intuition eauto. destruct H as [cl []]; exists cl; split; try clsets; auto. -Qed. - -Lemma check_model_aux_spec {cls w m w' m' modified} : - model_of (clauses_conclusions cls) m -> - check_model_aux cls (w, m) = (modified, (w', m')) -> - check_model_invariants cls w m w' m' modified. -Proof. - rewrite /check_model_aux /is_model. - revert modified w' m'. - eapply ClausesProp.fold_rec. - - intros s' e modified w' m' mof [= <- <- <-]. - split. - - intros x ? s' s'' inx nins' hadd ih modified w' m' mof. - destruct a as [modified'' [w'' m'']]. - assert (ms' : model_of (clauses_conclusions s') m). - { eapply model_of_subset; tea. - eapply clauses_conclusions_subset. red in hadd. intros ?. - specialize (hadd a). intuition auto. } - specialize (ih _ _ _ ms' eq_refl). - apply ClausesProp.Add_Equal in hadd. rewrite hadd. - eapply check_clause_model_modify' => //. - red. apply mof. - apply clauses_conclusions_spec. exists x; split => //. - apply hadd. clsets. -Qed. - -Lemma check_model_spec {cls w m w' m'} : - model_of (clauses_conclusions cls) m -> - check_model cls (w, m) = Some (w', m') -> - check_model_invariants cls w m w' m' true. -Proof. - intros mof. - unfold check_model. - destruct check_model_aux eqn:cm. - destruct p as []. - eapply check_model_aux_spec in cm => //. - destruct b => //. now intros [= <- <-]. -Qed. - -Lemma check_model_aux_not_model {cls w m w' m'} : - model_of (clauses_conclusions cls) m -> - check_model_aux cls (w, m) = (true, (w', m')) -> - ~~ is_model cls m. -Proof. - intros mof. - move/(check_model_aux_spec mof) => [] _ _ [cl [incl inval]] _ _ _. - unfold is_model. - apply clauses_for_all_neg. - intros hf. specialize (hf cl incl). cbn in hf. - rewrite /is_true hf in inval => //. -Qed. - -Lemma check_model_is_model {W cls m} : - model_of (clauses_conclusions cls) m -> - check_model cls (W, m) = None <-> is_model cls m. -Proof. - intros mof; unfold check_model, is_model. - destruct check_model_aux eqn:caux. - destruct b => //. intuition auto. congruence. - { destruct p; eapply check_model_aux_not_model in caux => //. - rewrite /is_model /= // in caux. now rewrite H in caux. } - intuition auto. - pose proof (check_model_aux_false caux). subst p. - now rewrite check_model_aux_model in caux. -Qed. - -Lemma check_model_update {W cls m wm'} : - model_of (clauses_conclusions cls) m -> - check_model cls (W, m) = Some wm' -> ~~ is_model cls m /\ m ⩽ wm'.2. -Proof. - intros mof; unfold check_model, is_model. - destruct check_model_aux eqn:caux. - destruct b => //. intros [= <-]. intuition auto. - destruct p. - now eapply check_model_aux_not_model in caux. - now eapply check_model_aux_model_le in caux. -Qed. - -Definition measure_w W cls m w := - let bound := v_minus_w_bound W m in - let maxgain := max_gain (cls_diff cls W) in - (Z.of_nat bound + Z.of_nat maxgain - Z.of_nat (level_value m w))%Z. - -Lemma invalid_clause_measure W cls cl m : - ~~ valid_clause m cl -> - Clauses.In cl (cls_diff cls W) -> - (0 < measure_w W cls m (concl cl))%Z. -Proof. - unfold valid_clause. - case: Z.ltb_spec => // hprem. - destruct cl as [prem [l k]]; cbn. - case: Nat.leb_spec => // hlt. intros _ hin. - have hne := (non_W_atoms_ne _ _ _ hin). - cbn. unfold measure_w. unfold gain. - set (clsdiff := Clauses.diff _ _). - set (bound := v_minus_w_bound W m). - enough (Z.of_nat (level_value m l) < Z.of_nat bound + Z.of_nat (max_gain clsdiff))%Z. lia. - set (prem' := non_W_atoms W prem). - set (preml := {| t_set := prem'; t_ne := hne |}). - assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff). - { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. - unfold gain. cbn. - pose proof (premise_min_subset preml prem). - rewrite !Z2Nat.inj_sub //; try lia. rewrite !Nat2Z.id. - forward H. eapply non_W_atoms_subset. lia. } - eapply Z.lt_le_trans with (Z.of_nat bound + Z.of_nat (Z.to_nat (gain (preml, (l, k)))))%Z; try lia. - rewrite -Nat2Z.inj_add. - unfold gain; cbn. - enough (level_value m l < v_minus_w_bound W m + (k - premise_min preml)). lia. - enough (k + Z.to_nat (min_premise m prem) <= v_minus_w_bound W m + (k - premise_min preml)). lia. - assert (min_premise m prem <= min_premise m preml)%Z. - { eapply min_premise_subset. eapply non_W_atoms_subset. } - transitivity (k + Z.to_nat (min_premise m preml)). lia. - pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. - pose proof (max_premise_value_spec m preml) as [amax [exmax [inmaxpre eqmaxpre]]]. - pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. - assert (premise_min prem <= premise_min preml). - { eapply premise_min_subset. eapply non_W_atoms_subset. } - transitivity (v_minus_w_bound W m + (k - premise_min preml)). 2:lia. - assert (Z.to_nat (min_premise m preml) <= max_premise_value m preml - premise_min preml). - { rewrite eqpminpre eqmaxpre eqminpre. - pose proof (min_atom_value_levelexpr_value m exmin). etransitivity; tea. - specialize (amax _ inminpre). rewrite eqmaxpre in amax. - assert (expmin <= exmin). specialize (apmin _ inminpre). lia. - unfold level_expr_elt in *. lia. } - transitivity (k + (max_premise_value m preml - premise_min preml)). lia. - assert (premise_min preml <= max_premise_value m preml). - { rewrite eqmaxpre. - move/min_premise_pos_spec: hprem => hprem. - transitivity exmax. apply apmin => //. eapply hprem. - now apply (non_W_atoms_subset W prem). } - assert (k + (max_premise_value m preml - premise_min preml) = - (max_premise_value m preml + k - premise_min preml)) as ->. lia. - enough (max_premise_value m preml <= v_minus_w_bound W m). lia. - { rewrite eqmaxpre. - apply v_minus_w_bound_spec. - intros hin'. - have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). - rewrite levelexprset_levels_spec in hlevels. - forward hlevels. - exists exmax.2. now destruct exmax. - rewrite LevelSet.diff_spec in hlevels. - now destruct hlevels. } -Qed. - -Definition levelset_m_eq : LevelSet.t × model -> LevelSet.t × model -> Prop := - fun x y => LevelSet.Equal x.1 y.1 /\ LevelMap.Equal x.2 y.2. - -#[local] Instance lmeq_eq : Equivalence levelset_m_eq. -Proof. - split. intros x. split => //. - intros x y []; split => //. now rewrite H. - intros x y z [] []; split => //. - all:etransitivity; tea. -Qed. - -Definition modified_levelset_m_eq : bool × LevelSet.t × model -> bool × LevelSet.t × model -> Prop := - fun x y => x.1 = y.1 /\ levelset_m_eq x.2 y.2. - -#[local] Instance mlm_eq : Equivalence modified_levelset_m_eq. -Proof. - split. intros x. split => //. - intros x y []; split => //. now symmetry. - intros x y z [] []; split => //. all:etransitivity; tea. -Qed. - -#[local] Instance min_atom_value_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_atom_value. -Proof. - intros m m' eqm ? ? ->. unfold min_atom_value. - destruct y => //. - now rewrite eqm. -Qed. - -#[local] Instance fold_left_ext {A B} : Proper (`≐2` ==> eq ==> eq ==> eq) (@fold_left A B). -Proof. - intros f g hfg ? ? -> ? ? ->. - induction y in y0 |- *; cbn; auto. now rewrite (hfg y0 a). -Qed. - -#[local] Instance min_premise_proper : Proper (LevelMap.Equal ==> eq ==> eq) min_premise. -Proof. - intros m m' eq ? ? ->. - unfold min_premise. - destruct to_nonempty_list. - now setoid_rewrite eq. -Qed. - -#[local] Instance update_model_proper : Proper (LevelMap.Equal ==> eq ==> eq ==> LevelMap.Equal) update_model. -Proof. - intros m m' hm ? ? -> ? ? ->. - unfold update_model. - now rewrite hm. -Qed. - -#[local] Instance check_clause_model_proper : Proper (eq ==> modified_levelset_m_eq ==> modified_levelset_m_eq) check_clause_model. -Proof. - intros x y eq [? []] [? []] []; cbn in *; subst. - unfold levelset_m_eq in H0. destruct H0; cbn in *; subst. - replace (min_premise m (premise y)) with (min_premise m0 (premise y)). - 2: now rewrite H0. - destruct Z.ltb => //. - destruct concl => //. - replace (level_value m t1) with (level_value m0 t1). - 2:now rewrite H0. - destruct Nat.leb => //. - red. cbn. split => //. - red. cbn; split => //. now rewrite H. now rewrite H0. -Qed. - -Module ClausesOrd := OrdProperties Clauses. - - -#[local] Instance check_model_aux_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model_aux. -Proof. - intros cls cls' eq. - intros wm wm' eq'. subst wm'. - unfold check_model_aux. - now eapply ClausesOrd.fold_equal; tc. -Qed. - -#[local] Instance check_model_aux_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> modified_levelset_m_eq) check_model_aux. -Proof. - intros cls cls' eq. - intros wm wm' eq'. - transitivity (check_model_aux cls' wm). - 2:{ unfold check_model_aux. - eapply (ClausesProp.fold_init (eqA := modified_levelset_m_eq)); tc. - red. cbn => //. } - unfold check_model_aux. - now eapply ClausesOrd.fold_equal; tc. -Qed. - -#[local] Instance check_model_proper : Proper (Clauses.Equal ==> levelset_m_eq ==> R_opt levelset_m_eq) check_model. -Proof. - intros cls cls' eq. - intros wm wm' eq'. - unfold check_model. - destruct (check_model_aux cls wm) eqn:eqc. - destruct (check_model_aux cls' wm') eqn:eqc' => //. - pose proof (check_model_aux_proper cls cls' eq wm wm' eq'). - rewrite eqc eqc' in H. destruct H; cbn in *; subst. - red in H0. destruct H0. - destruct b0 => //. -Qed. - -#[local] Instance check_model_proper_eq : Proper (Clauses.Equal ==> eq ==> eq) check_model. -Proof. - intros cls cls' eq. - intros wm wm' eq'. - unfold check_model. - now subst wm'; rewrite eq. -Qed. - -Record valid_model_def (V : LevelSet.t) (m : model) (cls : clauses) := - { model_model : model; - model_of_V :> model_of V model_model; - model_clauses_conclusions : clauses_conclusions cls ⊂_lset V; - model_ok :> is_model cls model_model; - model_extends : model_extension V m model_model; - }. -Arguments model_model {V m cls}. -Arguments model_of_V {V m cls}. -Arguments model_clauses_conclusions {V m cls}. -Arguments model_ok {V m cls}. -Arguments model_extends {V m cls}. -Extraction Inline model_model. - -Definition valid_model := valid_model_def. - -Inductive result (V U : LevelSet.t) (cls : clauses) (m : model) := - | Loop - | Model (w : LevelSet.t) (m : valid_model V m cls) (prf : U ⊂_lset w /\ w ⊂_lset V). -Arguments Loop {V U cls m}. -Arguments Model {V U cls m}. -Arguments lexprod {A B}. - -Definition option_of_result {V U m cls} (r : result V U m cls) : option model := - match r with - | Loop => None - | Model w m sub => Some m.(model_model) - end. - -Definition extends_model {W U cls m m'} : - m' ⩽ m -> - model_same_domain m' m -> - model_map_outside W m' m -> - result W U cls m -> result W U cls m'. -Proof. - intros leq ldom lout []. exact Loop. - econstructor 2; tea. - destruct m0. econstructor; tea. - - now transitivity m. -Qed. - -(* #[tactic="idtac"] -Equations? result_inclusion {V U m cls V'} (r : result V U cls m) - (prf : LevelSet.Subset V V') : result V' U cls m := - result_inclusion Loop _ := Loop; - result_inclusion (Model w m' sub) sub' := - Model w {| model_model := m'.(model_model) |} _. -Proof. - - - - transitivity V => //. now eapply m'.(model_clauses_conclusions). - - apply m'. - - apply m'. - - apply m'. - - intros x hin. apply m'. intros hv. - apply sub' in hv. now apply hin. - - intuition lsets. -Qed. *) - -Notation "#| V |" := (LevelSet.cardinal V). - -Notation loop_measure V W := (#|V|, #|V| - #|W|). - -Definition lexprod_rel := lexprod lt lt. - -#[local] Instance lexprod_rel_wf : WellFounded lexprod_rel. -Proof. - eapply (Acc_intro_generator 1000). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. -Defined. - -Section InnerLoop. - Context (V : LevelSet.t) (U : LevelSet.t) - (loop : forall (V' U' : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V', U' ⊂_lset V' & model_of V' m]), - lexprod_rel (loop_measure V' U') (loop_measure V U) -> result V' U' cls m). - - Definition sum_W W (f : LevelSet.elt -> nat) := - LevelSet.fold (fun w acc => acc + f w) W 0. - - Definition measure (W : LevelSet.t) (cls : clauses) (m : model) : nat := - sum_W W (fun w => Z.to_nat (measure_w W cls m w)). - - Lemma measure_model W cls m : - let clsdiff := cls_diff cls W in - measure W cls m = 0 -> is_model clsdiff m. - Proof using. - clear loop V U. - unfold measure, sum_W, measure_w, is_model. - set (clsdiff := Clauses.diff _ _). - intros hm. - assert (LevelSet.For_all (fun w => v_minus_w_bound W m + max_gain clsdiff <= level_value m w) W). - { move: hm. - generalize (v_minus_w_bound W m) => vbound. - eapply LevelSetProp.fold_rec. - intros. intros x hin. firstorder eauto. - intros x a s' s'' inw nins' hadd ih heq. - forward ih by lia. - intros l hin. - apply hadd in hin as []. - * subst x. lia. - * now apply ih. } - clear hm. - eapply ClausesFact.for_all_iff. tc. - intros cl hl. - unfold valid_clause. - case: Z.ltb_spec => // hk0. - destruct cl as [prem [l k]] => /=. - eapply Nat.leb_le. cbn in hk0. - rewrite /clsdiff in hl. - destruct (proj1 (Clauses.diff_spec _ _ _) hl) as [hlcls hl']. - eapply in_clauses_with_concl in hlcls as [lW incls]. - specialize (H _ lW). cbn -[clsdiff] in H. cbn in lW. - etransitivity; tea. - set (prem' := non_W_atoms W prem). - assert (ne : LevelExprSet.is_empty prem' = false). - { now eapply (non_W_atoms_ne W (prem, (l, k)) cls). } - set (preml := {| t_set := prem'; t_ne := ne |}). - assert (min_premise m prem <= min_premise m preml)%Z. - { eapply min_premise_subset. eapply non_W_atoms_subset. } - (* min_i (f(x_i)-k_i) <= max_i(f(x_i)) - min(k_i) *) - pose proof (min_premise_spec m preml) as [amin [exmin [inminpre eqminpre]]]. - pose proof (max_premise_value_spec m preml) as [amax [exmax [inmaxpre eqmaxpre]]]. - pose proof (premise_min_spec preml) as [apmin [expmin [inpminpre eqpminpre]]]. - assert (Z.to_nat (min_premise m preml) <= - (max_premise_value m preml) - premise_min preml). - { rewrite eqpminpre eqmaxpre eqminpre. - pose proof (min_atom_value_levelexpr_value m exmin). etransitivity; tea. - specialize (amax _ inminpre). rewrite eqmaxpre in amax. - assert (expmin <= exmin). specialize (apmin _ inminpre). lia. - unfold level_expr_elt in *. lia. } - transitivity (k + (max_premise_value m preml - premise_min preml)). lia. - assert (Z.to_nat (gain (preml, (l, k))) <= max_gain clsdiff). - { transitivity (Z.to_nat (gain (prem, (l, k)))). 2:now apply max_gain_in. - unfold gain. cbn. - pose proof (premise_min_subset preml prem). - rewrite !Z2Nat.inj_sub //; try lia. rewrite !Nat2Z.id. - forward H2. eapply non_W_atoms_subset. lia. } - transitivity (v_minus_w_bound W m + Z.to_nat (gain (preml, (l, k)))). - 2:lia. - unfold gain. cbn -[max_premise_value premise_min]. - assert (premise_min preml <= max_premise_value m preml). - { rewrite eqmaxpre. - move/min_premise_pos_spec: hk0 => hprem. - transitivity exmax. apply apmin => //. eapply hprem. - now apply (non_W_atoms_subset W prem). } - assert (k + (max_premise_value m preml - premise_min preml) = - (max_premise_value m preml + k - premise_min preml)) as ->. lia. - rewrite Z2Nat.inj_sub. lia. - rewrite !Nat2Z.id. - assert (max_premise_value m preml <= v_minus_w_bound W m). - { rewrite eqmaxpre. - apply v_minus_w_bound_spec. - intros hin. - have [hlevels _] := (@levels_exprs_non_W_atoms W prem (levelexpr_level exmax)). - rewrite levelexprset_levels_spec in hlevels. - forward hlevels. - exists exmax.2. now destruct exmax. - rewrite LevelSet.diff_spec in hlevels. - now destruct hlevels. } - lia. - Qed. - - Lemma measure_le {W cls m m'} : - model_map_outside W m m' -> - m ⩽ m' -> - (measure W cls m' <= measure W cls m). - Proof. - intros hout hle. - unfold measure, measure_w, sum_W. - rewrite (v_minus_w_bound_irrel _ _ hout). - rewrite !LevelSet.fold_spec. unfold flip. - eapply fold_left_le; unfold flip. 2:lia. - - intros. rewrite LevelSet_In_elements in H. - have lexx' := (model_le_values x hle). - lia. - Qed. - - Lemma measure_lt {W cls m m'} : - model_map_outside W m m' -> - m ⩽ m' -> - (exists l, [/\ LevelSet.In l W, (0 < measure_w W cls m l)%Z & level_value m l < level_value m' l]) -> - (measure W cls m' < measure W cls m). - Proof. - intros hout hle. - unfold measure, measure_w, sum_W. - rewrite (v_minus_w_bound_irrel _ _ hout). - intros hlt. - rewrite !LevelSet.fold_spec. unfold flip. - eapply fold_left_ne_lt; unfold flip. - - unfold flip. intros; lia. - - unfold flip; intros; lia. - - destruct hlt as [l [hin _]]. intros he. rewrite -LevelSetProp.elements_Empty in he. lsets. - - intros. rewrite LevelSet_In_elements in H. - have lexx' := (model_le_values x hle). - lia. - - intros. rewrite LevelSet_In_elements in H. - have lexx' := (model_le_values x hle). - lia. - - destruct hlt as [l [hinl hbound hlev]]. - exists l. rewrite LevelSet_In_elements. split => //. - intros acc acc' accle. - eapply Nat.add_le_lt_mono => //. lia. - Qed. - - Lemma is_model_equal {cls cls' m} : Clauses.Equal cls cls' -> is_model cls m -> is_model cls' m. - Proof. now intros ->. Qed. - - Lemma union_diff_eq {cls cls'} : Clauses.Equal (Clauses.union cls (Clauses.diff cls' cls)) - (Clauses.union cls cls'). - Proof. clsets. Qed. - - Lemma union_restrict_with_concl {cls W} : - Clauses.Equal (Clauses.union (cls ⇂ W) (cls ↓ W)) (cls ↓ W). - Proof. - intros cl. rewrite Clauses.union_spec. - intuition auto. - eapply in_clauses_with_concl. - now eapply in_restrict_clauses in H0 as []. - Qed. - - Lemma maps_to_level_value x (m m' : model) : - (forall k, LevelMap.MapsTo x k m <-> LevelMap.MapsTo x k m') -> - level_value m x = level_value m' x. - Proof. - intros heq. - unfold level_value. - destruct LevelMap.find eqn:hl. - apply LevelMap.find_2 in hl. rewrite heq in hl. - rewrite (LevelMap.find_1 hl) //. - destruct (LevelMap.find x m') eqn:hl' => //. - apply LevelMap.find_2 in hl'. rewrite -heq in hl'. - now rewrite (LevelMap.find_1 hl') in hl. - Qed. - - Lemma measure_Z_lt x y : - (x < y)%Z -> - (0 < y)%Z -> - Z.to_nat x < Z.to_nat y. - Proof. intros. lia. Qed. - - Lemma sum_pos W f : - (0 < sum_W W f) -> - exists w, LevelSet.In w W /\ (0 < f w). - Proof. - unfold sum_W. - eapply LevelSetProp.fold_rec => //. - intros. lia. - intros. - destruct (Nat.ltb_spec 0 a). - - destruct (H2 H4) as [w [hin hlt]]. exists w. split => //. apply H1. now right. - - exists x. split => //. apply H1. now left. lia. - Qed. - - Lemma measure_pos {W cls m} : - (0 < measure W cls m) -> - exists l, LevelSet.In l W /\ (0 < measure_w W cls m l)%Z. - Proof. - unfold measure. - move/sum_pos => [w [hin hlt]]. - exists w. split => //. lia. - Qed. - - Lemma model_of_diff cls W m : - model_of W m -> model_of (clauses_conclusions (cls_diff cls W)) m. - Proof. - intros; eapply model_of_subset; tea. - eapply clauses_conclusions_diff_left. - Qed. - Hint Resolve model_of_diff : core. - - Lemma check_model_spec_diff {cls w m w' m' w''} : - model_of w m -> - let cls := (cls_diff cls w) in - check_model cls (w'', m) = Some (w', m') -> - [/\ w'' ⊂_lset w', w' ⊂_lset (w'' ∪ w), - exists cl : clause, - let cll := levelexpr_level (concl cl) in - [/\ Clauses.In cl cls, ~~ valid_clause m cl, LevelSet.In cll w' - & level_value m cll < level_value m' cll] - & model_extension w' m m']. - Proof. - cbn; intros mof cm. - pose proof (clauses_conclusions_diff_left cls w (cls ⇂ w)). - apply check_model_spec in cm as []. - split => //. lsets. - eapply model_of_subset; tea. - Qed. - - Lemma model_of_ext {W W' m m'} : - model_of W m -> model_extension W' m m' -> model_of W m'. - Proof. - intros mof [_ dom _]. - intros k hin. apply dom. now apply mof. - Qed. - - Lemma clauses_partition_spec {cls W allW conclW} : - clauses_conclusions cls ⊂_lset W -> - Clauses.partition (premise_restricted_to W) cls = (allW, conclW) -> - (Clauses.Equal allW (cls ⇂ W)) /\ - (Clauses.Equal conclW (Clauses.diff cls (cls ⇂ W))). - Proof. - intros clW. - destruct Clauses.partition eqn:eqp. - intros [= <- <-]. - change t with (t, t0).1. - change t0 with (t, t0).2 at 2. - rewrite -eqp. clear t t0 eqp. - split. - - intros cl. rewrite Clauses.partition_spec1. - rewrite in_restrict_clauses Clauses.filter_spec. - rewrite /premise_restricted_to LevelSet.subset_spec. firstorder eauto. - apply clW, clauses_conclusions_spec. now exists cl. - - intros cl. rewrite Clauses.partition_spec2. - rewrite Clauses.filter_spec Clauses.diff_spec. - rewrite /premise_restricted_to. intuition auto. - move/negbTE: H1. eapply eq_true_false_abs. - eapply LevelSet.subset_spec. - now eapply in_restrict_clauses in H as []. - apply eq_true_not_negb. move/LevelSet.subset_spec => he. - apply H1. apply in_restrict_clauses. split => //. - apply clW, clauses_conclusions_spec. now exists cl. - Qed. - - Lemma clauses_conclusions_eq cls W : - clauses_conclusions cls ⊂_lset W -> - Clauses.Equal cls (cls ↓ W). - Proof. - intros cl x. - rewrite in_clauses_with_concl. intuition auto. - apply cl, clauses_conclusions_spec. now exists x. - Qed. - - Section innerloop_partition. - Context (W : LevelSet.t) (cls : clauses). - Context (premconclW conclW : clauses). - Context (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W, - Clauses.Equal premconclW (cls ⇂ W) & Clauses.Equal conclW (Clauses.diff (cls ↓ W) (cls ⇂ W))]). - - #[tactic="idtac"] - Equations? inner_loop_partition (m : model) (mW : model_of W m) : result W U cls m - by wf (measure W cls m) lt := - inner_loop_partition m mW with loop W LevelSet.empty premconclW m _ _ := { - (* premconclW = cls ⇂ W , conclW = (Clauses.diff (cls ↓ W) (cls ⇂ W)) *) - | Loop => Loop - (* We have a model for (cls ⇂ W), we try to extend it to a model of (csl ↓ W). - By invariant Wr ⊂ W *) - | Model Wr mr hsub with inspect (check_model conclW (Wr, model_model mr)) := { - | exist None eqm => Model W {| model_model := model_model mr |} _ - | exist (Some (Wconcl, mconcl)) eqm with inner_loop_partition mconcl _ := { - (* Here Wconcl ⊂ Wr by invariant *) - | Loop => Loop - | Model Wr' mr' hsub' => Model Wr' {| model_model := model_model mr' |} hsub' } - (* Here Wr' ⊂ W by invariant *) - (* We check if the new model [mr] for (cls ⇂ W) extends to a model of (cls ↓ W). *) - (* We're entitled to recursively compute a better model starting with mconcl, - as we have made the measure decrease: - some atom in W has been strictly updated in Wconcl. *) - } }. - Proof. - all:cbn [model_model]; clear loop inner_loop_partition. - all:try solve [try apply LevelSet.subset_spec; try reflexivity]. - all:try apply LevelSet.subset_spec in hsub. - all:auto. - all:try destruct prf as [WV neW UW clsW eqprem eqconcl]. - all:try solve [intuition auto]. - all:try rewrite eqconcl in eqm. - - split => //. rewrite eqprem. apply clauses_conclusions_restrict_clauses. lsets. - - left. now eapply strict_subset_cardinal. - - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. - eapply model_of_ext. 2:tea. apply mr. - - eapply (check_model_spec_diff mr) in eqm as [subwwconcl subwconcl hm hext] => //. - pose proof (clauses_conclusions_diff_left cls W (cls ⇂ W)). - destruct hm as [cll [hind nvalid inwconcl hl]]. - eapply Nat.lt_le_trans. - 2:{ eapply measure_le; eapply mr. } - eapply measure_lt. - { eapply model_map_outside_weaken. eapply hext. lsets. } - { apply hext. } - eapply invalid_clause_measure in nvalid; tea. - exists (levelexpr_level (concl cll)). - split => //. - eapply clauses_conclusions_diff_left; tea. - eapply clauses_conclusions_spec. exists cll; split => //. exact hind. - - apply mr'. - (* - apply clauses_conclusions_clauses_with_concl. *) - - apply mr'. - - eapply (check_model_spec_diff mr) in eqm as [eqw hm hext] => //. - eapply model_ext_trans_weaken. 2:apply mr. lsets. - transitivity mconcl. eapply model_extension_weaken. 2:tea. lsets. apply mr'. - - apply mr. - (* - eapply clauses_conclusions_clauses_with_concl. *) - - rewrite check_model_is_model in eqm. - 1:{ eapply model_of_diff, mr. } - have okm := (model_ok mr). - have mu := is_model_union okm eqm. - rewrite {1}eqprem in mu. - rewrite union_diff_eq in mu. - rewrite union_restrict_with_concl in mu. - now rewrite (clauses_conclusions_eq _ _ clsW). - - apply mr. - - split; lsets. - Qed. - End innerloop_partition. - - (* We first partition the clauses among those that mention only W and the ones that can mention other atoms. - We then call the loop on these two sets of clauses, which not need to change during the recursive calls. - *) - #[tactic="idtac"] - Equations? inner_loop (W : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ strict_subset W V, ~ LevelSet.Empty W, U ⊂_lset W, clauses_conclusions cls ⊂_lset W & model_of W m]) : - result W U cls m := - inner_loop W cls m prf with inspect (Clauses.partition (premise_restricted_to W) cls) := - | exist (premconclW, conclW) eqp => inner_loop_partition W cls premconclW conclW _ m _. - Proof. - - destruct prf as [subWV neW UW clsW mW]. - eapply (clauses_partition_spec clsW) in eqp as [eqprem eqconcl]. - split => //. now rewrite -(clauses_conclusions_eq _ _ clsW). - - apply prf. - Qed. - -End InnerLoop. - -Lemma diff_cardinal_inter V W : #|LevelSet.diff V W| = #|V| - #|LevelSet.inter V W|. -Proof. - pose proof (LevelSetProp.diff_inter_cardinal V W). lia. -Qed. - -Lemma diff_cardinal V W : W ⊂_lset V -> #|LevelSet.diff V W| = #|V| - #|W|. -Proof. - intros hsub. - rewrite diff_cardinal_inter LevelSetProp.inter_sym LevelSetProp.inter_subset_equal //. -Qed. - -Lemma is_modelP m cls : reflect (Clauses.For_all (valid_clause m) cls) (is_model cls m). -Proof. - case E: is_model; constructor. - - now move: E; rewrite /is_model -ClausesFact.for_all_iff. - - intros hf. apply ClausesFact.for_all_iff in hf; tc. unfold is_model in E; congruence. -Qed. - -Lemma is_model_invalid_clause cl cls m : is_model cls m -> ~~ valid_clause m cl -> ~ Clauses.In cl cls. -Proof. - move/is_modelP => ism /negP valid hin. - now specialize (ism _ hin). -Qed. - -Lemma strict_subset_leq_right U V W : - strict_subset U V -> V ⊂_lset W -> strict_subset U W. -Proof. - intros [] le. split. lsets. intros eq. rewrite -eq in le. - apply H0. lsets. -Qed. - -Lemma strict_subset_diff_incl V W W' : - strict_subset W' W -> - W ⊂_lset V -> - W' ⊂_lset V -> - strict_subset (LevelSet.diff V W) (LevelSet.diff V W'). -Proof. - intros [] lew lew'. - split. lsets. - intros eq. - apply H0. lsets. -Qed. - -(* To help equations *) -Opaque lexprod_rel_wf. - -Lemma check_model_spec_V {V cls w m w' m'} : - model_of V m -> clauses_conclusions cls ⊂_lset V -> - check_model cls (w, m) = Some (w', m') -> - check_model_invariants cls w m w' m' true. -Proof. - cbn; intros mof incl cm. - apply check_model_spec in cm => //. - eapply model_of_subset; tea. -Qed. - -Lemma valid_model_of {V W m cls} (m' : valid_model W m cls) : - model_of V m -> model_of V (model_model m'). -Proof. - intros mof. eapply model_of_ext; tea. eapply m'. -Qed. - -#[tactic="idtac"] -Equations? loop (V : LevelSet.t) (U : LevelSet.t) (cls : clauses) (m : model) - (prf : [/\ clauses_conclusions cls ⊂_lset V, U ⊂_lset V & model_of V m]) : result V U cls m - by wf (loop_measure V U) lexprod_rel := - loop V U cls m prf with inspect (check_model cls (U, m)) := - | exist None eqm => Model U {| model_model := m |} _ - | exist (Some (W, m')) eqm with inspect (LevelSet.equal W V) := { - | exist true eq := Loop - (* Loop on cls ↓ W, with |W| < |V| *) - | exist false neq with inner_loop V U loop W (cls ↓ W) m' _ := - { | Loop := Loop - | Model Wc mwc hsub' - (* We get a model for (cls ↓ W), we check if it extends to all clauses. - By invariant |Wc| cannot be larger than |W|. *) - with inspect (check_model cls (Wc, mwc.(model_model))) := - { | exist None eqm' => Model Wc {| model_model := mwc.(model_model) |} _ - | exist (Some (Wcls, mcls)) eqm' with inspect (LevelSet.equal Wcls V) := { - | exist true _ := Loop - | exist false neq' with loop V Wcls cls mcls _ := { - (* Here Wcls < V, we've found a model for all of the clauses with conclusion - in W, which can now be fixed. We concentrate on the clauses whose - conclusion is different. Clearly |W| < |V|, but |Wcls| is not - necessarily < |V| *) - | Loop := Loop - | Model Wvw mcls' hsub'' := Model Wvw {| model_model := model_model mcls' |} _ } } } - } - } - . -Proof. - all:clear loop. - all:try solve [intuition auto]. - all:try eapply levelset_neq in neq. - all:have cls_sub := clauses_conclusions_levels cls. - all:destruct prf as [clsV UV mof]. - - apply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext] => //. - split => //. split => //. lsets. - destruct hcl as [l [hl _]]. intros he. lsets. - apply clauses_conclusions_clauses_with_concl. - eapply model_of_ext; tea. eapply model_of_subset; tea. lsets. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - eapply check_model_spec in eqm' as []. - 2:{ eapply model_of_subset. 2:exact clsV. - exact (valid_model_of mwc (model_of_ext mof ext)). } - split. lsets. lsets. - exact (model_of_ext (valid_model_of mwc (model_of_ext mof ext)) H2). - - right. - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - eapply check_model_spec in eqm' as []. - 2:{ eapply model_of_subset. 2:exact clsV. - exact (valid_model_of mwc (model_of_ext mof ext)). } - destruct hsub' as [UWc WcW]. - assert (Wcls ⊂_lset V). lsets. - rewrite -!diff_cardinal //. - eapply strict_subset_cardinal. - assert (strict_subset Wc Wcls). - { split => //. - destruct H1 as [cl [clcls nvalid hcll hv]]. - pose proof (model_ok mwc). - eapply is_model_invalid_clause in H1; tea. - assert (~ LevelSet.In (levelexpr_level (concl cl)) W). - { intros hin. rewrite in_clauses_with_concl in H1. intuition auto. } - move/(_ (levelexpr_level (concl cl))) => [] wcwcls wclswc. - now apply H4, WcW, wclswc. } - eapply (strict_subset_leq_right _ (LevelSet.diff V Wc)). - 2:{ clear -UWc WcW UW WU H3 H4. lsets. } - apply strict_subset_diff_incl => //. clear -H H3; lsets. - - eapply mcls'. - - auto. - - exact mcls'. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - eapply check_model_spec in eqm' as []. - 2:{ eapply model_of_subset. 2:exact clsV. - exact (valid_model_of mwc (model_of_ext mof ext)). } - assert (WV : W ⊂_lset V). - { clear -UV clsV WU; lsets. } - eapply model_ext_trans_weaken => //. 2:tea. auto. - transitivity mcls; [|apply mcls']. - transitivity (model_model mwc). 2:{ eapply model_extension_weaken; [|tea]. lsets. } - eapply model_extension_weaken. 2:apply mwc. auto. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - eapply check_model_spec in eqm' as []. - 2:{ eapply model_of_subset. 2:exact clsV. - exact (valid_model_of mwc (model_of_ext mof ext)). } - split. lsets. lsets. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - refine (valid_model_of mwc _). - refine (model_of_ext mof ext). - - auto. - - rewrite check_model_is_model // in eqm'. - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - refine (valid_model_of mwc _). - eapply model_of_subset. - refine (model_of_ext mof ext). auto. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - transitivity m'. eapply model_extension_weaken; [|tea]. lsets. - eapply model_extension_weaken. 2:apply mwc. lsets. - - eapply (check_model_spec_V mof clsV) in eqm as [UW WU hcl ext]. - split; lsets. - - exact mof. - - exact clsV. - - apply check_model_is_model in eqm; eauto. - eapply model_of_subset; tea. - - reflexivity. - - split; lsets. -Qed. - -Transparent lexprod_rel_wf. - -Definition zero_model levels := - LevelSet.fold (fun l acc => LevelMap.add l 0 acc) levels (LevelMap.empty _). - -Definition add_max l k m := - match LevelMap.find l m with - | Some k' => - if k' LevelMap.add l k m - end. - -#[local] Instance proper_levelexprset_levels : Proper (LevelExprSet.Equal ==> LevelSet.Equal) - levels. -Proof. - intros s s' eq l. - rewrite !levelexprset_levels_spec. - firstorder eauto. -Qed. - -Lemma In_add_max l l' k acc : - LevelMap.In (elt:=nat) l (add_max l' k acc) <-> - (l = l' \/ LevelMap.In l acc). -Proof. - unfold add_max. - destruct LevelMap.find eqn:hl. - case: Nat.ltb_spec. - - rewrite LevelMapFact.F.add_in_iff /Level.eq. - firstorder eauto. - - intros. intuition auto. subst. - now rewrite LevelMapFact.F.in_find_iff hl. - - LevelMapFact.F.map_iff. rewrite /Level.eq. intuition auto. -Qed. - -Lemma In_fold_add_max k n a : - LevelMap.In (elt:=nat) k - (LevelExprSet.fold - (fun '(l, k0) (acc : LevelMap.t nat) => add_max l k0 acc) n a) <-> - (LevelSet.In k (levels n)) \/ LevelMap.In k a. -Proof. - eapply LevelExprSetProp.fold_rec. - - intros s' he. - rewrite (LevelExprSetProp.empty_is_empty_1 he). - cbn. unfold levels. rewrite LevelExprSetProp.fold_empty. rewrite LevelSetFact.empty_iff. intuition auto. - - intros. - destruct x as [l k']. - rewrite In_add_max. - rewrite H2 !levelexprset_levels_spec. - split. - * intros []; subst. - left. exists k'. apply H1. now left. - destruct H3 as [[k'' ?]|?]. left; exists k''. apply H1. now right. - now right. - * red in H1. setoid_rewrite H1. - intros [[k'' []]|]. noconf H3. now left. - right. now left; exists k''. right; right. apply H3. -Qed. - - -(* To handle the constraint checking decision problem, - we must start with a model where all atoms [l + k] - appearing in premises are true. Otherwise the - [l := 0] model is minimal for [l+1-> l+2]. - Starting with [l := 1], we see that the minimal model above it - has [l := ∞]. - We also ensure that all levels in the conclusions are in the model. - - *) - -Definition min_model_map (m : LevelMap.t nat) cls : LevelMap.t nat := - Clauses.fold (fun '(cl, concl) acc => - LevelExprSet.fold (fun '(l, k) acc => - add_max l k acc) cl (add_max (levelexpr_level concl) 0 acc)) cls m. - -Lemma min_model_map_levels m cls k : - LevelMap.In k (min_model_map m cls) <-> - LevelSet.In k (clauses_levels cls) \/ LevelMap.In k m. -Proof. - rewrite /min_model_map. - rewrite clauses_levels_spec. - eapply ClausesProp.fold_rec. - - intros s' he. intuition auto. - destruct H0 as [cl []]. - clsets. - - intros x a s' s'' inx ninx hadd ih. - destruct x as [cl k']. - rewrite In_fold_add_max In_add_max. rewrite ih. - intuition auto. left. exists (cl, k'); intuition auto. - apply hadd. now left. - rewrite clause_levels_spec. now left. - subst. left. exists (cl, k'). split. apply hadd; now left. - rewrite clause_levels_spec. now right. - destruct H as [cl'' []]. left. exists cl''. - intuition auto. apply hadd. now right. - destruct H3 as [cl'' []]. - apply hadd in H0 as []; subst. - rewrite clause_levels_spec in H3. destruct H3; subst. - cbn in H0. now left. right. now left. - right. right. left; exists cl''. split => //. -Qed. - -Definition min_model m cls : model := min_model_map m cls. - -Definition init_model cls := min_model (LevelMap.empty _) cls. - -Lemma init_model_levels cls k : - LevelMap.In k (init_model cls) <-> LevelSet.In k (clauses_levels cls). -Proof. - rewrite min_model_map_levels. intuition auto. - now rewrite LevelMapFact.F.empty_in_iff in H0. -Qed. - -Definition init_w (levels : LevelSet.t) : LevelSet.t := LevelSet.empty. - -(* We don't need predecessor clauses as they are trivially satisfied *) -(* Definition add_predecessors (V : LevelSet.t) cls := - LevelSet.fold (fun l acc => - Clauses.add (NonEmptySetFacts.singleton (l, 1), (l, 0)) acc) V cls. *) - -Definition infer_result V cls := result V LevelSet.empty cls (init_model cls). - -Equations? infer (cls : clauses) : infer_result (clauses_levels cls) cls := - infer cls := loop (clauses_levels cls) LevelSet.empty cls (init_model cls) (And3 _ _ _). -Proof. - - now eapply clauses_conclusions_levels. - - lsets. - - now eapply init_model_levels. -Qed. - -Definition valuation_of_model (m : model) : LevelMap.t nat := - let max := LevelMap.fold (fun l k acc => Nat.max k acc) m 0 in - LevelMap.fold (fun l k acc => LevelMap.add l (max - k) acc) m (LevelMap.empty _). - -Definition print_result {V cls} (m : infer_result V cls) := - match m with - | Loop => "looping" - | Model w m _ => "satisfiable with model: " ^ print_level_nat_map m.(model_model) ^ nl ^ " W = " ^ - print_lset w - ^ nl ^ "valuation: " ^ print_level_nat_map (valuation_of_model m.(model_model)) - end. - -Definition valuation_of_result {V cls} (m : infer_result V cls) := - match m with - | Loop => "looping" - | Model w m _ => print_level_nat_map (valuation_of_model m.(model_model)) - end. - -Definition to_string_expr (e : LevelExpr.t) : string := - let '(l, n) := e in Level.to_string l ^ (if n is 0 then "" else "+" ^ string_of_nat n). - -Definition print_premise (l : nonEmptyLevelExprSet) : string := - let (e, exprs) := NonEmptySetFacts.to_nonempty_list l in - to_string_expr e ^ - match exprs with - | [] => "" - | l => ", " ^ print_list to_string_expr ", " exprs - end. - -Definition print_clauses (cls : clauses) := - let list := Clauses.elements cls in - print_list (fun '(l, r) => - print_premise l ^ " → " ^ to_string_expr r) nl list. - -Equations? infer_model_extension (V : LevelSet.t) (m : model) (cls cls' : clauses) - (prf : clauses_conclusions cls ⊂_lset V /\ clauses_conclusions cls' ⊂_lset V /\ model_of V m) : result V LevelSet.empty (Clauses.union cls cls') m := - | V, m, cls, cls', prf := loop V LevelSet.empty (Clauses.union cls cls') m _. -Proof. - split. 2:lsets. - intros x. rewrite clauses_conclusions_spec. - intros [cl [hcl hl]]. - rewrite Clauses.union_spec in hcl. destruct hcl. - - apply H, clauses_conclusions_spec. exists cl => //. - - apply H0, clauses_conclusions_spec. exists cl => //. - - exact H1. -Qed. - -(* To infer an extension, we weaken a valid model for V to a model for [V ∪ clauses_levels cls] by - setting a minimal value for the new atoms in [clauses_levels cls \ V] - such that the new clauses [cls] do not hold vacuously. -*) -Equations? infer_extension {V init cls} (m : valid_model V init cls) (cls' : clauses) : - result (LevelSet.union (clauses_levels cls') V) LevelSet.empty (Clauses.union cls cls') (min_model m.(model_model) cls') := - infer_extension m cls' := - infer_model_extension (LevelSet.union (clauses_levels cls') V) (min_model m.(model_model) cls') cls cls' _. -Proof. - repeat split. - - pose proof (model_clauses_conclusions m). lsets. - - pose proof (clauses_conclusions_levels cls'). lsets. - - red. intros. - unfold min_model. rewrite min_model_map_levels. - pose proof (model_of_V m k). - apply LevelSet.union_spec in H as []; auto. -Qed. - -Definition enforce_clauses {V init cls} (m : valid_model V init cls) cls' : option model := - match infer_extension m cls' with - | Loop => None - | Model w m _ => Some m.(model_model) - end. - -Definition enforce_clause {V init cls} (m : valid_model V init cls) cl : option model := - enforce_clauses m (Clauses.singleton cl). - -Inductive constraint_type := UnivEq | UnivLe. - -Notation constraint := (nonEmptyLevelExprSet * constraint_type * nonEmptyLevelExprSet). - -Definition enforce_constraint (cstr : constraint) (cls : clauses) : clauses := - let '(l, d, r) := cstr in - match d with - | UnivLe => - LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) l cls - | UnivEq => - let cls := - LevelExprSet.fold (fun lk acc => Clauses.add (r, lk) acc) l cls - in - let cls' := - LevelExprSet.fold (fun rk acc => Clauses.add (l, rk) acc) r cls - in cls' - end. - -Definition clauses_of_list := ClausesProp.of_list. -Definition list_of_clauses := Clauses.elements. -Definition valuation := LevelMap.t nat. - -End LoopChecking. From c4f38e5b122d33b2c6a83bea375bc1f488ffad52 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 7 Nov 2025 15:41:59 +0100 Subject: [PATCH 135/164] Remove consistent_extension_on invariant, not used in Rocq --- .vscode/metarocq.code-workspace | 1 + common/theories/EnvironmentTyping.v | 12 +- common/theories/LoopChecking/Deciders.v | 28 ++ .../theories/LoopChecking/UnivLoopChecking.v | 120 ++++-- common/theories/Universes.v | 45 +-- common/theories/UniversesDec.v | 45 +-- common/theories/uGraph.v | 70 +++- pcuic/theories/PCUICGlobalEnv.v | 2 +- pcuic/theories/PCUICTyping.v | 2 +- safechecker/theories/PCUICEqualityDec.v | 8 +- safechecker/theories/PCUICWfEnvImpl.v | 45 ++- template-rocq/src/g_template_rocq.ml | 360 ++++++++++++++++++ 12 files changed, 571 insertions(+), 167 deletions(-) create mode 100644 template-rocq/src/g_template_rocq.ml diff --git a/.vscode/metarocq.code-workspace b/.vscode/metarocq.code-workspace index 125b6ae7d..b9e9dbde2 100644 --- a/.vscode/metarocq.code-workspace +++ b/.vscode/metarocq.code-workspace @@ -156,5 +156,6 @@ "-I", "test-suite/plugin-demo/src", "-Q", "examples", "MetaRocq.Examples", ], + "vsrocq.completion.enable": true, } } diff --git a/common/theories/EnvironmentTyping.v b/common/theories/EnvironmentTyping.v index e65f22e2e..728c69769 100644 --- a/common/theories/EnvironmentTyping.v +++ b/common/theories/EnvironmentTyping.v @@ -1284,11 +1284,6 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT Definition satisfiable_udecl (univs : ContextSet.t) φ := consistent (univs_ext_constraints (ContextSet.constraints univs) φ). - (* Constraints from udecl between *global* universes - are implied by the constraints in univs *) - Definition valid_on_mono_udecl (univs : ContextSet.t) ϕ := - consistent_extension_on univs (constraints_of_udecl ϕ). - (* Check that: *) (* - declared levels are fresh *) (* - all levels used in constraints are declared *) @@ -1298,8 +1293,7 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT let all_levels := LevelSet.union levels global_levels in LevelSet.For_all (fun l => ~ LevelSet.In l global_levels) levels /\ UnivConstraintSet.For_all (declared_univ_cstr_levels all_levels) (constraints_of_udecl udecl) - /\ satisfiable_udecl univs udecl - /\ valid_on_mono_udecl univs udecl. + /\ satisfiable_udecl univs udecl. (** Positivity checking of the inductive, ensuring that the inductive itself can only appear at the right of an arrow in each argument's types. *) @@ -1809,10 +1803,6 @@ Module GlobalMaps (T: Term) (E: EnvironmentSig T) (TU : TermUtils T E) (ET: EnvT destruct H as ((cstrs & _ & consistent) & decls). destruct consistent; eexists. intros v e. specialize (H v e); tea. - - unfold valid_on_mono_udecl, constraints_of_udecl, consistent_extension_on. - intros v sat; exists v; split. - + intros x e. ucsets. - + intros x e => //. Qed. End GlobalMaps. diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index e8d4df31e..b7e029b87 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -3510,6 +3510,34 @@ Module LoopChecking (LS : LevelSets). firstorder. Qed. + Lemma zero_declared_in_levels m : LevelSet.In Level.zero (levels m). + Proof. + have [k hm] := zero_declared m. + apply model_levels. eexists; tea. + Qed. + + Lemma declared_init_clauses {m} : forall l, + LevelSet.In l (levels m) <-> + l = Level.zero \/ Clauses.In (Impl.init_clause_of_level l) (clauses m). + Proof. + move=> l. + move: (above_zero_declared m l). + rewrite /Impl.declared_init_clause_of_level /Impl.init_clause_of_level => ab. + split. + - move: ab; case: (eqb_spec l Level.zero) => //. + * now left. + * move=> eq hin. + right. destruct Level.is_global eqn:isg => //. + apply (hin H). + apply (hin H). + - move=> [h|h]. + * subst l. apply zero_declared_in_levels. + * apply (clauses_levels_declared m). + apply clauses_levels_spec. eexists; split; tea. cbn. + apply clause_levels_spec. left. cbn. + apply levels_spec. exists 0%Z. now apply LevelExprSet.singleton_spec. + Qed. + Definition init_model := Impl.Abstract.init_model. (* Returns None if already declared *) diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 872f33d6e..f08c938c1 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -467,15 +467,15 @@ End ZUnivConstraint. repr_constraints : forall c, UnivConstraintSet.In c constraints -> Clauses.Subset (LoopCheck.to_clauses (to_constraint c)) (LoopCheck.Impl.Abstract.clauses model); repr_constraints_inv : forall cl, Clauses.In cl (LoopCheck.Impl.Abstract.clauses model) -> - exists c, UnivConstraintSet.In c constraints /\ Clauses.In cl (LoopCheck.to_clauses (to_constraint c)) + exists c, UnivConstraintSet.In c constraints /\ Clauses.In cl (LoopCheck.to_clauses (to_constraint c)); + repr_init : forall l c, LevelSet.In l (LoopCheck.levels model) -> init_constraint_of_level l = Some c -> UnivConstraintSet.In c constraints }. - Lemma declared_zero (m : univ_model) : LevelSet.In Level.lzero (LoopCheck.levels m.(model)). + Definition levels m := (LoopCheck.levels m.(model)). + + Lemma declared_zero (m : univ_model) : LevelSet.In Level.lzero (levels m). Proof. - have := LoopCheck.zero_declared m. - have := LoopCheck.Impl.Abstract.model_levels m.(model) Level.lzero. - rewrite /Impl.zero_declared. intros ->. - intros [k hm]. now exists (Z.of_nat (S k)). + apply zero_declared_in_levels. Qed. Module C := LoopCheck.Impl.I.Model.Model.Clauses. @@ -535,7 +535,6 @@ End ZUnivConstraint. rewrite Nat2Z.id //. Qed. - Definition relation_of_constraint (c : ZUnivConstraint.t) := let '(l, d, r) := c in match d with @@ -786,10 +785,9 @@ End ZUnivConstraint. Proof. - move: H. now rewrite UnivConstraintSetFact.empty_iff. - move: H. now rewrite ClausesFact.empty_iff. + - eapply LevelSet.singleton_spec in H. subst l. noconf H0. Qed. - Definition levels m := LoopCheck.levels m.(model). - Lemma init_model_levels : levels init_model = LevelSet.singleton (Level.zero). Proof. now cbn. Qed. @@ -818,6 +816,8 @@ End ZUnivConstraint. rewrite UnivConstraintSet.add_spec. now right. * move=> hin. exists c. split => //. rewrite UnivConstraintSet.add_spec. now left. + - intros l c' hin hc'. apply UnivConstraintSet.add_spec. right. eapply repr_init; tea. + apply enforce_levels in eq0. now rewrite -eq0. Qed. Definition univ_constraint_levels (c : UnivConstraint.t) := @@ -1146,6 +1146,74 @@ End ZUnivConstraint. f_equal. apply equal_exprsets. rewrite /to_atoms //=. Qed. + Lemma constraints_clauses m : + forall c, UnivConstraintSet.In c (constraints m) -> Clauses.Subset (LoopCheck.to_clauses (to_constraint c)) (LoopCheck.clauses m). + Proof. + move=> c. + move/repr_constraints => //. + Qed. + + Definition init_constraints_of_levels ls := + LevelSet.fold (fun l cstrs => + match init_constraint_of_level l with + | None => cstrs + | Some c => UnivConstraintSet.add c cstrs + end) ls UnivConstraintSet.empty. + + Lemma init_constraints_of_levels_spec ls : + forall l, LevelSet.In l ls -> forall c, init_constraint_of_level l = Some c -> UnivConstraintSet.In c (init_constraints_of_levels ls). + Proof. Admitted. + + Lemma init_constraints_of_levels_spec_inv ls : + forall c, UnivConstraintSet.In c (init_constraints_of_levels ls) -> + exists l, LevelSet.In l ls /\ init_constraint_of_level l = Some c. + Proof. Admitted. + + Instance init_constraints_of_levels_proper : Proper (LevelSet.Equal ==> UnivConstraintSet.Equal) (init_constraints_of_levels). + Proof. + intros l l' eqll' cl. + rewrite /init_constraints_of_levels. + Admitted. + + Lemma init_constraints_of_levels_add l c ls : + init_constraint_of_level l = Some c -> + init_constraints_of_levels (LevelSet.add l ls) =_ucset UnivConstraintSet.add c (init_constraints_of_levels ls). + Proof. Admitted. + + (* Lemma clauses_constraints m : + forall l, Clauses.In (Impl.init_clause_of_level l) (LoopCheck.clauses m) -> + exists c, init_constraint_of_level l = Some c /\ UnivConstraintSet.In c (constraints m). + + exists c Clauses.Subset (LoopCheck.to_clauses (to_constraint c)) (LoopCheck.clauses m). + Proof. + move=> c. + move/repr_constraints => //. + Qed. *) + + (* Lemma in_singleton_to_clauses {le concl} c : Clauses.In (singleton le, concl) (to_clauses c) <-> c . *) + + Lemma declared_init_constraints {m} : forall l, + LevelSet.In l (levels m) -> + l = Level.zero \/ exists c, init_constraint_of_level l = Some c /\ UnivConstraintSet.In c (constraints m). + Proof. + move=> l. + destruct (Classes.eq_dec l Level.zero). + firstorder. + move/(repr_init m) => h. + right. destruct l; cbn in *. + { elim n; reflexivity. } + specialize (h _ eq_refl). + eexists; split; trea. + specialize (h _ eq_refl). + eexists; split; trea. + Qed. + + Lemma init_constraints_subset m : (init_constraints_of_levels (levels m)) ⊂_ucset (constraints m). + Proof. + move=> l /init_constraints_of_levels_spec_inv; case=> l' [] hin heq. + now move/repr_init: hin => /(_ _ heq). + Qed. + Definition add_opt_cstr (c : option UnivConstraint.t) s := match c with | None => s @@ -1184,6 +1252,14 @@ End ZUnivConstraint. * have [ec [? ?]] := repr_constraints_inv _ _ h. exists ec. split => //. ucsets. + - intros l' c' hin heq. + apply UnivConstraintSet.add_spec. + destruct (Classes.eq_dec l l'). + * subst l'. rewrite eqc in heq. noconf heq. now left. + * right. + move/declare_level_levels: eq0 => [] hnin hl. + eapply repr_init; tea. rewrite hl in hin. + apply LevelSet.add_spec in hin. destruct hin => //. congruence. - destruct l; noconf eqc. move/declare_level_levels: eq0 => [] hnin _; apply hnin. eapply declared_zero. @@ -1243,32 +1319,6 @@ End ZUnivConstraint. Definition declare_levels (g : univ_model) (levels : LevelSet.t) : option univ_model := declare_levels_aux (Some g) levels. - Definition init_constraints_of_levels ls := - LevelSet.fold (fun l cstrs => - match init_constraint_of_level l with - | None => cstrs - | Some c => UnivConstraintSet.add c cstrs - end) ls UnivConstraintSet.empty. - - Lemma init_constraints_of_levels_spec ls : - forall l, LevelSet.In l ls -> forall c, init_constraint_of_level l = Some c -> UnivConstraintSet.In c (init_constraints_of_levels ls). - Proof. Admitted. - - Lemma init_constraints_of_levels_spec_inv ls : - forall c, UnivConstraintSet.In c (init_constraints_of_levels ls) -> - exists l, LevelSet.In l ls /\ init_constraint_of_level l = Some c. - Proof. Admitted. - - Instance init_constraints_of_levels_proper : Proper (LevelSet.Equal ==> UnivConstraintSet.Equal) (init_constraints_of_levels). - Proof. - intros l l' eqll' cl. - rewrite /init_constraints_of_levels. - Admitted. - - Lemma init_constraints_of_levels_add l c ls : - init_constraint_of_level l = Some c -> - init_constraints_of_levels (LevelSet.add l ls) =_ucset UnivConstraintSet.add c (init_constraints_of_levels ls). - Proof. Admitted. Hint Rewrite UnivConstraintSet.union_spec : set_specs. diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 57539ca13..91e464af4 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -880,6 +880,8 @@ Ltac ucsets := UnivConstraintSetDecide.fsetdec. Notation "(=_ucset)" := UnivConstraintSet.Equal (at level 0). Infix "=_ucset" := UnivConstraintSet.Equal (at level 30). +Notation "(⊂_ucset)" := UnivConstraintSet.Subset (at level 0). +Infix "⊂_ucset" := UnivConstraintSet.Subset (at level 30). Notation "(==_ucset)" := UnivConstraintSet.equal (at level 0). Infix "==_ucset" := UnivConstraintSet.equal (at level 30). @@ -1169,17 +1171,6 @@ Section Univ. Definition consistent ctrs := exists v, satisfies v ctrs. - Definition consistent_extension_on cs cstr := - forall v, satisfies v (ContextSet.constraints cs) -> exists v', - satisfies v' cstr /\ - LevelSet.For_all (fun l => val v l = val v' l) (ContextSet.levels cs). - - Lemma consistent_extension_on_empty Σ : - consistent_extension_on Σ UCS.empty. - Proof. - move=> v hv; exists v; split; [move=> ? /UCS.empty_spec[]| move=> ??//]. - Qed. - Lemma fold_right_ext {A B} (f g : B -> A -> A) acc acc' l l' : (forall x y, f x y = g x y) -> acc = acc' -> l = l' -> fold_right f acc l = fold_right g acc' l'. @@ -1313,38 +1304,6 @@ Section Univ. Lemma val_succ v l : val v (Universe.succ l) = val v l + 1. Proof. by rewrite (val_plus v 1). Qed. - (* Lemma consistent_extension_on_union X cstrs - (wfX : forall c, UCS.In c X.2 -> LS.Subset (Universe.levels c.1.1) X.1 /\ LS.Subset (Universe.levels c.2) X.1) : - consistent_extension_on X cstrs -> - consistent_extension_on X (UCS.union cstrs X.2). -Proof. - move=> hext v /[dup] vsat /hext [v' [v'sat v'eq]]. - exists v'; split=> //. - apply/satisfies_union; split=> //. - move=> c hc. destruct (wfX c hc). - destruct (vsat c hc); constructor; cbn in *. - 2:{ rewrite -(val_eq_levels_alg v v' _ v'eq l) //. - rewrite -(val_eq_levels_alg v v' _ v'eq l') //. } - rewrite -(val_eq_levels_alg v v' _ v'eq l) //. - rewrite -(val_eq_levels_alg v v' _ v'eq l') //. -Qed. *) - - Lemma consistent_extension_on_union X cstrs - (wfX : forall c, UCS.In c X.2 -> LS.Subset (Universe.levels c.1.1) X.1 /\ LS.Subset (Universe.levels c.2) X.1) : - consistent_extension_on X cstrs -> - consistent_extension_on X (UCS.union cstrs X.2). - Proof. - move=> hext v /[dup] vsat /hext [v' [v'sat v'eq]]. - exists v'; split=> //. - apply/satisfies_union; split=> //. - move=> c hc. destruct (wfX c hc). - destruct (vsat c hc); constructor; cbn in *. - 2:{ rewrite -(val_eq_levels_alg v v' _ v'eq l) //. - rewrite -(val_eq_levels_alg v v' _ v'eq l') //. } - rewrite -(val_eq_levels_alg v v' _ v'eq l) //. - rewrite -(val_eq_levels_alg v v' _ v'eq l') //. - Qed. - Definition leq0_universe φ (u u' : Universe.t) := forall v, satisfies v φ -> val v u <= val v u'%Z. diff --git a/common/theories/UniversesDec.v b/common/theories/UniversesDec.v index 90c04b700..f0b3101ae 100644 --- a/common/theories/UniversesDec.v +++ b/common/theories/UniversesDec.v @@ -89,41 +89,6 @@ Proof. apply Universe.levels_spec. now exists le.2; destruct le. Qed. -(* Lemma invalid_cstr cs c : ~ valid0_cstrs cs c <-> ~ (forall v, exists v, *) - -Definition consistent_extension_on_dec (cf := config.default_checker_flags) cs cstr : {@consistent_extension_on cs cstr} + {~@consistent_extension_on cs cstr}. -Proof. - unfold consistent_extension_on. - have hp := push_uctx_spec init_model cs. - cbn in hp. - destruct (push_uctx init_model cs). - - destruct hp as [ul uc]. destruct (check_constraints u cstr) eqn:hc. - unfold check_constraints, check_constraints_gen in hc. cbn in hc. - left. - intros v hsat. - apply UnivConstraintSet.for_all_spec in hc. - exists v. split. move=> c /hc. - have hs := checkb_spec u cs. - forward hs. red. admit. forward hs. red. admit. - red in hs. specialize (hs c). forward hs. admit. rewrite [_ = true]hs. - now move/(_ v hsat). - intros hl. reflexivity. tc. - right. - intros hv. - have [c [hin hc']] : exists c, UnivConstraintSet.In c cstr /\ @check_constraint_gen config.default_checker_flags (checkb u) c = false. - admit. - unfold check_constraint_gen in hc'. cbn in hc'. - have hs := checkb_spec u cs. - forward hs. red. admit. forward hs. red. admit. - red in hs. - specialize (hs c). forward hs. admit. rewrite hc' in hs. - destruct hs => //. forward H0 => //. - intros v' hs. specialize (hv v' hs). - destruct hv as [v'0 [hsat heq]]. - admit. - - admit. -Admitted. - Lemma declared_univ_cstrs_levels_spec cstrs : declared_univ_cstrs_levels (univ_constraints_levels cstrs) cstrs. Proof. intros cl hin. apply declared_univ_cstr_levels_spec. @@ -153,10 +118,7 @@ Proof. cbn. red. red in leq. move=> v /leq. now constructor. * apply push_uctx_init_model_unsat in eqp => //. - left. intros v hv. elim eqp. - exists v. eapply satisfies_union. split. - 2:{ apply satisfies_init. } - exact hv. + left. intros v hv. elim eqp. now exists v. Qed. Definition leq_universe_dec cf ϕ u u' : {@leq_universe cf ϕ u u'} + {~@leq_universe cf ϕ u u'}. @@ -211,10 +173,7 @@ Proof. * move=> _ hv; right => leq. forward hv => //. - apply push_uctx_init_model_unsat in eqp => //. left. red. destruct config.check_univs => //. - intros v sat. elim eqp. - exists v. eapply satisfies_union. split. - 2:{ apply satisfies_init. } - exact sat. + intros v sat. elim eqp. now exists v. Qed. Definition valid_constraints0_dec ϕ ctrs : {@valid_constraints0 ϕ ctrs} + {~@valid_constraints0 ϕ ctrs} diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index c56904f1f..888284cb0 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -767,31 +767,71 @@ Proof. rewrite init_constraints_of_levels_singleton_zero. ucsets. Qed. -Lemma push_uctx_init_model_unsat `{cf : checker_flags} [uctx] : - global_uctx_invariants uctx -> - push_uctx init_model uctx = None <-> - let allcstrs := (UnivConstraintSet.union uctx.2 (init_constraints_of_levels uctx.1)) in +Lemma is_model_of_uctx m : model_of_uctx m (levels m, constraints m). +Proof. + split. + - cbn => l. rewrite LevelSet.union_spec LevelSet.singleton_spec. firstorder. subst. + have hd := LoopCheck.zero_declared m. + have hm := LoopCheck.Impl.Abstract.model_levels m.(model) Level.lzero. + apply hm. destruct hd as [n hm']. now exists (Z.of_nat (S n)). + - cbn. + have hs := init_constraints_subset m. ucsets. +Qed. + +Definition wf_uctx_ext (m : univ_model) (uctx : ContextSet.t) := + (forall l, LevelSet.In l uctx.1 -> ~ LevelSet.In l (levels m)) /\ + declared_univ_cstrs_levels (LevelSet.union uctx.1 (levels m)) uctx.2. + +(* Instance declared_univ_cstrs_levels_proper *) + +Lemma push_uctx_model_unsat `{cf : checker_flags} [m uctx] : + wf_uctx_ext m uctx -> + push_uctx m uctx = None <-> + let allcstrs := (UnivConstraintSet.union (constraints m) uctx.2) in (~ exists v, satisfies v allcstrs). Proof. move=> inv. set cstrs := UnivConstraintSet.union _ _. cbn; destruct push_uctx eqn:hp. - - destruct (push_uctx_init_model_sat hp) as [hl hc]. split => //. + - have hm := is_model_of_uctx m. + eapply push_uctx_model in hp; tea. + split => //. elim. exists (to_valuation (model_val u)). - destruct inv as [nz hd]. red in hd. - subst cstrs. rewrite -hc. - eapply model_satisfies. + subst cstrs. have hs := model_satisfies u. + destruct hp as [hl hc]. + rewrite hc in hs. cbn -[init_constraints_of_levels] in hs. + apply satisfies_union in hs as [h h']. + apply satisfies_union in h as []. + rewrite init_constraints_of_levels_union in h'. + apply satisfies_union in h' as []. + now apply satisfies_union. - split => //. intros _ [v sat]. - have := push_uctx_spec init_model uctx. + have hm := is_model_of_uctx m. + have := push_uctx_spec m uctx. cbn. rewrite hp. intros [[l [hin hsing]]|[ndecl|nsat]]. - * eapply LevelSet.singleton_spec in hsing. subst l. - destruct inv => //. - * destruct inv. red in H0. - rewrite LevelSetProp.add_union_singleton in H0. contradiction. + * now apply (proj1 inv l). + * destruct inv. rewrite LevelSetProp.union_sym in ndecl. contradiction. * apply nsat. exists v. - rewrite -UnivConstraintSetProp.union_assoc. eapply satisfies_union. split => //. - intros c; ucsets. + rewrite -UnivConstraintSetProp.union_assoc. + apply satisfies_union in sat as []. + eapply satisfies_union. split => //. + subst cstrs. + apply satisfies_union; split => //. + apply satisfies_init. +Qed. + +Lemma push_uctx_init_model_unsat `{cf : checker_flags} [uctx] : + global_uctx_invariants uctx -> + push_uctx init_model uctx = None <-> + (~ exists v, satisfies v uctx.2). +Proof. + move=> inv. + rewrite push_uctx_model_unsat //. + destruct inv; split. + intros l hin h. eapply LevelSet.singleton_spec in h. subst. contradiction. + cbn. rewrite LevelSetProp.union_sym -LevelSetProp.add_union_singleton. + exact H0. Qed. Instance levelset_sub : RewriteRelation LevelSet.Subset := {}. diff --git a/pcuic/theories/PCUICGlobalEnv.v b/pcuic/theories/PCUICGlobalEnv.v index 65b411670..a3eb2f976 100644 --- a/pcuic/theories/PCUICGlobalEnv.v +++ b/pcuic/theories/PCUICGlobalEnv.v @@ -168,7 +168,7 @@ Definition global_ext_uctx_consistent {cf:checker_flags} {P} Σ Proof. intros HΣ. cbn. unfold global_ext_constraints. unfold wf_ext, on_global_env_ext in HΣ. - destruct HΣ as (_ & _ & _ & HH & _). apply HH. + destruct HΣ as (_ & _ & _ & HH). apply HH. Qed. diff --git a/pcuic/theories/PCUICTyping.v b/pcuic/theories/PCUICTyping.v index 2cd0b0b4a..c9554ee6c 100644 --- a/pcuic/theories/PCUICTyping.v +++ b/pcuic/theories/PCUICTyping.v @@ -519,7 +519,7 @@ Hint Resolve wf_ext_wf : core. Lemma wf_ext_consistent {cf:checker_flags} Σ : wf_ext Σ -> consistent Σ. -Proof. intros [_ [_ [_ [? _]]]]; assumption. Qed. +Proof. intros [_ [_ [_ ?]]]. assumption. Qed. #[global] Hint Resolve wf_ext_consistent : core. diff --git a/safechecker/theories/PCUICEqualityDec.v b/safechecker/theories/PCUICEqualityDec.v index 491211056..386ea3763 100644 --- a/safechecker/theories/PCUICEqualityDec.v +++ b/safechecker/theories/PCUICEqualityDec.v @@ -835,9 +835,7 @@ Proof. * exfalso. destruct HΣ. apply hp. assert (consistent (global_uctx Σ).2) as HC. { sq; apply (wf_consistent _ X). } - destruct HC as [v sat]. - exists v. apply satisfies_union. split => //. - apply satisfies_init. + destruct HC as [v sat]. now exists v. * destruct HΣ. eapply wf_global_uctx_invariants. exact X. Qed. @@ -851,9 +849,7 @@ Proof. * exfalso. destruct HΣ. apply hp. assert (consistent (global_ext_uctx Σ).2) as HC. { sq. now apply (wf_ext_consistent _ X). } - destruct HC as [v sat]. - exists v. apply satisfies_union. split => //. - apply satisfies_init. + destruct HC as [v sat]. now exists v. * destruct HΣ. eapply wf_ext_global_uctx_invariants. exact X. Qed. diff --git a/safechecker/theories/PCUICWfEnvImpl.v b/safechecker/theories/PCUICWfEnvImpl.v index 9cc9e1bac..2cc8f3883 100644 --- a/safechecker/theories/PCUICWfEnvImpl.v +++ b/safechecker/theories/PCUICWfEnvImpl.v @@ -38,7 +38,7 @@ end. Next Obligation. destruct Σ.(reference_impl_wf). sq. destruct X as [onu ond]; split => //. rewrite <- Heq_anonymous in ond. -now depelim ond. +depelim ond. apply ond. Qed. Program Definition make_wf_env_ext {cf:checker_flags} {guard : abstract_guard_impl} @@ -278,6 +278,8 @@ Section GraphSpec. End GraphSpec. +Import UnivLoopChecking.UnivLoopChecking. + Program Global Instance canonical_abstract_env_prop {cf:checker_flags} {guard : abstract_guard_impl} : @abstract_env_prop _ _ _ canonical_abstract_env_struct := {| abstract_env_ext_exists := fun Σ => sq (reference_impl_env_ext Σ ; eq_refl); |}. @@ -305,13 +307,33 @@ Next Obligation. + reflexivity. Qed. Next Obligation. pose (reference_impl_ext_wf X). sq. symmetry; apply LevelSet.Raw.mem_spec. typeclasses eauto. Defined. -Next Obligation. todo "consistent extension on". Qed. - (* pose (reference_impl_wf X). sq. - rename H0 into Hudecl. rename H1 into Hudecl'. - assert (H0 : global_uctx_invariants (global_uctx X)). +Next Obligation. + pose (reference_impl_wf X). sq. + rename H0 into Hudecl. + assert (H0 : global_uctx_invariants (clean_uctx (global_uctx X))). { eapply wf_global_uctx_invariants; eauto. } set (udecl := (t , t0)). - assert (H1 : global_uctx_invariants (ContextSet.union udecl (global_uctx X))). + destruct (push_uctx _ udecl) eqn:hp. + - split => // _. + subst udecl. + intros v sat. + pose proof (reference_impl_graph_wf X) as HG. + set (gph := (graph_of_wf X).π1) in *. simpl in HG. + eapply push_uctx_model in hp; tea. + exists (to_valuation (LoopCheck.valuation u.(model))). + split. + destruct hp as [hl hc]. + have hv := model_satisfies u. rewrite hc in hv. + apply satisfies_union in hv as [hv hv']. + apply satisfies_union in hv as [ht hg]. + now cbn in ht. + todo "Valuation does not change for globals". + - split=> // hcon. + have hs := push_uctx_spec (reference_impl_graph X) udecl. + rewrite hp in hs. cbn in hs. + Search push_uctx. in hp. + + (* assert (H1 : global_uctx_invariants (ContextSet.union udecl (global_uctx X))). { split => //. - apply LevelSet.union_spec; right ; now destruct H0. - intros [[l ct] l'] [Hl|Hl]%UCS.union_spec. @@ -319,11 +341,9 @@ Next Obligation. todo "consistent extension on". Qed. + destruct H0 as [_ H0]. specialize (H0 _ Hl). split; apply LevelSet.union_spec; right; now cbn in H0. - } - unfold reference_impl_graph; rewrite andb_and. - pose proof (reference_impl_graph_wf X) as HG. - set (gph := (graph_of_wf X).π1) in *. clearbody gph. simpl in HG. - pose proof (HG' := is_graph_of_uctx_add Hudecl' HG). + } *) + (* unfold reference_impl_graph; rewrite andb_and. *) + pose proof (HG' := model_of_uctx_add Hudecl' HG). pose (global_ext_uctx := ContextSet.union udecl (global_uctx X)). pose (wf_consistent_extension_on_consistent udecl.2 s). assert (reorder : forall a a' b c : Prop, (b -> a) -> (a /\ b <-> a' /\ c) -> b <-> a' /\ c) by intuition; eapply reorder; try eassumption; clear reorder. @@ -336,7 +356,8 @@ Next Obligation. todo "consistent extension on". Qed. change (UCS.union _ _) with global_ext_uctx.2. apply: consistent_ext_on_full_ext=> //. apply: add_uctx_subgraph. -Qed. *) +Qed. + Next Obligation. apply guard_correct. Qed. diff --git a/template-rocq/src/g_template_rocq.ml b/template-rocq/src/g_template_rocq.ml new file mode 100644 index 000000000..a9187abbd --- /dev/null +++ b/template-rocq/src/g_template_rocq.ml @@ -0,0 +1,360 @@ +let _ = Mltop.add_known_module "rocq-metarocq-template-rocq.plugin" + +# 4 "src/g_template_rocq.mlg" + + +open Attributes +open Ltac_plugin +open Names + +(** Calling Ltac **) + +let ltac_lcall tac args = + let (location, name) = Loc.tag (Names.Id.of_string tac) + (* Loc.tag @@ Names.Id.of_string tac *) + in + CAst.make ?loc:location (Tacexpr.TacArg(Tacexpr.TacCall + (CAst.make (Locus.ArgVar (CAst.make ?loc:location name),args)))) + +open Tacexpr +open Tacinterp +open Stdarg +open Tacarg +open Redexpr + +(* If strict unquote universe mode is on then fail when unquoting a non *) +(* declared universe / an empty list of level expressions. *) +(* Otherwise, add it / a fresh level the global environnment. *) + +let _ = + let open Goptions in + declare_bool_option + { optdepr = None; + optstage = Interp; + optkey = ["MetaRocq"; "Strict"; "Unquote"; "Universe"; "Mode"]; + optread = (fun () -> !Denoter.strict_unquote_universe_mode); + optwrite = (fun b -> Denoter.strict_unquote_universe_mode := b) } + +let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) = + let fold arg (i, vars, lfun) = + let id = Names.Id.of_string ("x" ^ string_of_int i) in + let (l,n) = (Loc.tag id) in + let x = Reference (Locus.ArgVar (CAst.make ?loc:l n)) in + (succ i, x :: vars, Id.Map.add id arg lfun) + in + let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in + let lfun = Id.Map.add (Id.of_string "F") f lfun in + let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in + Tacinterp.eval_tactic_ist ist (ltac_lcall "F" args) + +let to_ltac_val c = Tacinterp.Value.of_constr c + +let run_template_program ~pm env evm ~poly pgm = + Run_template_monad.run_template_program_rec ~poly (fun ~st _ _ _ -> st) ~st:pm env (evm, pgm) + +let fresh_env () = + let env = Global.env () in + let sigma = Evd.from_env env in + env, sigma + +let to_constr_evars sigma c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c + + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Test_Quote" ~classifier:(fun _ -> Vernacextend.classify_as_query) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Test", + Vernacextend.TyTerminal + ("Quote", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil)))), + (let coqpp_body def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 67 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (evm, def) = Constrintern.interp_open_constr env evm def in + let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmTestQuote) in + let pgm = Constr.mkApp (EConstr.to_constr evm pgm, + [|Constr.mkRel 0; to_constr_evars evm def|]) in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun def ?loc ~atts () -> + coqpp_body def (Attributes.parse +# 66 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Quote", + Vernacextend.TyTerminal + ("Definition", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), + Vernacextend.TyTerminal + (":=", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil)))))), + (let coqpp_body name def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 77 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (evm, def) = Constrintern.interp_open_constr env evm def in + let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteDefinition) in + let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; + to_constr_evars evm def|]) in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun name def ?loc ~atts () -> + coqpp_body name def (Attributes.parse +# 76 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Definition_Eval" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Quote", + Vernacextend.TyTerminal + ("Definition", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), + Vernacextend.TyTerminal + (":=", + Vernacextend.TyTerminal + ("Eval", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_red_expr), + Vernacextend.TyTerminal + ("in", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil))))))))), + (let coqpp_body name rd def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 87 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (evm, def) = Constrintern.interp_open_constr env evm def in + (* TODO : implem quoting of tactic reductions so that we can use ptmQuoteDefinitionRed *) + let (evm, rd) = Redexpr.interp_redexp_no_ltac env evm rd in + let (evm, def) = Plugin_core.reduce env evm rd (to_constr_evars evm def) in + let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteDefinition) in + let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; def|]) in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun name rd def ?loc ~atts () -> + coqpp_body name rd def (Attributes.parse +# 86 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Recursively_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Quote", + Vernacextend.TyTerminal + ("Recursively", + Vernacextend.TyTerminal + ("Definition", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), + Vernacextend.TyTerminal + (":=", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil))))))), + (let coqpp_body name def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 99 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (evm, def) = Constrintern.interp_open_constr env evm def in + let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteRecDefinition) in + let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; + to_constr_evars evm def|]) in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun name def ?loc ~atts () -> + coqpp_body name def (Attributes.parse +# 98 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Test_Unquote" ~classifier:(fun _ -> Vernacextend.classify_as_query) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Test", + Vernacextend.TyTerminal + ("Unquote", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil)))), + (let coqpp_body def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 109 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (evm, def) = Constrintern.interp_open_constr env evm def in + let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmTestUnquote) in + let pgm = Constr.mkApp (EConstr.to_constr evm pgm, + [|to_constr_evars evm def|]) in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun def ?loc ~atts () -> + coqpp_body def (Attributes.parse +# 108 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Make_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Unquote", + Vernacextend.TyTerminal + ("Definition", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), + Vernacextend.TyTerminal + (":=", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil)))))), + (let coqpp_body name def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 119 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (evm, def) = Constrintern.interp_open_constr env evm def in + let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmMkDefinition) in + let pgm = Constr.mkApp (EConstr.to_constr evm pgm, + [|Constr_quoter.quote_ident name; + to_constr_evars evm def|]) in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun name def ?loc ~atts () -> + coqpp_body name def (Attributes.parse +# 118 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Make_Inductive" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Unquote", + Vernacextend.TyTerminal + ("Inductive", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil)))), + (let coqpp_body def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 130 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (evm, def) = Constrintern.interp_open_constr env evm def in + let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmMkInductive) in + let pgm = Constr.mkApp (EConstr.to_constr evm pgm, + [|Constr_quoter.quote_bool false; to_constr_evars evm def|]) in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun def ?loc ~atts () -> + coqpp_body def (Attributes.parse +# 129 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Run_Template_Program" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None + [(Vernacextend.TyML + (false, + Vernacextend.TyTerminal + ("MetaRocq", + Vernacextend.TyTerminal + ("Run", + Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Vernacextend.TyNil))), + (let coqpp_body def poly = + Vernactypes.vtmodifyprogram (fun ~pm -> ( +# 140 "src/g_template_rocq.mlg" + fun ~pm -> let (env, evm) = fresh_env () in + let (pgm, ctx) = Constrintern.interp_constr env evm def in + let evm = Evd.from_ctx ctx in + let pgm = EConstr.to_constr ~abort_on_undefined_evars:true evm pgm in + run_template_program ~pm env evm ~poly pgm + ) ~pm) in fun def ?loc ~atts () -> + coqpp_body def (Attributes.parse +# 139 "src/g_template_rocq.mlg" + polymorphic + atts)), + None))] + +let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_quote_term" ~level:0 + [(Tacentries.TyML (Tacentries.TyIdent ("quote_term", Tacentries.TyArg ( + Extend.TUentry (Genarg.get_arg_tag wit_constr), + Tacentries.TyArg ( + Extend.TUentry (Genarg.get_arg_tag wit_tactic), + Tacentries.TyNil))), + (fun c tac ist -> +# 152 "src/g_template_rocq.mlg" + (* quote the given term, pass the result to t *) + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let c = to_constr_evars sigma c in + let c = Constr_quoter.quote_term env sigma c in + ltac_apply tac (List.map to_ltac_val [EConstr.of_constr c]) + end + )))] + +let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_denote_term" ~level:0 + [(Tacentries.TyML (Tacentries.TyIdent ("denote_term", Tacentries.TyArg ( + Extend.TUentry (Genarg.get_arg_tag wit_constr), + Tacentries.TyArg ( + Extend.TUentry (Genarg.get_arg_tag wit_tactic), + Tacentries.TyNil))), + (fun c tac ist -> +# 164 "src/g_template_rocq.mlg" + Proofview.Goal.enter (begin fun gl -> + let env = Proofview.Goal.env gl in + let evm = Proofview.Goal.sigma gl in + let evm, c = Constr_denoter.denote_term env evm (to_constr_evars evm c) in + let evm, _ = Typing.type_of env evm (EConstr.of_constr c) in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) + (ltac_apply tac (List.map to_ltac_val [EConstr.of_constr c])) + end) + )))] + +let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_run_template_program" ~level:0 + [(Tacentries.TyML (Tacentries.TyIdent ("run_template_program", + Tacentries.TyArg (Extend.TUentry (Genarg.get_arg_tag wit_constr), + Tacentries.TyArg (Extend.TUentry (Genarg.get_arg_tag wit_tactic), + Tacentries.TyNil))), (fun c tac ist -> +# 176 "src/g_template_rocq.mlg" + let open Proofview.Notations in + Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (name, poly) -> + Proofview.Goal.enter (begin fun gl -> + let env = Proofview.Goal.env gl in + let evm = Proofview.Goal.sigma gl in + let ret = ref None in + (* We don't allow opening obligations / updating the vernacular inside proofs / as tactics *) + let pm = Declare.OblState.empty in + let _pm = Run_template_monad.run_template_program_rec + ~poly ~intactic:true ~st:pm (fun ~st env evm t -> ret := Some (env,evm,t); st) + env (evm, to_constr_evars evm c) + in + match !ret with + | Some (env, evm, t) -> + Proofview.tclTHEN + (Proofview.Unsafe.tclEVARS evm) + (ltac_apply tac (List.map to_ltac_val [EConstr.of_constr t])) + | None -> Proofview.tclUNIT () + end) + )))] + From a67c280b657de3dd5cb899497b8dd0e12847f053 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 7 Nov 2025 18:59:57 +0100 Subject: [PATCH 136/164] Finished porting! --- common/theories/LoopChecking/Thinning.v | 417 ------------------ .../theories/LoopChecking/UnivLoopChecking.v | 2 - common/theories/Universes.v | 2 + common/theories/uGraph.v | 10 +- safechecker/theories/PCUICSafeChecker.v | 73 +-- safechecker/theories/PCUICWfEnv.v | 24 +- safechecker/theories/PCUICWfEnvImpl.v | 67 ++- 7 files changed, 87 insertions(+), 508 deletions(-) delete mode 100644 common/theories/LoopChecking/Thinning.v diff --git a/common/theories/LoopChecking/Thinning.v b/common/theories/LoopChecking/Thinning.v deleted file mode 100644 index 19bd1176a..000000000 --- a/common/theories/LoopChecking/Thinning.v +++ /dev/null @@ -1,417 +0,0 @@ - -(** To ensure validity in Z, one must remove "latent" loops from the clauses. - As we start validity checking from a set of satisfiable clauses, we know - that there exists an equivalent set of clauses (for Z valuations) with - no latent loop. - It is basically computed by the inference algorithm. - - E.g. if we encountered a clause l ∨ x + 1 -> l+1 during inference and found - a total model m of this clause, then necessarily the model also validates - x + 1 -> l + 1 as: - - min_premise m (l ∨ x + 1) = (min m[l] m[x]-1)+1 <= m[l] <-> m[x] <= m[l] - - So, instead of checking d - - -*) - -Class In T E := in_pred : E -> T -> Prop. -Instance Ines : In LevelExprSet.t LevelExpr.t := LevelExprSet.In. -Instance Inprems : In NES.t LevelExpr.t := fun x s => LevelExprSet.In x s. - -Notation " x ∈ S " := (in_pred x S) (at level 20). - -Equations remove_prem_opt (le : LevelExpr.t) (e : NES.t) : option NES.t := - remove_prem_opt le e with inspect (LevelExprSet.is_empty (LevelExprSet.remove le e)) := - | exist true _ => None - | exist false he => Some {| t_set := LevelExprSet.remove le e; t_ne := he |}. - -Lemma remove_prem_opt_Some le e e' le' : - remove_prem_opt le e = Some e' -> - LevelExprSet.In le' e' <-> - LevelExprSet.In le' e /\ le <> le'. -Proof. - funelim (remove_prem_opt le e) => //. - intros [= <-]; cbn. - rewrite LevelExprSet.remove_spec /LevelExprSet.E.eq. - intuition auto. -Qed. - -Lemma remove_prem_opt_Some_eq le e e' : - le ∈ e -> - remove_prem_opt le e = Some e' -> - e = union (singleton le) e' /\ ~ le ∈ e'. -Proof. - intros hin. - move/remove_prem_opt_Some => hl. - split. - - apply equal_exprsets => lk. - rewrite LevelExprSet.union_spec LevelExprSet.singleton_spec. - rewrite hl. - destruct (Classes.eq_dec lk le). - * subst. split => // _. now left. - * split => //. intros hin'. now right. - intros []. congruence. apply H. - - intros hin'. specialize (hl le). - apply hl in hin'. destruct hin'. congruence. -Qed. - -Lemma remove_prem_opt_None le e : - remove_prem_opt le e = None -> - LevelExprSet.In le e <-> e = singleton le. -Proof. - funelim (remove_prem_opt le e) => //. - intros _. clear H. move: e0. - rewrite LevelExprSet.is_empty_spec. - intros he. - split. intros. - - red in he. - apply equal_exprsets => l. - rewrite LevelExprSet.singleton_spec /LevelExprSet.E.eq. - split. intros hin. - setoid_rewrite LevelExprSet.remove_spec in he. - destruct (Classes.eq_dec l le0) => //. - elim (he l). split => //. - now intros ->. - - intros ->. now eapply LevelExprSet.singleton_spec. -Qed. - -Definition union_opt (e : NES.t) (e' : option NES.t) : NES.t := - match e' with - | Some e' => union e e' - | None => e - end. - -Lemma union_opt_union e e' e'' : union (union_opt e e') e'' = union e (union_opt e'' e'). -Proof. - destruct e'; cbn. - now rewrite union_assoc (@union_comm t0). - reflexivity. -Qed. - -Lemma union_remove le prems : - le ∈ prems -> - union_opt (singleton le) (remove_prem_opt le prems) = prems. -Proof. - intros hin. - destruct (remove_prem_opt le prems) eqn:hr. - - apply equal_exprsets => lk. - cbn. rsets; rewrite /LevelExprSet.E.eq. - eapply remove_prem_opt_Some in hr. erewrite hr. - firstorder auto. subst. apply hin. - destruct (Classes.eq_dec lk le). now left. - right. firstorder. - - apply remove_prem_opt_None in hr. - apply hr in hin. subst prems. now cbn. -Qed. - -Lemma entails_weak_union_opt cls prems prems' concl : - entails cls (prems, concl) -> - entails cls (union_opt prems prems', concl). -Proof. - destruct prems'; cbn => //. - now intros ent; rewrite union_comm; eapply entails_weak_union. -Qed. - -Inductive max_chain cls : Clause.t -> Prop := -| incl cl : entails cls cl -> max_chain cls cl -| chain {prems concl k k'} {prems' : NES.t} {concl'} : - max_chain cls (prems, (concl, k)) -> - max_chain cls (prems', concl') -> - (concl, k') ∈ prems' -> - max_chain cls (union_opt (add_prems (k' - k) prems) (remove_prem_opt (concl, k') prems'), concl'). - -Lemma max_chain_entails cls cl : - max_chain cls cl <-> entails cls cl. -Proof. - split. - + induction 1. - - exact H. - - eapply (entails_cumul_one (prems' := singleton (concl0, k'))); revgoals. - { rewrite union_opt_union union_remove //. now eapply entails_weak_union. } - eapply (entails_shift (k' - k)) in IHmax_chain1. - cbn in IHmax_chain1. - have heq: k' - k + k = k' by lia. - rewrite heq in IHmax_chain1. - eapply entails_all_singleton. - now eapply entails_weak_union_opt. - + intros ent; now apply incl. -Qed. - -Definition thin_clause m cl := - let prems := premise cl in - let filter '(l, k) := if entails_dec m (prems, (l, k + 1)) then false else true in - LevelExprSet.filter filter (premise cl). - - -Lemma thin_clause_spec m cl : - let prems := thin_clause m cl in - if LevelExprSet.is_empty prems then - entails_all (clauses m) (premise cl) (succ (premise cl)) - else - exists premsnl premsl, - [/\ premise cl = (union_opt premsnl premsl)%nes, - prems = premsnl, - (forall l k, (l, k) ∈ premsnl -> ~ entails (clauses m) (premise cl, (l, k+1))) & - on_Some_or_None (fun premsl => entails_all (clauses m) (premise cl) (succ premsl)) premsl]. -Proof. - intros prems. - destruct (LevelExprSet.is_empty prems) eqn:ise. - - have ha : forall l k, LevelExprSet.In (l, k) (premise cl) -> entails (clauses m) (premise cl, (l, k + 1)). - intros l k hin. - eapply (empty_filter _ _ ise) in hin. - destruct entails_dec => //. - move=> -[] l k /In_add_prems -[[l' k']] [] hin ->. - eapply ha in hin. rewrite /succ_expr //=. now rewrite Z.add_comm. - - subst prems; unfold thin_clause in *. - set (fn := fun '(l, k) => _) in *. - set (fil := LevelExprSet.filter _ _) in *. - have hs := LevelExprSet.partition_spec2 (f:=fn) (premise cl). forward hs. tc. - have hs' := LevelExprSet.partition_spec1 (f:=fn) (premise cl). forward hs'. tc. - set (part := LevelExprSet.partition _ _) in *. - exists {| t_set := fil; t_ne := ise |}. - destruct (LevelExprSet.is_empty part.2) eqn:ise2. - * exists None. - cbn. split => //. - { apply equal_exprsets; cbn. - move=> lk. rewrite LevelExprSet.filter_spec. - intuition auto. - rewrite hs in ise2. - have he := empty_filter _ _ ise2. - specialize (he lk H). - destruct (fn lk) => //. } - { move=> l k /LevelExprSet.filter_spec -[] hin hf hent. - unfold fn in hf. destruct entails_dec => //. } - * exists (Some {| t_set := part.2; t_ne := ise2 |}). - cbn. split => //. - apply equal_exprsets => l. cbn. - rewrite LevelExprSet.union_spec. - rewrite -[fil]hs'. - now rewrite -partition_in. - { move=> l k /LevelExprSet.filter_spec -[] hin' hf hent. - unfold fn in hf. destruct entails_dec => //. } - { move=> l /In_add_prems -[[le' le'k]] []. - cbn. rewrite hs => /LevelExprSet.filter_spec [] hin heq. - intros ->. unfold fn in heq. destruct entails_dec => //. - cbn in heq. now rewrite Z.add_comm. } -Qed. - -Equations thin_clause_opt (m : t) (cl : clause) : option clause := - | m, cl with inspect (LevelExprSet.is_empty (thin_clause m cl)) := - | exist true _ => None - | exist false ne => Some ({| t_set := thin_clause m cl; t_ne := ne |}, concl cl). - - -Lemma thin_clause_opt_spec m cl : - match thin_clause_opt m cl with - | None => False - | Some cl' => - exists premsnl premsl, - [/\ premise cl = union_opt premsnl premsl, - cl' = (premsnl, concl cl), - (forall l k, (l, k) ∈ premsnl -> ~ entails (clauses m) (premise cl, (l, k+1))) & - on_Some_or_None (fun premsl => entails_all (clauses m) (premise cl) (succ premsl)) premsl] - end. -Proof. - funelim (thin_clause_opt m cl); clear H. - - assert (h := thin_clause_spec m cl). - cbn in h. - rewrite e in h. - now eapply model_entails_loop in h. - - assert (h := thin_clause_spec m cl). - cbn in h. - clear Heqcall. - rewrite ne in h. - destruct h as [premsnl [premsl []]]. - exists premsnl, premsl; split => //. - f_equal. apply equal_exprsets; cbn. now rewrite H0. -Qed. - -Lemma interp_nes_thin_clause (v : Level.t -> Z) {m cl ne} {premsnl : NES.t} : - thin_clause m cl = premsnl -> - interp_nes v ({| t_set := thin_clause m cl; t_ne := ne |}) = - interp_nes v premsnl. -Proof. - intros eq. - destruct premsnl. - destruct cl as [prems concl]; cbn in eq. - subst t_set0. f_equal. - apply equal_exprsets. cbn. reflexivity. -Qed. - -Lemma interp_nes_union_opt v e e' : - interp_nes v (union_opt e e') = - match e' with - | Some e' => Z.max (interp_nes v e) (interp_nes v e') - | None => interp_nes v e - end. -Proof. - destruct e' => //=. - now rewrite interp_nes_union; cbn. -Qed. - -Lemma thin_clause_opt_valid m cl : - match thin_clause_opt m cl with - | None => False - | Some cl' => valid_clause_Z (clauses m) cl <-> valid_clause_Z (clauses m) cl' - end. -Proof. - (* intros hent. *) - funelim (thin_clause_opt m cl). - - clear H Heqcall. - have hs := thin_clause_spec m cl. - cbn in hs. rewrite e in hs. - now eapply model_entails_loop in hs. - - clear H Heqcall. - have hs := thin_clause_spec m cl. - cbn in hs. rewrite ne in hs. - destruct cl as [prems [concl k]]. - rewrite /valid_clause_Z. cbn. - cbn in hs. destruct hs as [premsl [premsnl [heq heq' hent' hentl]]]. - split. - * move=> hv v vpos csem. - have hi := interp_nes_thin_clause v (ne := ne) heq'. - move: hv => /(_ v vpos csem). - rewrite hi. subst prems. - rewrite interp_nes_union_opt. - destruct premsnl => //. - destruct heq'. - move/to_entails_all: hentl. - move/entails_L_entails_ℋ_equiv/entails_L_rels_entails_L_clauses/completeness_all. - move/(_ Z _ v). - rewrite -interp_rels_clauses_sem. - move/(_ csem). - rewrite -interp_rels_clauses_sem. - move/clauses_sem_clauses_of_le. - rewrite interp_add_prems interp_nes_union. - cbn in hent' |- *. lia. - * move=> hv v vpos csem. - have hi := interp_nes_thin_clause v (ne := ne) heq'. - move: hv => /(_ v vpos csem). - rewrite hi. - subst prems. - rewrite interp_nes_union_opt. - destruct premsnl => //. - destruct heq'. - move/to_entails_all: hentl. - move/entails_L_entails_ℋ_equiv/entails_L_rels_entails_L_clauses/completeness_all. - move/(_ Z _ v). - rewrite -interp_rels_clauses_sem. - move/(_ csem). - rewrite -interp_rels_clauses_sem. - move/clauses_sem_clauses_of_le. - rewrite interp_add_prems interp_nes_union. - cbn in hent' |- *. lia. -Qed. - -(* -Lemma thin_clause_opt_entails m cl : - match thin_clause_opt m cl with - | None => False - | Some cl' => entails (clauses m) cl' -> entails (clauses m) cl - end. -Proof. Admitted. *) - -Definition thin_clauses m := - Clauses.fold (fun cl acc => - match thin_clause_opt m cl with - | Some cl' => Clauses.add cl' acc - | None => acc (* Impossible for consistent models *) - end) (clauses m) Clauses.empty. - -Lemma thin_clauses_spec m : - forall cl, Clauses.In cl (clauses m) -> - exists cl', thin_clause_opt m cl = Some cl' /\ Clauses.In cl' (thin_clauses m). -Proof. Admitted. - -Lemma thin_clauses_spec_inv m : - forall cl, Clauses.In cl (thin_clauses m) -> - exists clo, thin_clause_opt m clo = Some cl /\ Clauses.In clo (clauses m). -Proof. Admitted. - -(** The thinned clauses are stronger than the original clauses *) -Lemma thin_clauses_entails m : thin_clauses m ⊢ℋ clauses m. -Proof. - intros cl hin. - destruct (thin_clauses_spec m cl hin) as [cl' [heq hin']]. - have hs := thin_clause_opt_spec m cl. - rewrite heq in hs. destruct hs as [premsnl [premsl [eq eq' ent ent']]]. - destruct cl as [prems concl]. cbn in eq, eq', ent. - subst prems cl'. - now eapply entails_weak_union_opt, entails_in. -Qed. -Lemma thin_clauses_model model m : - is_model model (thin_clauses m) -> is_model model (clauses m). -Proof. - move=> ism. eapply is_model_entails_H; tea. - eapply thin_clauses_entails. -Qed. - - -Lemma is_total_model_thin m m' : - is_total_model m' (clauses m) -> - is_total_model m' (thin_clauses m). -Proof. - move/is_total_model_altP => ism. - apply/is_total_model_altP => cl /thin_clauses_spec_inv -[] cl' [] heq /ism. - have := thin_clause_opt_spec m cl'. - rewrite heq => -[premsnl] [premsl] [eq eq' ent nent]. - subst cl. - move=> -[] minp [] value [] => hmin hl hle. - exists minp, value. cbn. split => //. - rewrite -hmin eq. - apply antisymmetry; revgoals. - { eapply min_premise_subset. destruct premsl; cbn; lesets. } - destruct premsl as [premsl|]; cbn => //; revgoals. reflexivity. - rewrite min_premise_union. - cbn in nent. - rewrite -to_entails_all in nent. - eapply entails_all_model_valid in nent. 2:{ apply is_model_valid. eapply is_total_model_altP in ism. apply ism. } - rewrite eq in nent. cbn in nent. - rewrite eq min_premise_union in hmin. - destruct (min_premise m' premsl) as [minl|] eqn:minle, (min_premise m' premsnl) as [minnl|] eqn:minnle; cbn in hmin |- * => //. - noconf hmin. constructor. - eapply valid_clauses_of_le in nent. 2:{ rewrite min_premise_union minle minnle //=. } - 2:{ rewrite (min_premise_add_prems minle); trea. } lia. -Qed. - - -Lemma total_model_thin m : is_total_model (model m) (thin_clauses m). -Proof. - by eapply is_total_model_thin, total_model. -Qed. - -Definition check_clauseZ m cl := - check_genb (thin_clauses m) cl. - -Lemma clauses_levels_thin m : clauses_levels (thin_clauses m) ⊂_lset clauses_levels (clauses m). -Proof. Admitted. - -Lemma check_gen_thin_model_looping m cl v vcls isl : - check_gen (thin_clauses m) cl = IsLooping v vcls isl -> False. -Proof. - intros. - have hm := m.(model_valid).(model_ok). - have hen := model_enabled m. - have htot : is_total_model (model m) (clauses m). - split => //. - eapply is_total_model_thin in htot. - eapply (check_valid_looping (cls := thin_clauses m)). apply htot. tea. - eapply defined_model_of_ext. eapply defined_model_of_subset. - 2:{ eapply defined_model. } - intros ? ?; eapply clauses_levels_declared. - instantiate (1 := m). now eapply clauses_levels_thin, vcls. - reflexivity. -Qed. - -Lemma checkb_thin_entails m cl : - check_genb (thin_clauses m) cl <-> entails (thin_clauses m) cl. -Proof. - unfold check_genb. - destruct (check_gen) eqn:ec. - - now move/check_gen_thin_model_looping: ec. - - split => //. - now move/check_invalid_entails: ec. - - now move/check_gen_entails: ec. -Qed. diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index f08c938c1..78ad7d17f 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -1020,8 +1020,6 @@ End ZUnivConstraint. Definition enforce_constraints g cstrs := enforce_constraints_aux (Some g) cstrs. - Definition declared_univ_cstrs_levels levels cstrs := UnivConstraintSet.For_all (declared_univ_cstr_levels levels) cstrs. - Lemma satisfies_singleton v x : satisfies v (UnivConstraintSet.singleton x) <-> satisfies0 v x. Proof. split. diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 91e464af4..4bea21410 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -889,6 +889,8 @@ Definition declared_univ_cstr_levels levels (cstr : UnivConstraint.t) := let '(l1,_,l2) := cstr in LevelSet.Subset (Universe.levels l1) levels /\ LevelSet.Subset (Universe.levels l2) levels. +Definition declared_univ_cstrs_levels levels cstrs := UnivConstraintSet.For_all (declared_univ_cstr_levels levels) cstrs. + Definition is_declared_univ_cstr_levels levels (cstr : UnivConstraint.t) : bool := let '(l1,_,l2) := cstr in LevelSet.subset (Universe.levels l1) levels && LevelSet.subset (Universe.levels l2) levels. diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index 888284cb0..38341f87f 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -13,7 +13,7 @@ Definition universe_model := UnivLoopChecking.univ_model. Definition init_model : universe_model := UnivLoopChecking.init_model. Definition uctx_invariants (uctx : ContextSet.t) - := UnivLoopChecking.declared_univ_cstrs_levels (LevelSet.add Level.lzero uctx.1) uctx.2. + := declared_univ_cstrs_levels (LevelSet.add Level.lzero uctx.1) uctx.2. Definition global_uctx_invariants (uctx : ContextSet.t) := ~ LevelSet.In Level.lzero uctx.1 /\ uctx_invariants uctx. @@ -778,14 +778,14 @@ Proof. have hs := init_constraints_subset m. ucsets. Qed. -Definition wf_uctx_ext (m : univ_model) (uctx : ContextSet.t) := - (forall l, LevelSet.In l uctx.1 -> ~ LevelSet.In l (levels m)) /\ - declared_univ_cstrs_levels (LevelSet.union uctx.1 (levels m)) uctx.2. +Definition wf_uctx_ext (ctx : LevelSet.t) (uctx : ContextSet.t) := + (forall l, LevelSet.In l uctx.1 -> ~ LevelSet.In l ctx) /\ + declared_univ_cstrs_levels (LevelSet.union uctx.1 ctx) uctx.2. (* Instance declared_univ_cstrs_levels_proper *) Lemma push_uctx_model_unsat `{cf : checker_flags} [m uctx] : - wf_uctx_ext m uctx -> + wf_uctx_ext (levels m) uctx -> push_uctx m uctx = None <-> let allcstrs := (UnivConstraintSet.union (constraints m) uctx.2) in (~ exists v, satisfies v allcstrs). diff --git a/safechecker/theories/PCUICSafeChecker.v b/safechecker/theories/PCUICSafeChecker.v index c39958798..fcf9bab1f 100644 --- a/safechecker/theories/PCUICSafeChecker.v +++ b/safechecker/theories/PCUICSafeChecker.v @@ -189,7 +189,6 @@ Section OnUdecl. apply In_Var_global_ext_poly. len. - destruct wfext as [onX onu]. simpl in *. destruct onu as [_ [_ [sat _]]]. - do 2 red in sat. unfold PCUICLookup.global_ext_constraints in sat. simpl in sat. red. destruct check_univs => //. unfold valid_constraints0. @@ -221,7 +220,6 @@ Section OnUdecl. apply In_Var_global_ext_poly. len. - destruct wfext as [onX onu]. simpl in *. destruct onu as [_ [_ [sat _]]]. - do 2 red in sat. unfold PCUICLookup.global_ext_constraints in sat. simpl in sat. red. destruct check_univs => //. unfold valid_constraints0. @@ -304,14 +302,14 @@ Section CheckEnv. Section UniverseChecks. Obligation Tactic := idtac. - Lemma consistent_extension_on_global Σ uctx : + (* Lemma consistent_extension_on_global Σ uctx : consistent_extension_on (global_uctx Σ) uctx -> consistent_extension_on Σ uctx. Proof using Type. move=> hext v {}/hext [v' [satv' eqv']]. exists v'; split=> // x hx; apply: eqv'. apply/LevelSet.union_spec; by left. - Qed. + Qed. *) Definition declared_universe (ls : LevelSet.t) u : bool := LevelSet.subset (Universe.levels u) ls. @@ -383,11 +381,18 @@ Section CheckEnv. - split; eauto. pose (HΣ := abstract_env_wf _ wfΣ); sq. apply wf_global_uctx_invariants in HΣ. - enough (valid_on_mono_udecl (global_uctx Σ) udecl). + (* enough (valid_on_mono_udecl (global_uctx Σ) udecl). 1: { split. apply wf_consistent_extension_on_consistent => //. - apply: consistent_extension_on_global=> //. } - red. - eapply abstract_env_is_consistent_correct with (udecl := uctx_of_udecl udecl); eauto=> //. + apply: consistent_extension_on_global=> //. } *) + red. cbn. + eapply abstract_env_is_consistent_correct in uctx'; tea. + cbn in uctx'. rewrite /global_constraints in uctx'. + rewrite /univs_ext_constraints. now rewrite UnivConstraintSetProp.union_sym. + split => //. + intros l hin hin'. apply LevelSet.for_all_spec in H. + specialize (H l hin). + have h := not_var_global_levels hΣ l hin' => //. + now rewrite H in h. tc. Qed. Definition check_wf_env_ext_prop X X_ext ext := @@ -2271,9 +2276,16 @@ End monad_Alli_nth_forall. Lemma levels_global_levels_declared univs : LevelSet.mem Level.lzero (ContextSet.levels univs) -> - LevelSet.Equal (PCUICLookup.global_levels univs) (ContextSet.levels univs). + LevelSet.Equal (PCUICLookup.global_levels (LevelSet.remove Level.lzero univs.1, univs.2)) (ContextSet.levels univs). Proof using Type. clear. move / LevelSet.mem_spec. intros Hin l. unfold global_levels. rewrite LS.union_spec LevelSet.singleton_spec. + cbn. rewrite LevelSet.remove_spec. firstorder. now subst. + destruct l => //. now right. left. intuition. congruence. + left. intuition. congruence. + Qed. + + Lemma add_singleton l : LevelSet.add l (LevelSet.singleton l) =_lset LevelSet.singleton l. + Proof. lsets. Qed. @@ -2283,50 +2295,57 @@ End monad_Alli_nth_forall. /\ ∥ on_global_univs univs ∥ }) := let id := "toplevel" in let levels := ContextSet.levels univs in - check_eq_true_lazy (LevelSet.mem Level.lzero levels) + check_eq_true_lazy (~~ (LevelSet.mem Level.lzero levels)) (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("Level zero is not declared in the global levels " ^ print_lset levels))));; check_eq_true_lazy (LevelSet.for_all (fun l => negb (Level.is_var l)) levels) (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("Variable level in the global levels " ^ print_lset levels))));; - check_eq_true_lazy (UnivConstraintSet.for_all (fun c => declared_universe levels c.1.1 && declared_universe levels c.2) (ContextSet.constraints univs)) + check_eq_true_lazy (UnivConstraintSet.for_all (fun c => declared_universe (LevelSet.add Level.lzero levels) c.1.1 && declared_universe (LevelSet.add Level.lzero levels) c.2) (ContextSet.constraints univs)) (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("Non declared level in " ^ print_lset levels ^ " |= " ^ print_univ_constraint_set (ContextSet.constraints univs)))));; check_eq_true_lazy (@abstract_env_is_consistent_empty _ X_impl univs) (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("Constraints are not satisfiable:" ^ print_univ_constraint_set (ContextSet.constraints univs))))) ;; - ret (let Hunivs := _ in exist (abstract_env_init univs retro Hunivs) _). + ret (let Hunivs := _ in exist (abstract_env_init (univs.1, univs.2) retro Hunivs) _). Next Obligation. intros. have decll : - UnivConstraintSet.For_all (declared_univ_cstr_levels (ContextSet.levels univs)) (ContextSet.constraints univs). + UnivConstraintSet.For_all (declared_univ_cstr_levels (LevelSet.add Level.lzero (ContextSet.levels univs))) (ContextSet.constraints univs). { clear -i1. apply UnivConstraintSet.for_all_spec in i1. 2: now intros x y []. - intros [[l ct] l'] Hl. specialize (i1 _ Hl). simpl in i1. - apply andb_true_iff in i1. destruct i1 as [H H1]. - apply LevelSet.subset_spec in H. apply LevelSet.subset_spec in H1. + move=> [[l ct] l'] /i1 /andb_true_iff //=> [] h h'. + apply LevelSet.subset_spec in h. apply LevelSet.subset_spec in h'. now split. } intros. split; eauto. - { intros l Hl. specialize (decll l Hl). red. destruct l, p. now rewrite levels_global_levels_declared. } + { intros l Hl. specialize (decll l Hl). red. destruct l, p. unfold PCUICLookup.global_levels. cbn. + (* rewrite -LevelSetProp.union_sym -LevelSetProp.add_union_singleton levelset_add_remove. *) + cbn in Hl. destruct decll. split; lsets. } split; eauto. unfold declared_univ_cstr_levels. cbn. repeat split => //. + clear - i i0. apply LevelSet.for_all_spec in i0. 2: now intros x y []. - intros l Hl. rewrite levels_global_levels_declared in Hl; eauto. + subst levels. + rewrite /i0 => l. cbn. destruct l => //=. + rewrite /PCUICLookup.global_levels //=. + rewrite LevelSet.union_spec LevelSet.singleton_spec => //. + move: (i0 (Level.lvar n)) => hl. + intros [|]. cbn in hl. specialize (hl H). congruence. + congruence. + unfold abstract_env_is_consistent_empty in i2. pose proof (abs_init := abstract_env_init_correct (abstract_env_impl := X_env_type) - (LS.singleton Level.lzero, UCS.empty) Retroknowledge.empty PCUICWfEnv.abstract_env_empty_obligation_1). - epose proof (abs_consist := abstract_env_is_consistent_correct (@abstract_env_empty cf X_impl) _ univs abs_init); cbn in *. + (LevelSet.singleton Level.lzero, UCS.empty) Retroknowledge.empty PCUICWfEnv.abstract_env_empty_obligation_1). + epose proof (abs_consist := abstract_env_is_consistent_correct _ _ univs abs_init); cbn in *. rewrite /declared_univ_cstr_levels //= in abs_consist. forward abs_consist. - { move/UCS.for_all_spec: i1 => hf cl /hf. destruct cl as [[? ?] ?] => //=. - case/andP=> /LevelSet.subset_spec hl /LevelSet.subset_spec hr. subst levels; unfold ContextSet.levels in *; cbn in *. - split; lsets. } + { split. + { move=> l hin hin'. apply LevelSet.singleton_spec in hin'. subst l. + move/LevelSet.mem_spec: hin => e. now rewrite e in i. } + unfold global_levels. cbn. + rewrite LevelSetProp.union_sym -LevelSetProp.add_union_singleton add_singleton -LevelSetProp.add_union_singleton //. } rewrite /global_uctx //= /global_levels /global_constraints //= in abs_consist. pose (abstract_env_wf _ abs_init). sq. - rewrite <- abs_consist in i2; eauto ; clear abs_consist; cbn; sq. - pose proof (wf_consistent_extension_on_consistent _ _ i2). - rewrite UnivConstraintSetProp.union_sym in H. now rewrite CS_union_empty in H. + apply abs_consist in i2; eauto ; clear abs_consist; cbn; sq. Qed. Next Obligation. - cbv beta. intros univs retro name levels H nv hd habs Hunivs. clearbody Hunivs. + cbv beta. intros [] retro name levels H nv hd habs Hunivs. clearbody Hunivs. split. - intros. eapply (abstract_env_irr _ _ (abstract_env_init_correct _ _ _)); eauto. - now sq. diff --git a/safechecker/theories/PCUICWfEnv.v b/safechecker/theories/PCUICWfEnv.v index e95212a2d..f6955e528 100644 --- a/safechecker/theories/PCUICWfEnv.v +++ b/safechecker/theories/PCUICWfEnv.v @@ -109,8 +109,8 @@ Class abstract_env_prop {cf:checker_flags} (abstract_env_impl abstract_env_ext_i LevelSet.In l (global_ext_levels Σ) <-> abstract_env_level_mem X l; abstract_env_is_consistent_correct X Σ udecl : abstract_env_rel X Σ -> - UnivConstraintSet.For_all (declared_univ_cstr_levels (LevelSet.union udecl.1 (global_levels Σ))) udecl.2 -> - consistent_extension_on (global_uctx Σ) udecl.2 <-> abstract_env_is_consistent X udecl; + wf_uctx_ext (global_levels Σ) udecl -> + consistent (UnivConstraintSet.union (global_uctx Σ).2 udecl.2) <-> abstract_env_is_consistent X udecl; abstract_env_guard_correct X {Σ} (wfΣ : abstract_env_ext_rel X Σ) fix_cofix Γ mfix : guard fix_cofix Σ Γ mfix <-> abstract_env_guard X fix_cofix Γ mfix; @@ -178,7 +178,6 @@ Proof. - red. rewrite /univs_ext_constraints /=. rewrite CS_union_empty. apply wfΣ. - - apply consistent_extension_on_empty. Qed. Program Definition abstract_env_empty_ext {cf:checker_flags} {X_type : abstract_env_impl} @@ -308,24 +307,6 @@ Proof. now rewrite LevelSet.mem_spec. Qed. -Lemma wf_consistent_extension_on_consistent {cf:checker_flags} {Σ} udecl : - wf Σ -> consistent_extension_on (global_uctx Σ) udecl -> - consistent (UnivConstraintSet.union udecl (global_constraints Σ)). -Proof. - intros s Hext. pose proof (wf_consistent _ s). - destruct H as [val Hval]. - destruct (Hext val Hval) as [val' [Hval' Hval'']]. exists val'. - intros [[l ct] l'] [Hl|Hl]%UCS.union_spec; eauto. - destruct (Hval _ Hl); cbn; econstructor. -Admitted. - (* - erewrite <- (Hval'' l0). erewrite <- (Hval'' l'0) => //. - + destruct s as [[Hs _] _]. now destruct (Hs _ Hl). - + destruct s as [[Hs _] _]. now destruct (Hs _ Hl). - - erewrite <- (Hval'' l0). erewrite <- (Hval'' l'0) => //. - + destruct s as [[Hs _] _]. now destruct (Hs _ Hl). - + destruct s as [[Hs _] _]. now destruct (Hs _ Hl). *) -(* Qed. *) - Lemma abstract_env_lookup_correct' {cf:checker_flags} {X_type : abstract_env_impl} ( X:X_type.π2.π1) {Σ} kn : abstract_env_ext_rel X Σ -> lookup_env Σ kn = abstract_env_lookup X kn. @@ -339,4 +320,3 @@ Proof. intros decl Hdecl. eapply abstract_env_lookup_correct in Hdecl; eauto. destruct Hnotin. apply in_map_iff. now exists (kn,decl). Qed. - diff --git a/safechecker/theories/PCUICWfEnvImpl.v b/safechecker/theories/PCUICWfEnvImpl.v index 2cc8f3883..acc416ae8 100644 --- a/safechecker/theories/PCUICWfEnvImpl.v +++ b/safechecker/theories/PCUICWfEnvImpl.v @@ -280,6 +280,14 @@ End GraphSpec. Import UnivLoopChecking.UnivLoopChecking. +From Stdlib Require Import Morphisms. + +Instance wf_uctx_ext_proper : Morphisms.Proper (LevelSet.Equal ==> eq ==> iff) wf_uctx_ext. +Proof. + intros ? ? ls ? ? ->. + rewrite /wf_uctx_ext. now setoid_rewrite ls. +Qed. + Program Global Instance canonical_abstract_env_prop {cf:checker_flags} {guard : abstract_guard_impl} : @abstract_env_prop _ _ _ canonical_abstract_env_struct := {| abstract_env_ext_exists := fun Σ => sq (reference_impl_env_ext Σ ; eq_refl); |}. @@ -312,55 +320,44 @@ Next Obligation. rename H0 into Hudecl. assert (H0 : global_uctx_invariants (clean_uctx (global_uctx X))). { eapply wf_global_uctx_invariants; eauto. } - set (udecl := (t , t0)). destruct (push_uctx _ udecl) eqn:hp. - split => // _. - subst udecl. - intros v sat. - pose proof (reference_impl_graph_wf X) as HG. - set (gph := (graph_of_wf X).π1) in *. simpl in HG. + have h := is_model_of_uctx (reference_impl_graph X). cbn in h. + pose proof (reference_impl_graph_wf X) as HG. simpl in HG. + unfold reference_impl_graph in hp. eapply push_uctx_model in hp; tea. exists (to_valuation (LoopCheck.valuation u.(model))). - split. destruct hp as [hl hc]. have hv := model_satisfies u. rewrite hc in hv. apply satisfies_union in hv as [hv hv']. apply satisfies_union in hv as [ht hg]. - now cbn in ht. - todo "Valuation does not change for globals". + apply satisfies_union => //. - split=> // hcon. + pose proof (reference_impl_graph_wf X) as HG. simpl in HG. have hs := push_uctx_spec (reference_impl_graph X) udecl. rewrite hp in hs. cbn in hs. - Search push_uctx. in hp. - - (* assert (H1 : global_uctx_invariants (ContextSet.union udecl (global_uctx X))). - { split => //. - - apply LevelSet.union_spec; right ; now destruct H0. - - intros [[l ct] l'] [Hl|Hl]%UCS.union_spec. - + now specialize (Hudecl _ Hl). - + destruct H0 as [_ H0]. specialize (H0 _ Hl). - split; apply LevelSet.union_spec; right; - now cbn in H0. - } *) - (* unfold reference_impl_graph; rewrite andb_and. *) - pose proof (HG' := model_of_uctx_add Hudecl' HG). - pose (global_ext_uctx := ContextSet.union udecl (global_uctx X)). - pose (wf_consistent_extension_on_consistent udecl.2 s). - assert (reorder : forall a a' b c : Prop, (b -> a) -> (a /\ b <-> a' /\ c) -> b <-> a' /\ c) by intuition; eapply reorder; try eassumption; clear reorder. - rewrite - (is_consistent_spec global_ext_uctx) (is_consistent_spec2 HG'). - assert (reorder : forall a b c : Prop, (a -> b <-> c) -> a /\ b <-> a /\ c) by intuition; apply reorder. - move=> ?; rewrite consistent_extension_on_union. - 1:{ pose proof (reference_impl_wf X); sq. - apply: PCUICUnivSubstitutionConv.levels_global_constraint. } - cbn. - change (UCS.union _ _) with global_ext_uctx.2. - apply: consistent_ext_on_full_ext=> //. - apply: add_uctx_subgraph. + apply push_uctx_model_unsat in hp. + * exfalso; apply hp. + destruct hcon as [v h]. exists v. apply satisfies_union in h as []. + apply satisfies_union => //. split => //. + unfold reference_impl_graph. unfold global_constraints in H. + destruct HG as [hl hc]. rewrite hc. + apply satisfies_union. split => //. apply satisfies_init. + * clear H. move: Hudecl. + destruct HG as [hl hc]. + move=> [hl' hc']. + rewrite /reference_impl_graph hl. cbn. + split. + { move=> l hin hin'. specialize (hl' l hin). + apply hl'. apply LevelSet.union_spec in hin' as [] => //. + apply LevelSet.singleton_spec in H. subst l. + apply global_levels_InSet. } + { move=> cl /hc'. + eapply declared_univ_cstr_levels_subset. lsets. reflexivity. } Qed. Next Obligation. apply guard_correct. Qed. - Program Global Instance optimized_abstract_env_prop {cf:checker_flags} {guard : abstract_guard_impl} : @abstract_env_prop _ _ _ optimized_abstract_env_struct := {| abstract_env_ext_exists := fun Σ => sq (reference_impl_env_ext Σ ; eq_refl); |}. @@ -392,7 +389,7 @@ Next Obligation. now erewrite (abstract_env_level_mem_correct X.(wf_env_ext_reference)). Qed. Next Obligation. - now erewrite (abstract_env_is_consistent_correct X.(wf_env_reference)) with (udecl := (t,t0)); eauto. + rewrite (abstract_env_is_consistent_correct X.(wf_env_reference)) //. Qed. Next Obligation. eapply guard_correct. Qed. From 3688f28ee19a22e78772bbd4c254ff813ff7b7d1 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 7 Nov 2025 21:50:16 +0100 Subject: [PATCH 137/164] Fill admitted proofs --- .../Conversion/PCUICUnivSubstitutionConv.v | 231 +++++++++++------- safechecker/theories/PCUICSafeChecker.v | 68 ++++-- 2 files changed, 190 insertions(+), 109 deletions(-) diff --git a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v index 06dd6ff9d..276428b74 100644 --- a/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v +++ b/pcuic/theories/Conversion/PCUICUnivSubstitutionConv.v @@ -43,6 +43,17 @@ Proof using Type. + apply map_spec in H as [e []]. exists e. split => //. now right. Qed. +Lemma levelexpr_add_0 e : LevelExpr.add 0 e = e. +Proof. rewrite /LevelExpr.add //=. now destruct e. Qed. + +Lemma plus_0 u : Universe.plus 0 u = u. +Proof. + apply equal_exprsets => l. + rewrite Universe.map_spec. + setoid_rewrite levelexpr_add_0. + now firstorder subst. +Qed. + Lemma subset_levels l s : LevelSet.Subset (levels l) s <-> (forall lk, LevelExprSet.In lk l -> LevelSet.In lk.1 s). Proof. rewrite /LevelSet.Subset. setoid_rewrite levels_spec. firstorder. apply H. exists lk.2; destruct lk => //. @@ -727,14 +738,109 @@ Qed. #[global] Hint Resolve monomorphic_global_constraint monomorphic_global_constraint_ext : univ_subst. +Lemma In_subst_instance x u (l : Universe.t) : + LevelExprSet.In x (subst_instance u l) <-> + (exists x', LevelExprSet.In x' l /\ + LevelExprSet.In x (subst_instance_level_expr u x')). +Proof. + unfold subst_instance; cbn. + unfold subst_instance_universe. + rewrite Universe.fold_union_spec. + firstorder. +Qed. + + +Lemma add_make l n : LevelExpr.add n (LevelExpr.make l) = (l, n). +Proof. + rewrite /LevelExpr.add //=; lia_f_equal. +Qed. + +Lemma subst_instance_level_spec x i l : + LevelExprSet.In x (subst_instance_level i l) <-> + (~ Level.is_var l /\ x = LevelExpr.make l) \/ exists n, l = Level.lvar n /\ + if nth_error i n is (Some u) then LevelExprSet.In x u + else x = (Level.lzero, 0). +Proof. + destruct l. + - cbn. setoid_rewrite LevelExprSet.singleton_spec. firstorder. + congruence. + - cbn; rewrite LevelExprSet.singleton_spec. firstorder congruence. + - cbn. destruct nth_error eqn:hnth => //. + * firstorder subst; auto => //. + + right. exists n; split => //. now rewrite hnth. + + now noconf H; rewrite hnth in H0. + * rewrite LevelExprSet.singleton_spec. firstorder subst. + + right. exists n. split => //; rewrite hnth. reflexivity. + + now elim H. + + noconf H. rewrite hnth in H0. subst. reflexivity. +Qed. + +Lemma subst_instance_level_expr_spec x i le : + LevelExprSet.In x (subst_instance_level_expr i le) <-> + (~ Level.is_var le.1 /\ x = le) \/ exists n k, le = (Level.lvar n, k) /\ + if nth_error i n is (Some u) then LevelExprSet.In x (Universe.plus k u) + else x = (Level.lzero, k). +Proof. + destruct le as [l k]. + cbn -[subst_instance_level]. + rewrite Universe.map_spec. + setoid_rewrite subst_instance_level_spec. + split. + - move=> -[] e. + firstorder subst. + * left. now rewrite add_make. + * right. exists x0, k. split => //. destruct nth_error => //. + + rewrite Universe.map_spec. exists e; split => //. + + subst. now rewrite add_make. + - move=> -[] h. + * destruct h as []. subst x. exists (l, 0). rewrite add_make; split => //. + left. split => //. + * destruct h as [n [k' [heq hnth]]]. + destruct nth_error eqn:hnth'. + + noconf heq. + apply Universe.map_spec in hnth as [? []]. subst x. + exists x0; split => //. + right. exists n; split => //. + now rewrite hnth'. + + noconf heq. subst x. exists (LevelExpr.make Level.lzero). + rewrite add_make. split => //. right. eexists; split; trea. + now rewrite hnth'. +Qed. + +Lemma monomorphic_univ_subst u i : + monomorphic_univ u -> + u@[i] = u. +Proof. + move=> hm. + apply equal_exprsets => l. rewrite In_subst_instance. + unfold monomorphic_univ in hm. apply LevelSet.for_all_spec in hm. 2:tc. + split. + - case=> x' [] hin hin'. + destruct x'. + move: hm => /(_ t0) => /fwd. + { apply Universe.levels_spec. now exists n. } + move/subst_instance_level_expr_spec: hin'. + intros [[_ ->]|] => //. + destruct H as [? [? [h ?]]]; noconf h => //=. + - move=> hin; exists l; split => //. + destruct l => //=. + apply Universe.map_spec. exists (t0, 0). + rewrite /LevelExpr.add //= Nat.add_0_r. split; trea. + move: (hm t0) => /fwd. + { apply Universe.levels_spec; now exists n. } + move=> hnv. apply/subst_instance_level_spec. + left. split => //. + now move/negP: hnv. +Qed. + Lemma subst_instance_monom_cstr inst c : - is_monomorphic_cstr c - -> subst_instance_univ_cstr inst c = c. + is_monomorphic_cstr c -> + subst_instance_univ_cstr inst c = c. Proof. intro H; apply andb_and in H. destruct H. -Admitted. - (* destruct c as [[[] ?] []]; cbnr; discriminate. *) -(* Qed. *) + destruct c as [[l ?] r]; cbnr. + rewrite /subst_instance_univ_cstr //= !monomorphic_univ_subst //. +Qed. Lemma equal_subst_instance_cstrs_mono u cstrs : UCS.For_all is_monomorphic_cstr cstrs -> @@ -809,24 +915,31 @@ Proof. + rewrite forallb_map. apply forallb_forall. intros l Hl. (* unfold global_ext_levels in *; simpl in *. *) eapply forallb_forall in H; tea. clear -H H2 Hl. -Admitted. -(* - apply LevelSet_mem_union in H. destruct H as [H|H]. - 2: { destruct l; simpl; try (apply LevelSet_mem_union; right; assumption). - apply consistent_instance_declared in H2. - apply (forallb_nth' n Level.lzero) in H2. - destruct H2 as [[? [H2 ?]]|H2]; rewrite H2; tas. - apply LS.mem_spec, global_ext_levels_InSet. } - * destruct l; simpl. - -- apply LS.mem_spec, global_ext_levels_InSet. - -- apply LS.mem_spec in H. - destruct φ as [|[φ1 φ2]]; simpl in *. - { now apply LevelSetFact.empty_iff in H. } - now apply monomorphic_level_notin_AUContext in H. - -- apply consistent_instance_declared in H2. - apply (forallb_nth' n Level.lzero) in H2. - destruct H2 as [[? [H2 ?]]|H2]; rewrite H2; tas. - apply LS.mem_spec, global_ext_levels_InSet. + apply LevelSet.subset_spec in H. apply LevelSet.subset_spec. + move=> l' /Universe.levels_spec [k] /In_subst_instance [] k' [] hin + /subst_instance_level_expr_spec. + move=> [[isv eq]|]. + { subst k'. cbn in isv. + move/subset_levels: H => /(_ _ hin) //=. + rewrite /global_ext_levels //= !LevelSet.union_spec //=. + intuition auto. + destruct φ as [|[φ1 φ2]]; simpl in *. + { now apply LevelSetFact.empty_iff in H. } + destruct l' => //. + * right. right. lsets. + * now apply monomorphic_level_notin_AUContext in H. + * now destruct isv. } + { apply consistent_instance_declared in H2. + case=> n [] k0 [eq hnth]. + destruct nth_error eqn:hnth' => //. + * eapply forallb_nth_error in H2. + erewrite hnth' in H2. cbn in H2. + move/LevelSet.subset_spec/subset_levels: H2. + apply Universe.map_spec in hnth as [e [he he']]. + destruct e; noconf he'. + move=> /(_ _ he) //=. + * noconf hnth. subst k'. + apply global_ext_levels_InSet. } + unfold consistent_instance_ext, consistent_instance in H2. unfold valid_constraints in *; destruct check_univs; [|trivial]. destruct φ as [|[φ1 φ2]]; simpl in *. @@ -840,7 +953,6 @@ Admitted. * destruct H2 as [_ [_ H2]]. eapply consistent_ext_trans_polymorphic_case_aux; try eassumption. Qed. -*) Lemma consistent_ext_trans {cf : checker_flags} Σ φ φ' udecl inst inst' : wf_ext_wk (Σ, φ) -> @@ -954,9 +1066,6 @@ Definition precompose_subst_instance__1 Rle u i i' Definition precompose_subst_instance__2 Rle u i i' := snd (precompose_subst_instance Rle u i i'). -Lemma plus_0 u : Universe.plus 0 u = u. -Proof. Admitted. - Lemma subst_instance_make'_make u l : subst_instance u (Universe.make (LevelExpr.make l)) = subst_instance_level u l. @@ -1051,17 +1160,6 @@ Qed. (** Now routine lemmas ... *) -Lemma In_subst_instance x u (l : Universe.t) : - LevelExprSet.In x (subst_instance u l) <-> - (exists x', LevelExprSet.In x' l /\ - LevelExprSet.In x (subst_instance_level_expr u x')). -Proof. - unfold subst_instance; cbn. - unfold subst_instance_universe. - rewrite Universe.fold_union_spec. - firstorder. -Qed. - Lemma subst_instance_univ_super l u : subst_instance_sort u (Sort.super l) = Sort.super (subst_instance u l). Proof. @@ -1798,63 +1896,6 @@ Proof. - apply hin. Qed. -Lemma add_make l n : LevelExpr.add n (LevelExpr.make l) = (l, n). -Proof. - rewrite /LevelExpr.add //=; lia_f_equal. -Qed. - -Lemma subst_instance_level_spec x i l : - LevelExprSet.In x (subst_instance_level i l) <-> - (~ Level.is_var l /\ x = LevelExpr.make l) \/ exists n, l = Level.lvar n /\ - if nth_error i n is (Some u) then LevelExprSet.In x u - else x = (Level.lzero, 0). -Proof. - destruct l. - - cbn. setoid_rewrite LevelExprSet.singleton_spec. firstorder. - congruence. - - cbn; rewrite LevelExprSet.singleton_spec. firstorder congruence. - - cbn. destruct nth_error eqn:hnth => //. - * firstorder subst; auto => //. - + right. exists n; split => //. now rewrite hnth. - + now noconf H; rewrite hnth in H0. - * rewrite LevelExprSet.singleton_spec. firstorder subst. - + right. exists n. split => //; rewrite hnth. reflexivity. - + now elim H. - + noconf H. rewrite hnth in H0. subst. reflexivity. -Qed. - -Lemma subst_instance_level_expr_spec x i le : - LevelExprSet.In x (subst_instance_level_expr i le) <-> - (~ Level.is_var le.1 /\ x = le) \/ exists n k, le = (Level.lvar n, k) /\ - if nth_error i n is (Some u) then LevelExprSet.In x (Universe.plus k u) - else x = (Level.lzero, k). -Proof. - destruct le as [l k]. - cbn -[subst_instance_level]. - rewrite Universe.map_spec. - setoid_rewrite subst_instance_level_spec. - split. - - move=> -[] e. - firstorder subst. - * left. now rewrite add_make. - * right. exists x0, k. split => //. destruct nth_error => //. - + rewrite Universe.map_spec. exists e; split => //. - + subst. now rewrite add_make. - - move=> -[] h. - * destruct h as []. subst x. exists (l, 0). rewrite add_make; split => //. - left. split => //. - * destruct h as [n [k' [heq hnth]]]. - destruct nth_error eqn:hnth'. - + noconf heq. - apply Universe.map_spec in hnth as [? []]. subst x. - exists x0; split => //. - right. exists n; split => //. - now rewrite hnth'. - + noconf heq. subst x. exists (LevelExpr.make Level.lzero). - rewrite add_make. split => //. right. eexists; split; trea. - now rewrite hnth'. -Qed. - Lemma wf_universe_subst_instance {cf : checker_flags} (Σ : global_env_ext) univs ui u : wf Σ -> wf_universe Σ u -> diff --git a/safechecker/theories/PCUICSafeChecker.v b/safechecker/theories/PCUICSafeChecker.v index fcf9bab1f..fbf93a067 100644 --- a/safechecker/theories/PCUICSafeChecker.v +++ b/safechecker/theories/PCUICSafeChecker.v @@ -55,16 +55,6 @@ Definition cs_equal (x y : ContextSet.t) : Prop := Qed.*) Require Import SetoidTactics. - Global Instance model_of_uctx_proper {cf} G : Proper (cs_equal ==> iff) (model_of_uctx G). - Proof. - intros [l c] [l' c'] [eql eqc]; cbn. - unfold model_of_uctx; cbn. cbn in *. - split. intros []; split. now rewrite -eql. - rewrite -eqc. - - Admitted. - - (** It otherwise tries [auto with *], very bad idea. *) Ltac Corelib.Program.Tactics.program_solve_wf ::= match goal with @@ -145,7 +135,31 @@ Section OnUdecl. Lemma subst_instance_universe_lift inst l : closedu_universe #|inst| l -> subst_instance (lift_instance #|inst| (Instance.of_level_instance (level_var_instance 0 inst))) l = lift_universe #|inst| l. - Proof. Admitted. + Proof. + intros cl. + apply Universe.equal_exprsets => le. + rewrite In_subst_instance. + rewrite In_lift_universe. + rewrite /subst_instance_level_expr. + split. + - case=> x' [] hin hin'. + eapply Universe.map_spec in hin' as [e' [hin' heq]]. + subst le. rewrite subst_instance_level_lift in hin'. + now move/LevelExprSet.for_all_spec: cl => /(_ _ hin). + apply LevelExprSet.singleton_spec in hin'. subst e'. + exists x'; split => //. + rewrite /LevelExpr.add /LevelExpr.make. cbn. + now rewrite Nat.add_0_r. + - case=> le' [hin ->]. + exists le'; split => //. + apply Universe.map_spec. exists (lift_level #|inst| le'.1, 0). + split => //. + rewrite subst_instance_level_lift. + now move/LevelExprSet.for_all_spec: cl => /(_ _ hin). + now apply LevelExprSet.singleton_spec. + rewrite /LevelExpr.add /LevelExpr.make. cbn. + now rewrite Nat.add_0_r. + Qed. Lemma subst_instance_level_var_instance inst l : closedu_level #|inst| l -> @@ -156,15 +170,41 @@ Section OnUdecl. now rewrite /level_var_instance [mapi_rec _ _ _]mapi_unfold (proj1 (nth_error_unfold _ _ _) ltn). Qed. - Lemma subst_instance_universe_var_instance inst l : closedu_universe #|inst| l -> subst_instance (level_var_instance 0 inst) l = l. Proof using Type. - Admitted. + clear cf. + intros cl. + apply Universe.equal_exprsets => le. + rewrite In_subst_instance. + rewrite /subst_instance_level_expr. + setoid_rewrite Universe.map_spec. + split. + - case=> x' [] hin. + setoid_rewrite subst_instance_level_var_instance; revgoals. + { now move/LevelExprSet.for_all_spec: cl => /(_ _ hin). } + case=> x0 [] /LevelExprSet.singleton_spec -> ->. + now rewrite add_make; destruct x'. + - move=> hin. exists le; split => //. + setoid_rewrite subst_instance_level_var_instance; revgoals. + { now move/LevelExprSet.for_all_spec: cl => /(_ _ hin). } + eexists; split; trea. + apply LevelExprSet.singleton_spec; trea. + now rewrite add_make; destruct le. + Qed. + + Ltac rw l := rewrite_strat (topdown l). + Ltac rw_in l H := rewrite_strat (topdown l) in H. Lemma lift_universe_singleton n n' : lift_universe n (Universe.of_level (Level.lvar n')) = Universe.of_level (Level.lvar (n + n')). - Proof. Admitted. + Proof. + apply Universe.equal_exprsets=> l. + rw In_lift_universe; rw LevelExprSet.singleton_spec. + split. + - case=> le' [] -> -> //=. + - move=> ->. eexists; split; trea. + Qed. Lemma variance_universes_spec Σ ctx v univs u u' : wf_ext (Σ, ctx) -> From 88c5bf3a54cf0ead596b3c3d2fb6b981e0ac0620 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 7 Nov 2025 22:32:06 +0100 Subject: [PATCH 138/164] Fill last remaining proofs --- .../theories/LoopChecking/UnivLoopChecking.v | 77 +++++++++++++++---- pcuic/theories/PCUICWfUniverses.v | 6 +- 2 files changed, 66 insertions(+), 17 deletions(-) diff --git a/common/theories/LoopChecking/UnivLoopChecking.v b/common/theories/LoopChecking/UnivLoopChecking.v index 78ad7d17f..b2a556403 100644 --- a/common/theories/LoopChecking/UnivLoopChecking.v +++ b/common/theories/LoopChecking/UnivLoopChecking.v @@ -1160,35 +1160,80 @@ End ZUnivConstraint. Lemma init_constraints_of_levels_spec ls : forall l, LevelSet.In l ls -> forall c, init_constraint_of_level l = Some c -> UnivConstraintSet.In c (init_constraints_of_levels ls). - Proof. Admitted. + Proof. + unfold init_constraints_of_levels. + set fn := (fun (l0 : LevelSet.elt) (cstrs : UnivConstraintSet.t) => + match init_constraint_of_level l0 with + | Some c0 => UnivConstraintSet.add c0 cstrs + | None => cstrs + end). + pose P := fun ls f => forall l : LevelSet.elt, + LevelSet.In l ls -> + forall c : (Universe.t × ConstraintType.t_) × Universe.t, + init_constraint_of_level l = Some c -> UnivConstraintSet.In c f. + change (P ls (LevelSet.fold fn ls UnivConstraintSet.empty)). + eapply LevelSetProp.fold_rec; subst P; cbn in *. + - move=> s' he l hin. lsets. + - move=> x a s' s'' hin hnin hadd ih l hinl c hinit. + unfold fn. + destruct (Classes.eq_dec l x). + * subst. rewrite hinit. ucsets. + * destruct (init_constraint_of_level x) eqn:ix. + eapply UnivConstraintSet.add_spec. right. + eapply ih; tea. move: (hadd l). + move=> [] /(_ hinl) [] //=. congruence. + eapply ih; tea. + move: (hadd l). + move=> [] /(_ hinl) [] //=. congruence. + Qed. Lemma init_constraints_of_levels_spec_inv ls : forall c, UnivConstraintSet.In c (init_constraints_of_levels ls) -> exists l, LevelSet.In l ls /\ init_constraint_of_level l = Some c. - Proof. Admitted. + Proof. + unfold init_constraints_of_levels. + eapply LevelSetProp.fold_rec. + - ucsets. + - move=> x a s' s'' hin hnin hadd ih c. + destruct init_constraint_of_level eqn:hi. + * move/UnivConstraintSet.add_spec => [->|]. + { exists x. split => //. now apply hadd. } + case/ih => l -[] hin' hinit. exists l. split => //. + apply hadd. now right. + * case/ih => l -[] hin' hinit. exists l. split => //. + apply hadd. now right. + Qed. Instance init_constraints_of_levels_proper : Proper (LevelSet.Equal ==> UnivConstraintSet.Equal) (init_constraints_of_levels). Proof. intros l l' eqll' cl. - rewrite /init_constraints_of_levels. - Admitted. + split. + - move/init_constraints_of_levels_spec_inv=> -[] i []. + rewrite eqll' => hin hinit. + eapply init_constraints_of_levels_spec; tea. + - move/init_constraints_of_levels_spec_inv=> -[] i []. + rewrite -eqll' => hin hinit. + eapply init_constraints_of_levels_spec; tea. + Qed. Lemma init_constraints_of_levels_add l c ls : init_constraint_of_level l = Some c -> init_constraints_of_levels (LevelSet.add l ls) =_ucset UnivConstraintSet.add c (init_constraints_of_levels ls). - Proof. Admitted. - - (* Lemma clauses_constraints m : - forall l, Clauses.In (Impl.init_clause_of_level l) (LoopCheck.clauses m) -> - exists c, init_constraint_of_level l = Some c /\ UnivConstraintSet.In c (constraints m). - - exists c Clauses.Subset (LoopCheck.to_clauses (to_constraint c)) (LoopCheck.clauses m). Proof. - move=> c. - move/repr_constraints => //. - Qed. *) - - (* Lemma in_singleton_to_clauses {le concl} c : Clauses.In (singleton le, concl) (to_clauses c) <-> c . *) + move=> hc cl. + split. + - move/init_constraints_of_levels_spec_inv=> -[] i [] /LevelSet.add_spec hin hinit. + destruct hin; subst. + * rewrite hc in hinit; noconf hinit. + ucsets. + * apply UnivConstraintSet.add_spec. right. + eapply init_constraints_of_levels_spec; tea. + - move/UnivConstraintSet.add_spec => [eq|hin]. + * subst. eapply init_constraints_of_levels_spec. apply LevelSet.add_spec. now left. exact hc. + * apply init_constraints_of_levels_spec_inv in hin as [l0 []]. + eapply init_constraints_of_levels_spec; tea. + now apply LevelSet.add_spec; right. + Qed. Lemma declared_init_constraints {m} : forall l, LevelSet.In l (levels m) -> diff --git a/pcuic/theories/PCUICWfUniverses.v b/pcuic/theories/PCUICWfUniverses.v index 167ac8378..0cdab243c 100644 --- a/pcuic/theories/PCUICWfUniverses.v +++ b/pcuic/theories/PCUICWfUniverses.v @@ -212,7 +212,11 @@ Section CheckerFlags. Forall (wf_universe (Σ, Monomorphic_ctx)) u -> forallb (fun x => LevelSet.for_all (negb $ Level.is_var) (Universe.levels x)) u. Proof using Type. - Admitted. + move=> wf onu hf. + rewrite All_forallb => //. solve_all. + apply/LevelSet.for_all_spec => l /Universe.levels_spec [k] /H //=. + destruct l => // /in_var_global_ext //=. lsets. + Qed. Lemma wf_level_sub Σ univs u : wf_level (Σ, Monomorphic_ctx) u -> From fb81f0c84a6246fec4c67186660b13c73aee640a Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 7 Nov 2025 22:33:00 +0100 Subject: [PATCH 139/164] Minor cleanup --- erasure/theories/EReorderCstrs.v | 17 ----------------- 1 file changed, 17 deletions(-) diff --git a/erasure/theories/EReorderCstrs.v b/erasure/theories/EReorderCstrs.v index f3752acbb..52510a799 100644 --- a/erasure/theories/EReorderCstrs.v +++ b/erasure/theories/EReorderCstrs.v @@ -41,23 +41,6 @@ Section Tags. Definition new_tag tags tag := find_tag tags 0 tag. Definition old_tag (tags : list nat) tag := nth_error tags tag. - (*Lemma old_of_new tags oldidx : - old_tag tags oldidx >>= new_tag tags = Some oldidx. - Proof. - rewrite /old_tag /new_tag. - destruct nth_error eqn:hnth => //=. 2:admit. - revert hnth. - rewrite -{2}[oldidx]Nat.add_0_r. generalize 0. - induction tags in oldidx, n |- *. - - intros n0. now rewrite nth_error_nil. - - cbn. intros n0 hnth. case: eqb_spec. - intros ->. destruct oldidx => //. (* tags are unique *) admit. - intros neq. - destruct oldidx. - * cbn in hnth. now noconf hnth. - * cbn in hnth. rewrite (IHtags oldidx) //. f_equal. lia. - Qed.*) - Lemma new_tag_spec tags newidx oldidx : new_tag tags newidx = Some oldidx -> old_tag tags oldidx = Some newidx. From 74785908c2eae9279c9af249c60043b6b80088ba Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 7 Nov 2025 23:35:06 +0100 Subject: [PATCH 140/164] Fix template checker --- pcuic/theories/Bidirectional/BDTyping.v | 2 +- pcuic/theories/Conversion/PCUICWeakeningConfigConv.v | 3 ++- template-rocq/theories/Checker.v | 6 ++++-- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/pcuic/theories/Bidirectional/BDTyping.v b/pcuic/theories/Bidirectional/BDTyping.v index 2af0594e8..c9f1ef0be 100644 --- a/pcuic/theories/Bidirectional/BDTyping.v +++ b/pcuic/theories/Bidirectional/BDTyping.v @@ -16,7 +16,7 @@ From Equations.Prop Require Import DepElim. From Equations Require Import Equations. Implicit Types (cf : checker_flags) (Σ : global_env_ext) (Γ : context). - +Local Set Warnings "-postfix-notation-not-level-1". Reserved Notation " Σ ;;; Γ |- t ▹ T " (at level 50, Γ, t, T at next level). Reserved Notation " Σ ;;; Γ |- t ▹□ u " (at level 50, Γ, t, u at next level). Reserved Notation " Σ ;;; Γ |- t ▹Π ( na , A , B ) " (at level 50, Γ, t, na, A, B at next level). diff --git a/pcuic/theories/Conversion/PCUICWeakeningConfigConv.v b/pcuic/theories/Conversion/PCUICWeakeningConfigConv.v index d8e8e084d..2d2915e4e 100644 --- a/pcuic/theories/Conversion/PCUICWeakeningConfigConv.v +++ b/pcuic/theories/Conversion/PCUICWeakeningConfigConv.v @@ -33,7 +33,8 @@ Lemma compare_decl_config_impl {cf1 cf2} pb Σ φ d d' : config.impl cf1 cf2 -> @compare_decl cf1 pb Σ φ d d' -> @compare_decl cf2 pb Σ φ d d'. Proof. - intros Hcf []; constructor; eauto using (@compare_term_config_impl cf1 cf2). + have hc := (@compare_term_config_impl cf1 cf2). + intros Hcf []; constructor; eauto. Qed. Lemma compare_context_config_impl {cf1 cf2} pb Σ φ Γ Γ' diff --git a/template-rocq/theories/Checker.v b/template-rocq/theories/Checker.v index abbc25558..51143dc89 100644 --- a/template-rocq/theories/Checker.v +++ b/template-rocq/theories/Checker.v @@ -835,10 +835,12 @@ Section Checker. ret tt end. + Definition clean_uctx (uctx : ContextSet.t) := (LevelSet.remove Level.lzero (fst uctx), snd uctx). + Definition typecheck_program (p : program) : EnvCheck term := let Σ := fst p in let '(univs, decls, retro) := (Σ.(universes), Σ.(declarations), Σ.(retroknowledge)) in - match push_uctx init_model univs with + match push_uctx init_model (clean_uctx univs) with | None => EnvError (IllFormedDecl "toplevel" (UnsatisfiableConstraints univs.2)) | Some G => @@ -851,7 +853,7 @@ End Checker. (* for compatibility, will go away *) Definition infer' `{checker_flags} `{Fuel} (Σ : global_env_ext) Γ t := let uctx := (global_ext_uctx Σ) in - match push_uctx init_model uctx with + match push_uctx init_model (clean_uctx uctx) with | None => raise (UnsatisfiableConstraints uctx.2) | Some m => infer (fst Σ) m Γ t end. From e7942df671fe51305b9c122c8166b2c99da7b63b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Fri, 7 Nov 2025 23:35:37 +0100 Subject: [PATCH 141/164] [fixme] Comment parametricity translations that require to run universe checking inside Rocq. --- translations/param_cheap_packed.v | 18 +++++++++--------- translations/param_generous_packed.v | 2 ++ translations/times_bool_fun.v | 4 +++- translations/times_bool_fun2.v | 2 ++ 4 files changed, 16 insertions(+), 10 deletions(-) diff --git a/translations/param_cheap_packed.v b/translations/param_cheap_packed.v index b0264bd78..a3218e06b 100644 --- a/translations/param_cheap_packed.v +++ b/translations/param_cheap_packed.v @@ -43,7 +43,7 @@ Fixpoint tsl_rec1 (n : nat) (t : term) {struct t} : term := end. -Fixpoint tsl_rec2 (fuel : nat) (Σ : global_env) (G : universes_graph) (E : tsl_table) (Γ : context) (t : term) {struct fuel} +Fixpoint tsl_rec2 (fuel : nat) (Σ : global_env) (G : universe_model) (E : tsl_table) (Γ : context) (t : term) {struct fuel} : tsl_result term := match fuel with | O => raise translation_utils.NotEnoughFuel @@ -81,7 +81,7 @@ Fixpoint tsl_rec2 (fuel : nat) (Σ : global_env) (G : universes_graph) (E : tsl_ | _ => raise TranslationNotHandeled end end -with tsl_term (fuel : nat) (Σ : global_env) (G : universes_graph) (E : tsl_table) (Γ : context) (t : term) {struct fuel} +with tsl_term (fuel : nat) (Σ : global_env) (G : universe_model) (E : tsl_table) (Γ : context) (t : term) {struct fuel} : tsl_result term := match fuel with | O => raise translation_utils.NotEnoughFuel @@ -144,16 +144,16 @@ Fixpoint replace t k u {struct u} := | x => x end. +Definition clean_uctx (uctx : ContextSet.t) := (LevelSet.remove Level.lzero (fst uctx), snd uctx). Definition tsl_mind_body (ΣE : tsl_context) (mp : modpath) (kn : kername) (mind : mutual_inductive_body) : tsl_result (tsl_table * list mutual_inductive_body). refine ( let Σ := fst (fst ΣE) in - match gc_of_uctx (global_ext_uctx (fst ΣE)) with + match push_uctx init_model (clean_uctx (global_ext_uctx (fst ΣE))) with | None => raise (TypingError (UnsatisfiableConstraints (snd (global_ext_uctx (fst ΣE))))) - | Some ctrs => - let G := make_graph ctrs in + | Some G => let E := snd ΣE in let tsl_ty' := tsl_ty_param fuel Σ G E [] in let tsl2' := tsl_rec2 fuel Σ G E [] in @@ -224,14 +224,14 @@ Defined. #[export] Instance tsl_param : Translation := {| tsl_id := tsl_ident ; tsl_tm := fun ΣE t => - match gc_of_uctx (global_ext_uctx (fst ΣE)) with + match push_uctx init_model (global_ext_uctx (fst ΣE)) with | None => raise (TypingError (UnsatisfiableConstraints (snd (global_ext_uctx (fst ΣE))))) - | Some ctrs => tsl_term fuel (fst (fst ΣE)) (make_graph ctrs) (snd ΣE) [] t + | Some M => tsl_term fuel (fst (fst ΣE)) M (snd ΣE) [] t end; tsl_ty := Some (fun ΣE t => - match gc_of_uctx (global_ext_uctx (fst ΣE)) with + match push_uctx init_model (global_ext_uctx (fst ΣE)) with | None => raise (TypingError (UnsatisfiableConstraints (snd (global_ext_uctx (fst ΣE))))) - | Some ctrs => tsl_ty_param fuel (fst (fst ΣE)) (make_graph ctrs) (snd ΣE) [] t + | Some M => tsl_ty_param fuel (fst (fst ΣE)) M (snd ΣE) [] t end); tsl_ind := tsl_mind_body |}. diff --git a/translations/param_generous_packed.v b/translations/param_generous_packed.v index 0947f1942..22dc16ea3 100644 --- a/translations/param_generous_packed.v +++ b/translations/param_generous_packed.v @@ -183,6 +183,7 @@ Next Obligation. - cbn; intros A B x y. exact y.2. Defined. +(* Time MetaRocq Run (TC <- ImplementExisting TC' "sigT_ind" ;; tmDefinition "TC''" TC). Next Obligation. @@ -308,3 +309,4 @@ Next Obligation. intros [[[] [[] H]] _]. apply H; reflexivity. - cbn. intros [[[] [[] H]] _]. apply H; reflexivity. Defined. *) +*) \ No newline at end of file diff --git a/translations/times_bool_fun.v b/translations/times_bool_fun.v index f4021757b..57ecd8d15 100644 --- a/translations/times_bool_fun.v +++ b/translations/times_bool_fun.v @@ -111,7 +111,7 @@ Definition combine' {A B} (p : list A * list B) : list (A * B) Fixpoint replace pat u t {struct t} := - if eq_term uGraph.init_graph t pat then u else + if eq_term uGraph.init_model t pat then u else match t with | tCast t c A => tCast (replace pat u t) c (replace pat u A) | tProd n A B => tProd n (replace pat u A) (replace (up pat) (up u) B) @@ -339,6 +339,7 @@ Next Obligation. tIntro y. tIntro p. destruct p. exact t. Defined. +(* MetaRocq Run (TC <- TranslateRec eqTC'' wUnivalence ;; tmDefinition "eqTC3" TC). @@ -405,3 +406,4 @@ Next Obligation. apply (f_equal bool_of_Equivᵗ) in X. cbn in X. inversion X. Defined. +*) \ No newline at end of file diff --git a/translations/times_bool_fun2.v b/translations/times_bool_fun2.v index de2452d14..99454f3b5 100644 --- a/translations/times_bool_fun2.v +++ b/translations/times_bool_fun2.v @@ -79,6 +79,7 @@ Defined. Definition UA := forall A B, isequiv (id2equiv A B). +(* MetaRocq Run (TC <- Translate eqTC "isequiv" ;; TC <- Translate TC "equiv" ;; TC <- ImplementExisting TC "eq" ;; @@ -185,3 +186,4 @@ Definition αequiv_weakfunext : contr_isequivα -> weakFunext. 2: exact (equiv_contrfib _ (Hα A P H) idmap). exact (contr_retract_α A P H). Defined. +*) \ No newline at end of file From 261359a26c90bcc6ce03f190def373385ae5ff47 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 8 Nov 2025 00:03:56 +0100 Subject: [PATCH 142/164] Fix examples, deactivate typing_correctness for now, as the universe checker cannot run within Rocq yet --- examples/_RocqProject.in | 2 +- examples/metarocq_tour.v | 2 +- examples/metarocq_tour_prelude.v | 5 ++++- examples/tauto.v | 14 ++++++-------- safechecker/theories/PCUICSafeChecker.v | 2 +- 5 files changed, 13 insertions(+), 12 deletions(-) diff --git a/examples/_RocqProject.in b/examples/_RocqProject.in index 01e9e9edb..01d700b97 100644 --- a/examples/_RocqProject.in +++ b/examples/_RocqProject.in @@ -4,6 +4,6 @@ demo.v constructor_tac.v add_constructor.v tauto.v -typing_correctness.v +# typing_correctness.v metarocq_tour_prelude.v metarocq_tour.v \ No newline at end of file diff --git a/examples/metarocq_tour.v b/examples/metarocq_tour.v index 41a83187f..6f20cfc9a 100644 --- a/examples/metarocq_tour.v +++ b/examples/metarocq_tour.v @@ -77,7 +77,7 @@ Check type_of_subtype. (* Running the safe checker inside Rocq *) From MetaRocq.Examples Require Import metarocq_tour_prelude. -Check check_inh. +(* Check check_inh. *) (** We construct a proof of typing entirely within Rocq, calling the typechecker to produce the derivation *) (* Lemma identity_typing (u := Universe.make univ): diff --git a/examples/metarocq_tour_prelude.v b/examples/metarocq_tour_prelude.v index c30f6f0b3..d2dd042de 100644 --- a/examples/metarocq_tour_prelude.v +++ b/examples/metarocq_tour_prelude.v @@ -25,7 +25,8 @@ Definition univ := Level.level "s". (* TODO move to SafeChecker *) Definition gctx : global_env_ext := - ({| universes := (LS.union (LevelSet.singleton Level.lzero) (LevelSet.singleton univ), UnivConstraintSet.empty); + ({| universes := (LevelSet.singleton univ, + UnivConstraintSet.singleton (Universe.zero, UnivConstraintType.ConstraintType.Le, Universe.of_level univ)); declarations := []; retroknowledge := Retroknowledge.empty |}, Monomorphic_ctx). (** We use the environment checker to produce the proof that gctx, which is a singleton with only @@ -46,6 +47,7 @@ Definition make_wf_env_ext (Σ : global_env_ext) : EnvCheck wf_env_ext wf_env_ex '(exist Σ' pf) <- check_wf_ext optimized_abstract_env_impl Σ ;; ret Σ'. +(* Definition gctx_wf_env : wf_env_ext. Proof. let wf_proof := eval hnf in (make_wf_env_ext gctx) in @@ -80,3 +82,4 @@ Ltac fill_inh t := end | [ |- inh _ ?Γ _ ] => fail "Missing local wellformedness assumption for" Γ end. +*) \ No newline at end of file diff --git a/examples/tauto.v b/examples/tauto.v index a83230f4e..e0707cc47 100644 --- a/examples/tauto.v +++ b/examples/tauto.v @@ -835,8 +835,6 @@ Proof. repeat inst. lia. Qed. -Definition inspect {A} (x : A) : { y : A | y = x } := exist _ x eq_refl. - Definition tmLocateInd (q : qualid) : TemplateMonad kername := l <- tmLocate q ;; match l with @@ -901,28 +899,28 @@ Equations reify (Σ : global_env_ext) (Γ : context) (P : term) : option form } }. Next Obligation. - symmetry in e1. apply tsize_decompose_app in e1 as h1. + apply tsize_decompose_app in e1 as h1. simpl in h1. lia. Qed. Next Obligation. - symmetry in e1. apply tsize_decompose_app in e1 as h1. + apply tsize_decompose_app in e1 as h1. simpl in h1. pose proof (tsize_downlift_le B 0). lia. Qed. Next Obligation. - symmetry in e1. apply tsize_decompose_app in e1 as h1. + apply tsize_decompose_app in e1 as h1. simpl in h1. lia. Qed. Next Obligation. - symmetry in e1. apply tsize_decompose_app in e1 as h1. + apply tsize_decompose_app in e1 as h1. simpl in h1. lia. Qed. Next Obligation. - symmetry in e1. apply tsize_decompose_app in e1 as h1. + apply tsize_decompose_app in e1 as h1. simpl in h1. lia. Qed. Next Obligation. - symmetry in e1. apply tsize_decompose_app in e1 as h1. + apply tsize_decompose_app in e1 as h1. simpl in h1. lia. Qed. diff --git a/safechecker/theories/PCUICSafeChecker.v b/safechecker/theories/PCUICSafeChecker.v index fbf93a067..0ec974866 100644 --- a/safechecker/theories/PCUICSafeChecker.v +++ b/safechecker/theories/PCUICSafeChecker.v @@ -2336,7 +2336,7 @@ End monad_Alli_nth_forall. let id := "toplevel" in let levels := ContextSet.levels univs in check_eq_true_lazy (~~ (LevelSet.mem Level.lzero levels)) - (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("Level zero is not declared in the global levels " ^ print_lset levels))));; + (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("Level zero is declared in the global levels " ^ print_lset levels))));; check_eq_true_lazy (LevelSet.for_all (fun l => negb (Level.is_var l)) levels) (fun _ => (abstract_env_ext_empty, IllFormedDecl id (Msg ("Variable level in the global levels " ^ print_lset levels))));; check_eq_true_lazy (UnivConstraintSet.for_all (fun c => declared_universe (LevelSet.add Level.lzero levels) c.1.1 && declared_universe (LevelSet.add Level.lzero levels) c.2) (ContextSet.constraints univs)) From 5807e0af8dbcf3bfcf3ef47b707e4ea29298d89b Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 8 Nov 2025 08:03:17 +0100 Subject: [PATCH 143/164] WIP fixing quotation modules --- quotation/theories/ToPCUIC/Common/Universes.v | 19 +++++----------- quotation/theories/ToPCUIC/Init.v | 2 +- .../Common/EnvironmentTyping/Sig.v | 2 +- .../Universes/ConstraintSet/Instances.v | 4 ++-- .../ConstraintSetExtraDecide/Instances.v | 4 ++-- .../ConstraintSetExtraOrdProp/Instances.v | 8 +++---- .../ConstraintSetOrdProp/Instances.v | 22 +++++++++---------- .../QuotationOf/Common/Universes/Instances.v | 2 +- .../theories/ToTemplate/Common/Universes.v | 20 ++++------------- quotation/theories/ToTemplate/Init.v | 2 +- .../Common/EnvironmentTyping/Sig.v | 2 +- .../Universes/ConstraintSet/Instances.v | 4 ++-- .../ConstraintSetExtraDecide/Instances.v | 4 ++-- .../ConstraintSetExtraOrdProp/Instances.v | 8 +++---- .../ConstraintSetOrdProp/Instances.v | 22 +++++++++---------- .../QuotationOf/Common/Universes/Instances.v | 2 +- .../QuotationOf/Template/Ast/Env/Instances.v | 2 +- 17 files changed, 54 insertions(+), 75 deletions(-) diff --git a/quotation/theories/ToPCUIC/Common/Universes.v b/quotation/theories/ToPCUIC/Common/Universes.v index 418fcff0d..35308de7f 100644 --- a/quotation/theories/ToPCUIC/Common/Universes.v +++ b/quotation/theories/ToPCUIC/Common/Universes.v @@ -17,8 +17,8 @@ Module QuoteLevelSet := MSets.QuoteMSetAVL Level LevelSet LevelSetOrdProp LevelS Export (hints) QuoteLevelSet. Module QuoteLevelExprSet := MSets.QuoteMSetListWithLeibniz LevelExpr LevelExprSet LevelExprSetOrdProp LevelExprSetExtraOrdProp qLevelExpr qLevelExprSet qLevelExprSetOrdProp qLevelExprSetExtraOrdProp. Export (hints) QuoteLevelExprSet. -Module QuoteConstraintSet := MSets.QuoteMSetAVL UnivConstraint ConstraintSet ConstraintSetOrdProp ConstraintSetExtraOrdProp ConstraintSetExtraDecide qUnivConstraint qConstraintSet qConstraintSetOrdProp qConstraintSetExtraOrdProp qConstraintSetExtraDecide. -Export (hints) QuoteUnivConstraintSet. +Module QuoteConstraintSet := MSets.QuoteMSetAVL UnivConstraint UnivConstraintSet UnivConstraintSetOrdProp UnivConstraintSetExtraOrdProp UnivConstraintSetExtraDecide qUnivConstraint qConstraintSet qConstraintSetOrdProp qConstraintSetExtraOrdProp qConstraintSetExtraDecide. +Export (hints) QuoteConstraintSet. Module QuoteUniverses1. Module Import Level. @@ -58,7 +58,6 @@ End QuoteUniverses1. Export (hints) QuoteUniverses1. #[export] Hint Unfold - Universe.t Instance.t UContext.t AUContext.t @@ -68,7 +67,6 @@ Export (hints) QuoteUniverses1. : quotation. #[export] Typeclasses Transparent - Universe.t Instance.t UContext.t AUContext.t @@ -86,16 +84,9 @@ Module QuoteUniverses2. Export (hints) Universe. Module Import ConstraintType. - #[export] Instance quote_t_ : ground_quotable ConstraintType.t_ := ltac:(destruct 1; exact _). - #[export] Hint Unfold ConstraintType.t : quotation. - #[export] Typeclasses Transparent ConstraintType.t. - #[export] Instance quote_lt_ {x y} : ground_quotable (ConstraintType.lt_ x y). - Proof. - destruct x, y; - solve [ intro pf; exfalso; inversion pf - | adjust_ground_quotable_by_econstructor_inversion () ]. - Defined. - #[export] Hint Unfold ConstraintType.lt : quotation. + #[export] Instance quote_t_ : ground_quotable UnivConstraintType.ConstraintType.t_ := ltac:(destruct 1; exact _). + #[export] Hint Unfold UnivConstraintType.ConstraintType.t : quotation. + #[export] Typeclasses Transparent UnivConstraintType.ConstraintType.t. End ConstraintType. Export (hints) ConstraintType. diff --git a/quotation/theories/ToPCUIC/Init.v b/quotation/theories/ToPCUIC/Init.v index f332e7b36..6a53cd653 100644 --- a/quotation/theories/ToPCUIC/Init.v +++ b/quotation/theories/ToPCUIC/Init.v @@ -20,7 +20,7 @@ Import MRMonadNotation. Class quotation_of {T} (t : T) := quoted_term_of : PCUICAst.term. #[global] Arguments quoted_term_of {T} t {_}. Class ground_quotable T := quote_ground : forall t : T, quotation_of t. -Class inductive_quotation_of {T} (t : T) : Set +Class inductive_quotation_of {T} (t : T) := { qinductive : inductive ; qinst : Instance.t ; qquotation : quotation_of t := tInd qinductive qinst }. diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/EnvironmentTyping/Sig.v b/quotation/theories/ToPCUIC/QuotationOf/Common/EnvironmentTyping/Sig.v index b98ef2a15..a365564c5 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/EnvironmentTyping/Sig.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/EnvironmentTyping/Sig.v @@ -112,7 +112,7 @@ Module Type QuoteGlobalMapsSig (Import T: Term) (Import E: EnvironmentSig T) (Im #[export] Declare Instance quote_on_udecl {univs udecl} : ground_quotable (@on_udecl univs udecl). #[export] Declare Instance quote_satisfiable_udecl {univs ϕ} : ground_quotable (@satisfiable_udecl univs ϕ). - #[export] Declare Instance quote_valid_on_mono_udecl {univs ϕ} : ground_quotable (@valid_on_mono_udecl univs ϕ). + (* #[export] Declare Instance quote_valid_on_mono_udecl {univs ϕ} : ground_quotable (@valid_on_mono_udecl univs ϕ). *) #[export] Declare Instance quote_positive_cstr_arg {mdecl ctx t} : ground_quotable (@positive_cstr_arg mdecl ctx t). #[export] Declare Instance quote_positive_cstr {mdecl i ctx t} : ground_quotable (@positive_cstr mdecl i ctx t). diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSet/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSet/Instances.v index eef5f7f90..af747bf21 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSet/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSet/Instances.v @@ -3,5 +3,5 @@ From MetaRocq.Quotation.ToPCUIC Require Import Init. From MetaRocq.Quotation.ToPCUIC.QuotationOf.Stdlib.MSets Require Import MSetAVL.Sig. Module qConstraintSet <: MSetAVL.QuotationOfMake UnivConstraint UnivConstraintSet. - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSet"). -End qUnivConstraintSet. + MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSet"). +End qConstraintSet. diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v index b9ce4c2a0..15ef43804 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v @@ -2,6 +2,6 @@ From MetaRocq.Common Require Import Universes. From MetaRocq.Quotation.ToPCUIC Require Import Init. From MetaRocq.Quotation.ToPCUIC.QuotationOf.Utils Require Import MRMSets.Sig. -Module qConstraintSetExtraDecide <: MSetAVL.QuotationOfDecide UnivConstraintSet.E ConstraintSet ConstraintSetExtraDecide. - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetExtraDecide"). +Module qConstraintSetExtraDecide <: MSetAVL.QuotationOfDecide UnivConstraintSet.E UnivConstraintSet UnivConstraintSetExtraDecide. + MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetExtraDecide"). End qConstraintSetExtraDecide. diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v index 5e60770e2..2c2ebd0a0 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v @@ -4,9 +4,9 @@ From MetaRocq.Quotation.ToPCUIC.QuotationOf.Utils Require Import MRMSets.Sig. Import List.ListNotations. Local Open Scope list_scope. -Module qConstraintSetExtraOrdProp <: QuotationOfExtraOrdProperties ConstraintSet ConstraintSetOrdProp ConstraintSetExtraOrdProp. - Module qP <: QuotationOfWExtraPropertiesOn UnivConstraintSet.E ConstraintSet ConstraintSetOrdProp.P ConstraintSetExtraOrdProp.P. - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetExtraOrdProp.P"). +Module qConstraintSetExtraOrdProp <: QuotationOfExtraOrdProperties UnivConstraintSet UnivConstraintSetOrdProp UnivConstraintSetExtraOrdProp. + Module qP <: QuotationOfWExtraPropertiesOn UnivConstraintSet.E UnivConstraintSet UnivConstraintSetOrdProp.P UnivConstraintSetExtraOrdProp.P. + MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetExtraOrdProp.P"). End qP. - MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["P"]]%bs) None "ConstraintSetExtraOrdProp"). + MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["P"]]%bs) None "UnivConstraintSetExtraOrdProp"). End qConstraintSetExtraOrdProp. diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v index cd00e5c4b..dd5383c20 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v @@ -5,21 +5,21 @@ From MetaRocq.Quotation.ToPCUIC.QuotationOf.Stdlib.MSets Require Import MSetProp Import List.ListNotations. Local Open Scope list_scope. -Module qConstraintSetOrdProp <: QuotationOfOrdProperties ConstraintSet ConstraintSetOrdProp. - Module qME <: QuotationOfOrderedTypeFacts UnivConstraintSet.E ConstraintSetOrdProp.ME. - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetOrdProp.ME"). +Module qConstraintSetOrdProp <: QuotationOfOrdProperties UnivConstraintSet UnivConstraintSetOrdProp. + Module qME <: QuotationOfOrderedTypeFacts UnivConstraintSet.E UnivConstraintSetOrdProp.ME. + MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetOrdProp.ME"). End qME. Module qML. (* OrderedTypeLists(M.E). *) - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetOrdProp.ML"). + MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetOrdProp.ML"). End qML. - Module qP <: QuotationOfWProperties ConstraintSet ConstraintSetOrdProp.P. - Module qDec <: QuotationOfWDecideOn UnivConstraint ConstraintSet ConstraintSetOrdProp.P.Dec. - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetOrdProp.P.Dec"). + Module qP <: QuotationOfWProperties UnivConstraintSet UnivConstraintSetOrdProp.P. + Module qDec <: QuotationOfWDecideOn UnivConstraint UnivConstraintSet UnivConstraintSetOrdProp.P.Dec. + MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetOrdProp.P.Dec"). End qDec. - Module qFM <: QuotationOfWFactsOn UnivConstraint ConstraintSet ConstraintSetOrdProp.P.FM. - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetOrdProp.P.FM"). + Module qFM <: QuotationOfWFactsOn UnivConstraint UnivConstraintSet UnivConstraintSetOrdProp.P.FM. + MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetOrdProp.P.FM"). End qFM. - MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["Dec"]; ["FM"]]%bs) None "ConstraintSetOrdProp.P"). + MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["Dec"]; ["FM"]]%bs) None "UnivConstraintSetOrdProp.P"). End qP. - MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["ME"]; ["ML"]; ["P"]]%bs) None "ConstraintSetOrdProp"). + MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["ME"]; ["ML"]; ["P"]]%bs) None "UnivConstraintSetOrdProp"). End qConstraintSetOrdProp. diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/Instances.v index 89d08b540..ee6003a06 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/Instances.v @@ -10,7 +10,7 @@ From MetaRocq.Quotation.ToPCUIC.QuotationOf.Common.Universes Require Export LevelExprSetOrdProp.Instances LevelExprSetExtraOrdProp.Instances UnivConstraint.Instances - UnivConstraintSet.Instances + ConstraintSet.Instances ConstraintSetOrdProp.Instances ConstraintSetExtraOrdProp.Instances ConstraintSetExtraDecide.Instances diff --git a/quotation/theories/ToTemplate/Common/Universes.v b/quotation/theories/ToTemplate/Common/Universes.v index deff4ef80..e8872dc5b 100644 --- a/quotation/theories/ToTemplate/Common/Universes.v +++ b/quotation/theories/ToTemplate/Common/Universes.v @@ -17,7 +17,7 @@ Module QuoteLevelSet := MSets.QuoteMSetAVL Level LevelSet LevelSetOrdProp LevelS Export (hints) QuoteLevelSet. Module QuoteLevelExprSet := MSets.QuoteMSetListWithLeibniz LevelExpr LevelExprSet LevelExprSetOrdProp LevelExprSetExtraOrdProp qLevelExpr qLevelExprSet qLevelExprSetOrdProp qLevelExprSetExtraOrdProp. Export (hints) QuoteLevelExprSet. -Module QuoteConstraintSet := MSets.QuoteMSetAVL UnivConstraint ConstraintSet ConstraintSetOrdProp ConstraintSetExtraOrdProp ConstraintSetExtraDecide qUnivConstraint qConstraintSet qConstraintSetOrdProp qConstraintSetExtraOrdProp qConstraintSetExtraDecide. +Module QuoteConstraintSet := MSets.QuoteMSetAVL UnivConstraint UnivConstraintSet UnivConstraintSetOrdProp UnivConstraintSetExtraOrdProp UnivConstraintSetExtraDecide qUnivConstraint qConstraintSet qConstraintSetOrdProp qConstraintSetExtraOrdProp qConstraintSetExtraDecide. Export (hints) QuoteUnivConstraintSet. Module QuoteUniverses1. @@ -58,7 +58,6 @@ End QuoteUniverses1. Export (hints) QuoteUniverses1. #[export] Hint Unfold - Universe.t Instance.t UContext.t AUContext.t @@ -68,7 +67,6 @@ Export (hints) QuoteUniverses1. : quotation. #[export] Typeclasses Transparent - Universe.t Instance.t UContext.t AUContext.t @@ -86,25 +84,15 @@ Module QuoteUniverses2. Export (hints) Universe. Module Import ConstraintType. - #[export] Instance quote_t_ : ground_quotable ConstraintType.t_ := ltac:(destruct 1; exact _). - #[export] Hint Unfold ConstraintType.t : quotation. - #[export] Typeclasses Transparent ConstraintType.t. - #[export] Instance quote_lt_ {x y} : ground_quotable (ConstraintType.lt_ x y). - Proof. - destruct x, y; - solve [ intro pf; exfalso; inversion pf - | adjust_ground_quotable_by_econstructor_inversion () ]. - Defined. - #[export] Hint Unfold ConstraintType.lt : quotation. + #[export] Instance quote_t_ : ground_quotable UnivConstraintType.ConstraintType.t_ := ltac:(destruct 1; exact _). + #[export] Hint Unfold UnivConstraintType.ConstraintType.t : quotation. + #[export] Typeclasses Transparent UnivConstraintType.ConstraintType.t. End ConstraintType. Export (hints) ConstraintType. Module Import UnivConstraint. #[export] Hint Unfold UnivConstraint.t : quotation. #[export] Typeclasses Transparent UnivConstraint.t. - #[export] Instance quote_lt_ {x y} : ground_quotable (UnivConstraint.lt_ x y) - := ground_quotable_of_dec (@UnivConstraintSet.Raw.MX.lt_dec x y). - #[export] Hint Unfold UnivConstraint.lt : quotation. End UnivConstraint. Export (hints) UnivConstraint. diff --git a/quotation/theories/ToTemplate/Init.v b/quotation/theories/ToTemplate/Init.v index 2096b7473..ab039b338 100644 --- a/quotation/theories/ToTemplate/Init.v +++ b/quotation/theories/ToTemplate/Init.v @@ -16,7 +16,7 @@ Import MRMonadNotation. Class quotation_of {T} (t : T) := quoted_term_of : Ast.term. #[global] Arguments quoted_term_of {T} t {_}. Class ground_quotable T := quote_ground : forall t : T, quotation_of t. -Class inductive_quotation_of {T} (t : T) : Set +Class inductive_quotation_of {T} (t : T) := { qinductive : inductive ; qinst : Instance.t ; qquotation : quotation_of t := tInd qinductive qinst }. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/EnvironmentTyping/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Common/EnvironmentTyping/Sig.v index ece4da7f3..92b5a59d9 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/EnvironmentTyping/Sig.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/EnvironmentTyping/Sig.v @@ -112,7 +112,7 @@ Module Type QuoteGlobalMapsSig (Import T: Term) (Import E: EnvironmentSig T) (Im #[export] Declare Instance quote_on_udecl {univs udecl} : ground_quotable (@on_udecl univs udecl). #[export] Declare Instance quote_satisfiable_udecl {univs ϕ} : ground_quotable (@satisfiable_udecl univs ϕ). - #[export] Declare Instance quote_valid_on_mono_udecl {univs ϕ} : ground_quotable (@valid_on_mono_udecl univs ϕ). + (* #[export] Declare Instance quote_valid_on_mono_udecl {univs ϕ} : ground_quotable (@valid_on_mono_udecl univs ϕ). *) #[export] Declare Instance quote_positive_cstr_arg {mdecl ctx t} : ground_quotable (@positive_cstr_arg mdecl ctx t). #[export] Declare Instance quote_positive_cstr {mdecl i ctx t} : ground_quotable (@positive_cstr mdecl i ctx t). diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v index 96557073f..866d4f662 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v @@ -3,5 +3,5 @@ From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Stdlib.MSets Require Import MSetAVL.Sig. Module qConstraintSet <: MSetAVL.QuotationOfMake UnivConstraint UnivConstraintSet. - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSet"). -End qUnivConstraintSet. + MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSet"). +End qConstraintSet. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v index 140938120..6df03fa4f 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v @@ -2,6 +2,6 @@ From MetaRocq.Common Require Import Universes. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Utils Require Import MRMSets.Sig. -Module qConstraintSetExtraDecide <: MSetAVL.QuotationOfDecide UnivConstraintSet.E ConstraintSet ConstraintSetExtraDecide. - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetExtraDecide"). +Module qConstraintSetExtraDecide <: MSetAVL.QuotationOfDecide UnivConstraintSet.E UnivConstraintSet UnivConstraintSetExtraDecide. + MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetExtraDecide"). End qConstraintSetExtraDecide. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v index 35eecfe3f..52c4a6bf6 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v @@ -4,9 +4,9 @@ From MetaRocq.Quotation.ToTemplate.QuotationOf.Utils Require Import MRMSets.Sig. Import List.ListNotations. Local Open Scope list_scope. -Module qConstraintSetExtraOrdProp <: QuotationOfExtraOrdProperties ConstraintSet ConstraintSetOrdProp ConstraintSetExtraOrdProp. - Module qP <: QuotationOfWExtraPropertiesOn UnivConstraintSet.E ConstraintSet ConstraintSetOrdProp.P ConstraintSetExtraOrdProp.P. - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetExtraOrdProp.P"). +Module qConstraintSetExtraOrdProp <: QuotationOfExtraOrdProperties UnivConstraintSet UnivConstraintSetOrdProp UnivConstraintSetExtraOrdProp. + Module qP <: QuotationOfWExtraPropertiesOn UnivConstraintSet.E UnivConstraintSet UnivConstraintSetOrdProp.P UnivConstraintSetExtraOrdProp.P. + MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetExtraOrdProp.P"). End qP. - MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["P"]]%bs) None "ConstraintSetExtraOrdProp"). + MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["P"]]%bs) None "UnivConstraintSetExtraOrdProp"). End qConstraintSetExtraOrdProp. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v index d3412374d..72c228617 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v @@ -5,21 +5,21 @@ From MetaRocq.Quotation.ToTemplate.QuotationOf.Stdlib.MSets Require Import MSetP Import List.ListNotations. Local Open Scope list_scope. -Module qConstraintSetOrdProp <: QuotationOfOrdProperties ConstraintSet ConstraintSetOrdProp. - Module qME <: QuotationOfOrderedTypeFacts UnivConstraintSet.E ConstraintSetOrdProp.ME. - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetOrdProp.ME"). +Module qConstraintSetOrdProp <: QuotationOfOrdProperties UnivConstraintSet UnivConstraintSetOrdProp. + Module qME <: QuotationOfOrderedTypeFacts UnivConstraintSet.E UnivConstraintSetOrdProp.ME. + MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetOrdProp.ME"). End qME. Module qML. (* OrderedTypeLists(M.E). *) - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetOrdProp.ML"). + MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetOrdProp.ML"). End qML. - Module qP <: QuotationOfWProperties ConstraintSet ConstraintSetOrdProp.P. - Module qDec <: QuotationOfWDecideOn UnivConstraint ConstraintSet ConstraintSetOrdProp.P.Dec. - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetOrdProp.P.Dec"). + Module qP <: QuotationOfWProperties UnivConstraintSet UnivConstraintSetOrdProp.P. + Module qDec <: QuotationOfWDecideOn UnivConstraint UnivConstraintSet UnivConstraintSetOrdProp.P.Dec. + MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetOrdProp.P.Dec"). End qDec. - Module qFM <: QuotationOfWFactsOn UnivConstraint ConstraintSet ConstraintSetOrdProp.P.FM. - MetaRocq Run (tmMakeQuotationOfModule everything None "ConstraintSetOrdProp.P.FM"). + Module qFM <: QuotationOfWFactsOn UnivConstraint UnivConstraintSet UnivConstraintSetOrdProp.P.FM. + MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetOrdProp.P.FM"). End qFM. - MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["Dec"]; ["FM"]]%bs) None "ConstraintSetOrdProp.P"). + MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["Dec"]; ["FM"]]%bs) None "UnivConstraintSetOrdProp.P"). End qP. - MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["ME"]; ["ML"]; ["P"]]%bs) None "ConstraintSetOrdProp"). + MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["ME"]; ["ML"]; ["P"]]%bs) None "UnivConstraintSetOrdProp"). End qConstraintSetOrdProp. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/Instances.v index 53e1d603b..15151968c 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/Instances.v @@ -10,7 +10,7 @@ From MetaRocq.Quotation.ToTemplate.QuotationOf.Common.Universes Require Export LevelExprSetOrdProp.Instances LevelExprSetExtraOrdProp.Instances UnivConstraint.Instances - UnivConstraintSet.Instances + ConstraintSet.Instances ConstraintSetOrdProp.Instances ConstraintSetExtraOrdProp.Instances ConstraintSetExtraDecide.Instances diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/Env/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/Env/Instances.v index 903230f29..08b7ca9de 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/Env/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/Env/Instances.v @@ -1,7 +1,7 @@ From MetaRocq.Template Require Import Ast. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Common Require Import Environment.Sig. - +About Env. Module qEnv <: QuotationOfEnvironment TemplateTerm Env. MetaRocq Run (tmMakeQuotationOfModule everything None "Env"). End qEnv. From 3a6ecb48ad95f991aadb0c30725ac6d2f5358537 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 8 Nov 2025 08:04:39 +0100 Subject: [PATCH 144/164] Deactivate quotation module for now --- rocq-metarocq.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/rocq-metarocq.opam b/rocq-metarocq.opam index 8bdfd96fd..fced5ede7 100644 --- a/rocq-metarocq.opam +++ b/rocq-metarocq.opam @@ -24,7 +24,7 @@ depends: [ "rocq-metarocq-safechecker-plugin" {= version} "rocq-metarocq-erasure-plugin" {= version} "rocq-metarocq-translations" {= version} - "rocq-metarocq-quotation" {= version} +# "rocq-metarocq-quotation" {= version} ] build: [ ["bash" "./configure.sh" ] {with-test} From a9875f7a25c694e94823abe0de01845101ba5772 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 8 Nov 2025 08:05:30 +0100 Subject: [PATCH 145/164] Deactivate building quotation submodule for now in NIX --- .nix/rocq-overlays/metarocq/default.nix | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.nix/rocq-overlays/metarocq/default.nix b/.nix/rocq-overlays/metarocq/default.nix index 5c0ba0ef1..b49cf7f9c 100644 --- a/.nix/rocq-overlays/metarocq/default.nix +++ b/.nix/rocq-overlays/metarocq/default.nix @@ -34,11 +34,11 @@ let "safechecker" "template-pcuic" ]; - "quotation" = [ - "template-rocq" - "pcuic" - "template-pcuic" - ]; + # "quotation" = [ + # "template-rocq" + # "pcuic" + # "template-pcuic" + # ]; "safechecker-plugin" = [ "template-pcuic" "safechecker" @@ -52,7 +52,7 @@ let "safechecker-plugin" "erasure-plugin" "translations" - "quotation" + # "quotation" ]; }; @@ -111,7 +111,7 @@ let (lib.elem package [ "erasure" "template-pcuic" - "quotation" + # "quotation" "safechecker-plugin" "erasure-plugin" "translations" From 7a08631cf82a40d8dc5a738443cd7e4b739fab6f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 8 Nov 2025 09:04:22 +0100 Subject: [PATCH 146/164] Fix test-suite --- .../theories/SafeTemplateChecker.v | 29 ++++++++++++------- test-suite/castprop.v | 2 +- test-suite/erasure_test.v | 4 +-- test-suite/reduction_test.v | 16 +++++----- test-suite/tmFix.v | 16 +++++----- test-suite/univ.v | 2 +- 6 files changed, 39 insertions(+), 30 deletions(-) diff --git a/safechecker-plugin/theories/SafeTemplateChecker.v b/safechecker-plugin/theories/SafeTemplateChecker.v index 9f78e5109..a02f62033 100644 --- a/safechecker-plugin/theories/SafeTemplateChecker.v +++ b/safechecker-plugin/theories/SafeTemplateChecker.v @@ -19,6 +19,15 @@ Definition EnvCheck_wf_env_ext {cf:checker_flags} {guard : abstract_guard_impl} Local Instance Monad_EnvCheck_wf_env_ext {cf:checker_flags} {guard : abstract_guard_impl} : Monad EnvCheck_wf_env_ext := _. +Definition clean_global_env (p : Ast.Env.global_env) : Ast.Env.global_env := + {| Ast.Env.universes := PCUICGlobalEnv.clean_uctx p.(Ast.Env.universes); + Ast.Env.retroknowledge := p.(Ast.Env.retroknowledge); + Ast.Env.declarations := p.(Ast.Env.declarations) + |}. + +Definition clean_program (p : Ast.Env.program) : Ast.Env.program := + (clean_global_env p.1, p.2). + Program Definition infer_template_program {cf : checker_flags} {nor : normalizing_flags} {guard : abstract_guard_impl} (p : Ast.Env.program) φ (* this is the hypothesis we need, idk how to simplify it or appropriately generalize it, maybe use check_wf_env_ext_prop to simplify Σ0 ∼_ext X' into _ ∼ X so that we get an equality? *) @@ -28,20 +37,20 @@ Program Definition infer_template_program {cf : checker_flags} {nor : normalizin Σ0 ∼ X -> Σ0 = {| - universes := (trans_program p).1; - declarations := skipn Hdecls' (declarations (trans_program p).1); - retroknowledge := retroknowledge (trans_program p).1 + universes := (trans_program (clean_program p)).1; + declarations := skipn Hdecls' (declarations (trans_program (clean_program p)).1); + retroknowledge := retroknowledge (trans_program (clean_program p)).1 |}) -> forall X' : X_env_ext_type optimized_abstract_env_impl, check_wf_env_ext_prop optimized_abstract_env_impl X X' (universes_decl_of_decl g) -> forall Σ0 : global_env_ext, wf_ext Σ0 -> Σ0 ∼_ext X' -> NormalizationIn Σ0} {normalization_in' : forall x : X_env_ext_type optimized_abstract_env_impl, - ((trans_program p).1, φ) ∼_ext x -> + ((trans_program (clean_program p)).1, φ) ∼_ext x -> forall Σ : global_env_ext, wf_ext Σ -> Σ ∼_ext x -> NormalizationIn Σ} - : EnvCheck_wf_env_ext (let p' := trans_program p in ∑ A, { X : wf_env_ext | + : EnvCheck_wf_env_ext (let p' := trans_program (clean_program p) in ∑ A, { X : wf_env_ext | ∥ (p'.1, φ) = X.(wf_env_ext_reference).(reference_impl_env_ext) × wf_ext (p'.1, φ) × (p'.1, φ) ;;; [] |- p'.2 : A ∥ }) := - pp <- typecheck_program (cf := cf) (nor:=nor) optimized_abstract_env_impl (trans_program p) φ ;; + pp <- typecheck_program (cf := cf) (nor:=nor) optimized_abstract_env_impl (trans_program (clean_program p)) φ ;; ret (pp.π1 ; (exist (proj1_sig pp.π2) _)). Next Obligation. sq. destruct H; split; eauto. destruct p0; split; eauto. eapply infering_typing; tea. eapply w. constructor. @@ -56,16 +65,16 @@ Program Definition infer_and_print_template_program {cf : checker_flags} {nor : Σ0 ∼ X -> Σ0 = {| - universes := (trans_program p).1; - declarations := skipn Hdecls' (declarations (trans_program p).1); - retroknowledge := retroknowledge (trans_program p).1 + universes := (trans_program (clean_program p)).1; + declarations := skipn Hdecls' (declarations (trans_program (clean_program p)).1); + retroknowledge := retroknowledge (trans_program (clean_program p)).1 |}) -> forall X' : X_env_ext_type optimized_abstract_env_impl, check_wf_env_ext_prop optimized_abstract_env_impl X X' (universes_decl_of_decl g) -> forall Σ0 : global_env_ext, wf_ext Σ0 -> Σ0 ∼_ext X' -> NormalizationIn Σ0} {normalization_in' : forall x : X_env_ext_type optimized_abstract_env_impl, - ((trans_program p).1, φ) ∼_ext x -> + ((trans_program (clean_program p)).1, φ) ∼_ext x -> forall Σ : global_env_ext, wf_ext Σ -> Σ ∼_ext x -> NormalizationIn Σ} : string + string := match infer_template_program (cf:=cf) p φ return string + string with | CorrectDecl t => diff --git a/test-suite/castprop.v b/test-suite/castprop.v index 3b2425c1a..5339efff8 100644 --- a/test-suite/castprop.v +++ b/test-suite/castprop.v @@ -14,7 +14,7 @@ Definition f (x : nat) (p : True) (y : nat) := y. Definition fapp (x : nat) := f 0 I x. MetaRocq Quote Recursively Definition q_fapp := @fapp. -Definition setprop : { x : nat | x = 0 } := exist _ 0 eq_refl. +Definition setprop : { x : nat | x = 0 } := exist 0 eq_refl. MetaRocq Quote Recursively Definition q_setprop := setprop. Notation proof t := diff --git a/test-suite/erasure_test.v b/test-suite/erasure_test.v index 1c0e5cdba..7ccaad0d6 100644 --- a/test-suite/erasure_test.v +++ b/test-suite/erasure_test.v @@ -19,9 +19,9 @@ Environment is well-formed and Construct(Stdlib.Init.Datatypes.bool,0,0,[]) eras Construct(Stdlib.Init.Datatypes.bool,0,0) *) -MetaRocq Erase (exist (fun x => x = 0) 0 (eq_refl)). +MetaRocq Erase (@exist _ (fun x => x = 0) 0 (eq_refl)). -Definition test := (proj1_sig (exist (fun x => x = 0) 0 (eq_refl))). +Definition test := (proj1_sig (@exist _ (fun x => x = 0) 0 (eq_refl))). MetaRocq Erase -typed test. diff --git a/test-suite/reduction_test.v b/test-suite/reduction_test.v index 31cf03d60..74d7bbfa6 100644 --- a/test-suite/reduction_test.v +++ b/test-suite/reduction_test.v @@ -67,19 +67,19 @@ MetaRocq Quote Recursively Definition foo := Definition default_normal : @normalizing_flags default_checker_flags. now econstructor. Defined. +Unset MetaRocq Strict Unquote Universe Mode. -Time Definition bar := Eval lazy in @typecheck_template default_normal foo. +(* Time Definition bar := Eval lazy in @typecheck_template default_normal foo. *) -Unset MetaRocq Strict Unquote Universe Mode. -MetaRocq Unquote Definition unbar := (PCUICToTemplate.trans bar). +(* MetaRocq Unquote Definition unbar := (PCUICToTemplate.trans bar). *) Program Definition eval_compute (cf := default_checker_flags) (nor : normalizing_flags) (p : Ast.Env.program) φ : Ast.term + string := match infer_template_program (cf:=cf) p φ return Ast.term + string with | CorrectDecl A => - let p' := trans_program p in - let Σ' := TemplateToPCUIC.trans_global_env p.1 in + let p' := trans_program (clean_program p) in + let Σ' := TemplateToPCUIC.trans_global_env (clean_program p).1 in let redtm := reduce_term RedFlags.default optimized_abstract_env_impl (proj1_sig A.π2) [] p'.2 _ in @@ -97,7 +97,7 @@ Qed. Program Definition eval_compute_cheat (cf := default_checker_flags) (nor : normalizing_flags) (p : Ast.Env.program) φ : Ast.term -:= let p' := trans_program p in +:= let p' := trans_program (clean_program p) in let tm := reduce_term RedFlags.default canonical_abstract_env_impl {| reference_impl_env_ext := (p'.1 , φ); @@ -105,6 +105,6 @@ Program Definition eval_compute_cheat (cf := default_checker_flags) [] p'.2 (todo "welltyped") in PCUICToTemplate.trans tm. -Time Definition bar'' := Eval lazy in eval_compute default_normal foo Monomorphic_ctx. +Time Definition bar'' := Eval lazy in eval_compute_cheat default_normal foo Monomorphic_ctx. -MetaRocq Unquote Definition bar''' := (match bar'' with inl x => x | inr _ => todo "" end). +MetaRocq Unquote Definition bar''' := bar''. diff --git a/test-suite/tmFix.v b/test-suite/tmFix.v index 1cdd179c5..7935805b6 100644 --- a/test-suite/tmFix.v +++ b/test-suite/tmFix.v @@ -112,10 +112,10 @@ Module Unquote. := f (fun a => (bind@{t u} (tmQuote@{t u} A) (fun qA => bind@{t u} (tmQuote@{t u} B) (fun qB => - bind@{t u} tmQuoteLevel@{a t u} (fun qa => - bind@{t u} tmQuoteLevel@{b t u} (fun qb => - bind@{t u} tmQuoteLevel@{t t u} (fun qt => - bind@{t u} tmQuoteLevel@{u t u} (fun qu => + bind@{t u} tmQuoteUniverse@{a t u} (fun qa => + bind@{t u} tmQuoteUniverse@{b t u} (fun qb => + bind@{t u} tmQuoteUniverse@{t t u} (fun qt => + bind@{t u} tmQuoteUniverse@{u t u} (fun qu => let self := tConst (self, "tmFix'"%bs) [qa;qb;qt;qu] in @tmFix'@{a b t u} A B (mkApps self [qA; qB]) f a)))))))). (* reference that uses the constant in Core, for equality comparison *) @@ -123,10 +123,10 @@ Module Unquote. := f (fun a => bind@{t u} (tmQuote@{t u} A) (fun qA => bind@{t u} (tmQuote@{t u} B) (fun qB => - bind@{t u} tmQuoteLevel@{a t u} (fun qa => - bind@{t u} tmQuoteLevel@{b t u} (fun qb => - bind@{t u} tmQuoteLevel@{t t u} (fun qt => - bind@{t u} tmQuoteLevel@{u t u} (fun qu => + bind@{t u} tmQuoteUniverse@{a t u} (fun qa => + bind@{t u} tmQuoteUniverse@{b t u} (fun qb => + bind@{t u} tmQuoteUniverse@{t t u} (fun qt => + bind@{t u} tmQuoteUniverse@{u t u} (fun qu => let self := tConst (MPfile ["Core"; "TemplateMonad"; "Template"; "MetaRocq"], "tmFix'")%bs [qa;qb;qt;qu] in @tmFix'@{a b t u} A B (mkApps self [qA; qB]) f a))))))). Definition six := tmFix (fun f a => if (6 Date: Sat, 8 Nov 2025 09:05:14 +0100 Subject: [PATCH 147/164] Remove generated file --- .gitignore | 1 + template-rocq/src/g_template_rocq.ml | 360 --------------------------- 2 files changed, 1 insertion(+), 360 deletions(-) delete mode 100644 template-rocq/src/g_template_rocq.ml diff --git a/.gitignore b/.gitignore index 2ede99286..56b714768 100644 --- a/.gitignore +++ b/.gitignore @@ -301,6 +301,7 @@ test-suite/plugin-demo/Makefile.plugin template-rocq/Makefile.plugin-e template-rocq/Makefile.template-e template-rocq/src/g_template_coq.ml +template-rocq/src/g_template_rocq.ml pcuic/Makefile.plugin-e erasure/Makefile.plugin-e safechecker/Makefile.plugin-e diff --git a/template-rocq/src/g_template_rocq.ml b/template-rocq/src/g_template_rocq.ml deleted file mode 100644 index a9187abbd..000000000 --- a/template-rocq/src/g_template_rocq.ml +++ /dev/null @@ -1,360 +0,0 @@ -let _ = Mltop.add_known_module "rocq-metarocq-template-rocq.plugin" - -# 4 "src/g_template_rocq.mlg" - - -open Attributes -open Ltac_plugin -open Names - -(** Calling Ltac **) - -let ltac_lcall tac args = - let (location, name) = Loc.tag (Names.Id.of_string tac) - (* Loc.tag @@ Names.Id.of_string tac *) - in - CAst.make ?loc:location (Tacexpr.TacArg(Tacexpr.TacCall - (CAst.make (Locus.ArgVar (CAst.make ?loc:location name),args)))) - -open Tacexpr -open Tacinterp -open Stdarg -open Tacarg -open Redexpr - -(* If strict unquote universe mode is on then fail when unquoting a non *) -(* declared universe / an empty list of level expressions. *) -(* Otherwise, add it / a fresh level the global environnment. *) - -let _ = - let open Goptions in - declare_bool_option - { optdepr = None; - optstage = Interp; - optkey = ["MetaRocq"; "Strict"; "Unquote"; "Universe"; "Mode"]; - optread = (fun () -> !Denoter.strict_unquote_universe_mode); - optwrite = (fun b -> Denoter.strict_unquote_universe_mode := b) } - -let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) = - let fold arg (i, vars, lfun) = - let id = Names.Id.of_string ("x" ^ string_of_int i) in - let (l,n) = (Loc.tag id) in - let x = Reference (Locus.ArgVar (CAst.make ?loc:l n)) in - (succ i, x :: vars, Id.Map.add id arg lfun) - in - let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in - let lfun = Id.Map.add (Id.of_string "F") f lfun in - let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in - Tacinterp.eval_tactic_ist ist (ltac_lcall "F" args) - -let to_ltac_val c = Tacinterp.Value.of_constr c - -let run_template_program ~pm env evm ~poly pgm = - Run_template_monad.run_template_program_rec ~poly (fun ~st _ _ _ -> st) ~st:pm env (evm, pgm) - -let fresh_env () = - let env = Global.env () in - let sigma = Evd.from_env env in - env, sigma - -let to_constr_evars sigma c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c - - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Test_Quote" ~classifier:(fun _ -> Vernacextend.classify_as_query) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Test", - Vernacextend.TyTerminal - ("Quote", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))), - (let coqpp_body def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 67 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmTestQuote) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, - [|Constr.mkRel 0; to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun def ?loc ~atts () -> - coqpp_body def (Attributes.parse -# 66 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Quote", - Vernacextend.TyTerminal - ("Definition", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), - Vernacextend.TyTerminal - (":=", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))))), - (let coqpp_body name def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 77 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteDefinition) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; - to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun name def ?loc ~atts () -> - coqpp_body name def (Attributes.parse -# 76 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Definition_Eval" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Quote", - Vernacextend.TyTerminal - ("Definition", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), - Vernacextend.TyTerminal - (":=", - Vernacextend.TyTerminal - ("Eval", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_red_expr), - Vernacextend.TyTerminal - ("in", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil))))))))), - (let coqpp_body name rd def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 87 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - (* TODO : implem quoting of tactic reductions so that we can use ptmQuoteDefinitionRed *) - let (evm, rd) = Redexpr.interp_redexp_no_ltac env evm rd in - let (evm, def) = Plugin_core.reduce env evm rd (to_constr_evars evm def) in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteDefinition) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun name rd def ?loc ~atts () -> - coqpp_body name rd def (Attributes.parse -# 86 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Quote_Recursively_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Quote", - Vernacextend.TyTerminal - ("Recursively", - Vernacextend.TyTerminal - ("Definition", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), - Vernacextend.TyTerminal - (":=", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil))))))), - (let coqpp_body name def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 99 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmQuoteRecDefinition) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, [|Constr_quoter.quote_ident name; Constr.mkRel 0; - to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun name def ?loc ~atts () -> - coqpp_body name def (Attributes.parse -# 98 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Test_Unquote" ~classifier:(fun _ -> Vernacextend.classify_as_query) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Test", - Vernacextend.TyTerminal - ("Unquote", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))), - (let coqpp_body def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 109 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmTestUnquote) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, - [|to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun def ?loc ~atts () -> - coqpp_body def (Attributes.parse -# 108 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Make_Definition" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Unquote", - Vernacextend.TyTerminal - ("Definition", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_ident), - Vernacextend.TyTerminal - (":=", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))))), - (let coqpp_body name def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 119 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmMkDefinition) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, - [|Constr_quoter.quote_ident name; - to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun name def ?loc ~atts () -> - coqpp_body name def (Attributes.parse -# 118 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Make_Inductive" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Unquote", - Vernacextend.TyTerminal - ("Inductive", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil)))), - (let coqpp_body def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 130 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (evm, def) = Constrintern.interp_open_constr env evm def in - let (evm, pgm) = EConstr.fresh_global env evm (Lazy.force Template_monad.ptmMkInductive) in - let pgm = Constr.mkApp (EConstr.to_constr evm pgm, - [|Constr_quoter.quote_bool false; to_constr_evars evm def|]) in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun def ?loc ~atts () -> - coqpp_body def (Attributes.parse -# 129 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Vernacextend.static_vernac_extend ~plugin:(Some "rocq-metarocq-template-rocq.plugin") ~command:"TemplateRocq_Run_Template_Program" ~classifier:(fun _ -> Vernacextend.classify_as_sideeff) ?entry:None - [(Vernacextend.TyML - (false, - Vernacextend.TyTerminal - ("MetaRocq", - Vernacextend.TyTerminal - ("Run", - Vernacextend.TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Vernacextend.TyNil))), - (let coqpp_body def poly = - Vernactypes.vtmodifyprogram (fun ~pm -> ( -# 140 "src/g_template_rocq.mlg" - fun ~pm -> let (env, evm) = fresh_env () in - let (pgm, ctx) = Constrintern.interp_constr env evm def in - let evm = Evd.from_ctx ctx in - let pgm = EConstr.to_constr ~abort_on_undefined_evars:true evm pgm in - run_template_program ~pm env evm ~poly pgm - ) ~pm) in fun def ?loc ~atts () -> - coqpp_body def (Attributes.parse -# 139 "src/g_template_rocq.mlg" - polymorphic - atts)), - None))] - -let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_quote_term" ~level:0 - [(Tacentries.TyML (Tacentries.TyIdent ("quote_term", Tacentries.TyArg ( - Extend.TUentry (Genarg.get_arg_tag wit_constr), - Tacentries.TyArg ( - Extend.TUentry (Genarg.get_arg_tag wit_tactic), - Tacentries.TyNil))), - (fun c tac ist -> -# 152 "src/g_template_rocq.mlg" - (* quote the given term, pass the result to t *) - Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let c = to_constr_evars sigma c in - let c = Constr_quoter.quote_term env sigma c in - ltac_apply tac (List.map to_ltac_val [EConstr.of_constr c]) - end - )))] - -let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_denote_term" ~level:0 - [(Tacentries.TyML (Tacentries.TyIdent ("denote_term", Tacentries.TyArg ( - Extend.TUentry (Genarg.get_arg_tag wit_constr), - Tacentries.TyArg ( - Extend.TUentry (Genarg.get_arg_tag wit_tactic), - Tacentries.TyNil))), - (fun c tac ist -> -# 164 "src/g_template_rocq.mlg" - Proofview.Goal.enter (begin fun gl -> - let env = Proofview.Goal.env gl in - let evm = Proofview.Goal.sigma gl in - let evm, c = Constr_denoter.denote_term env evm (to_constr_evars evm c) in - let evm, _ = Typing.type_of env evm (EConstr.of_constr c) in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) - (ltac_apply tac (List.map to_ltac_val [EConstr.of_constr c])) - end) - )))] - -let () = Tacentries.tactic_extend "rocq-metarocq-template-rocq.plugin" "TemplateRocq_run_template_program" ~level:0 - [(Tacentries.TyML (Tacentries.TyIdent ("run_template_program", - Tacentries.TyArg (Extend.TUentry (Genarg.get_arg_tag wit_constr), - Tacentries.TyArg (Extend.TUentry (Genarg.get_arg_tag wit_tactic), - Tacentries.TyNil))), (fun c tac ist -> -# 176 "src/g_template_rocq.mlg" - let open Proofview.Notations in - Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (name, poly) -> - Proofview.Goal.enter (begin fun gl -> - let env = Proofview.Goal.env gl in - let evm = Proofview.Goal.sigma gl in - let ret = ref None in - (* We don't allow opening obligations / updating the vernacular inside proofs / as tactics *) - let pm = Declare.OblState.empty in - let _pm = Run_template_monad.run_template_program_rec - ~poly ~intactic:true ~st:pm (fun ~st env evm t -> ret := Some (env,evm,t); st) - env (evm, to_constr_evars evm c) - in - match !ret with - | Some (env, evm, t) -> - Proofview.tclTHEN - (Proofview.Unsafe.tclEVARS evm) - (ltac_apply tac (List.map to_ltac_val [EConstr.of_constr t])) - | None -> Proofview.tclUNIT () - end) - )))] - From 4f81efcbbcdcc84c621358b2e10a3c74f35b04b0 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 8 Nov 2025 09:46:46 +0100 Subject: [PATCH 148/164] Fix opam ci to not include quotation submodule --- Makefile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 0da598896..da9b89a6d 100644 --- a/Makefile +++ b/Makefile @@ -206,7 +206,8 @@ ci-quick: ci-opam: # Use -v so that regular output is produced - opam install --with-test -v -y . + opam pin add . + opam install --with-test -v -y rocq-metarocq opam remove -y rocq-metarocq rocq-metarocq-template checktodos: From 9570f589d6a2da17d0b1a71a5bb69fe96232e802 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 8 Nov 2025 11:12:02 +0100 Subject: [PATCH 149/164] Fix ci-opam target --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index da9b89a6d..93708c22f 100644 --- a/Makefile +++ b/Makefile @@ -206,7 +206,7 @@ ci-quick: ci-opam: # Use -v so that regular output is produced - opam pin add . + opam pin add -y . opam install --with-test -v -y rocq-metarocq opam remove -y rocq-metarocq rocq-metarocq-template From ffc4ced996635e66db7939568cef8a5d8984fa0f Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 8 Nov 2025 12:28:01 +0100 Subject: [PATCH 150/164] Force not testing the quotation package --- Makefile | 1 + rocq-metarocq-utils.opam | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 93708c22f..ecbc42112 100644 --- a/Makefile +++ b/Makefile @@ -206,6 +206,7 @@ ci-quick: ci-opam: # Use -v so that regular output is produced + rm -f rocq-metarocq-quotation.opam opam pin add -y . opam install --with-test -v -y rocq-metarocq opam remove -y rocq-metarocq rocq-metarocq-template diff --git a/rocq-metarocq-utils.opam b/rocq-metarocq-utils.opam index 6a943a199..b36a0e721 100644 --- a/rocq-metarocq-utils.opam +++ b/rocq-metarocq-utils.opam @@ -29,7 +29,7 @@ install: [ ] depends: [ "stdlib-shims" - "rocq-prover" { >= "9.0~" & != "9.0.dev" & < "10" } + "rocq-prover" { >= "9.0~" & != "9.0.dev" & < "9.1" } "coq-equations" { = "1.3.1+9.0" } ] synopsis: "The utility library of Template Rocq and PCUIC" From a616a6b44703795e4806256cd3ed0841f672c707 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 15 Nov 2025 15:33:59 +0100 Subject: [PATCH 151/164] Generates a segfault in ugraph --- common/theories/uGraph.v | 69 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 69 insertions(+) diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index 38341f87f..e02a58e07 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -76,6 +76,75 @@ Qed. End Push. +Definition levels_of_list (l : list Level.t) : LevelSet.t := + List.fold_right LevelSet.add LevelSet.empty l. + +Definition constraints_of_list (l : list UnivConstraint.t) : UnivConstraintSet.t := + List.fold_right UnivConstraintSet.add UnivConstraintSet.empty l. + +Import MRMonadNotation. + +Declare Scope cstr_scope. +Delimit Scope cstr_scope with cstr. +Bind Scope cstr_scope with UnivConstraint.t. +Notation " x <= y " := (@pair (Universe.t * UnivConstraintType.ConstraintType.t) Universe.t + (@pair Universe.t _ x Le) y) : cstr_scope. + +Definition of_level (l : Level.t_) : Universe.t := Universe.of_level l. +Coercion of_level : Level.t_ >-> Universe.t. +Coercion Universe.of_level : Level.t >-> Universe.t. + +Definition test_model : bool := + let la := Level.level "a" in + let lb := Level.level "b" in + let ls := levels_of_list [la; lb] in + let cs := constraints_of_list [(la <= lb)%cstr] in + match push_uctx init_model (ls, cs) with + | Some m => true + | None => false + end. + +Lemma test_model_spec : test_model = true. +Proof. + rewrite /test_model. + set ls := levels_of_list _. + set cs := constraints_of_list _. + rewrite /push_uctx /push_uctx_clause_1. + set m := UnivLoopChecking.declare_levels init_model ls. + rewrite /enforce_constraints /enforce_constraints_aux. + cbn -[enforce]. + set m' := {| model := _ |}. + unfold enforce. + set ef := LoopCheck.enforce m' _. + cbn -[LoopCheck.enforce] in ef. + unfold to_atoms in ef. + cbn -[LoopCheck.enforce] in ef. + unfold LoopCheck.enforce in ef. + unfold LoopCheck.Impl.Abstract.enforce_clauses in ef. + hnf in ef. + unfold LoopCheck.Impl.CorrectModel.infer_extension_correct in ef. + unfold LoopCheck.Impl.CorrectModel.infer_extension_correct_clause_1 in ef. + unfold LoopCheck.Impl.infer_extension in ef. + unfold LoopCheck.Impl.infer_model_extension in ef. + hnf in ef. + set (l := LoopCheck.Impl.I.loop _ _ _ _ _ _) in *. + match goal with + | [ l := LoopCheck.Impl.I.loop _ _ _ _ _ ?pre |- _ ] => + set (precond := pre) in * + end. + clearbody precond. + + + lazy in ef. + unfold LoopCheck.Impl.I.loop in ef. + hnf in ef. + set () + unfold FixWf in ef. + + hnf in ef. + Eval compute in test_model. + + Import UnivLoopChecking. (** ** Check of consistency ** *) From dcd1e32fc024706782e632b85284806325c25008 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 15 Nov 2025 18:34:11 +0100 Subject: [PATCH 152/164] Fix computation inside Rocq for enforce/check --- common/theories/LoopChecking/Deciders.v | 130 ++++++++++-------- .../LoopChecking/PartialLoopChecking.v | 2 +- common/theories/uGraph.v | 60 +++----- 3 files changed, 93 insertions(+), 99 deletions(-) diff --git a/common/theories/LoopChecking/Deciders.v b/common/theories/LoopChecking/Deciders.v index b7e029b87..a6b511d31 100644 --- a/common/theories/LoopChecking/Deciders.v +++ b/common/theories/LoopChecking/Deciders.v @@ -1045,7 +1045,8 @@ Module CorrectModel. init_model := {| initial_model := LevelMap.add Level.zero (Some 1) (LevelMap.empty _); only_model_of_V := _; - model_updates := LevelSet.empty; |}. + model_updates := LevelSet.empty; + model_valid := {| model_model := LevelMap.add Level.zero (Some 1) (LevelMap.empty _) |} |}. Proof. - exists 0%nat. rsets. left; auto. - exists 1%nat. rsets. @@ -1055,12 +1056,11 @@ Module CorrectModel. * intros ->. exists (Some 1). rsets. now left. * move=> [] k'. rsets. destruct p; intuition auto. - lsets. - - refine {| model_model := LevelMap.add Level.zero (Some 1) (LevelMap.empty _) |}. - * red. rsets. exists (Some 1). rsets; firstorder. - * red. now rsets. - * now rsets. - * rewrite /is_model. eapply Clauses.for_all_spec. tc. now rsets. + - red. rsets. exists (Some 1). rsets; firstorder. + - red. now rsets. + - cbn in H. lsets. Qed. + Record loop {cls} := { loop_univ : premises; loop_incl : NES.levels loop_univ ⊂_lset clauses_levels cls; @@ -1547,14 +1547,66 @@ Module Abstract. intros ?; rewrite clause_levels_spec; rsets; cbn; rsets; cbn. firstorder. Qed. + #[tactic="program_simpl"] + Equations? declare_valid_model {V W init cls} + (m : valid_model V W init cls) + (l : Level.t) + (hl : LevelSet.mem l V = false) + (hnin : ~ LevelSet.In l (clauses_levels cls)) + (hz : LevelSet.In Level.zero V) + (hzd : Deciders.zero_declared init) : + valid_model (LevelSet.add l V) W + (LevelMap.add l (Some (if Level.is_global l then 0 else 1)) init) + (Clauses.add (init_clause_of_level l) cls) := + @declare_valid_model V W init cls m l hl hnin hz zerod := {| + model_model := LevelMap.add l (Some (if Level.is_global l then 0 else 1)) m.(model_model) |}. + Proof. + all:destruct m as [M mofV mupd mcls mok]. cbn in *. + * intros k. rewrite LevelSet.add_spec LevelMapFact.F.add_in_iff. firstorder. now left. + * move: mupd; rewrite /is_update_of //=. + destruct (LevelSet.is_empty) eqn:hw. + { now intros ->. } + { eapply levelset_not_Empty_is_empty in hw. + apply LevelSetFact.not_mem_iff in hl. + intros s. eapply strictly_updates_weaken; revgoals. + eapply strictly_updates_add; tea. now clsets. } + * rewrite clauses_conclusions_add. cbn. rsets. + * apply LevelSetFact.not_mem_iff in hl. + rewrite ClausesProp.add_union_singleton is_model_union //. + split => //. + rewrite is_model_valid. + intros cl; rsets. subst cl. + rewrite /init_clause_of_level. + rewrite /valid_clause. cbn. rewrite min_premise_singleton //=. + rewrite level_value_add /level_value_above. + set value := Some _. + have hleq : (Some 1 ≤ level_value (LevelMap.add l value M) Level.zero)%opt. + { rewrite level_value_add_other. intros ->. now apply hl. + eapply is_update_of_ext in mupd. + eapply zero_declared_ext in zerod; tea. + destruct zerod as [k hzero]. rewrite (level_value_MapsTo hzero). + subst value. constructor. lia. } + depelim hleq. rewrite H0. + apply Z.leb_le. cbn. destruct Level.is_global; lia. + apply is_model_add => //. + Qed. + + #[tactic="program_simpl"] Equations? declare_level (m : t) (l : Level.t) : option t := declare_level m l with inspect (LevelSet.mem l m.(levels)) := | exist true _ => None - | exist false hneq => Some {| levels := LevelSet.add l m.(levels); clauses := Clauses.add (init_clause_of_level l) m.(clauses) |}. + | exist false hneq => + Some {| + levels := LevelSet.add l m.(levels); + clauses := Clauses.add (init_clause_of_level l) m.(clauses); + correct_model := + {| initial_model := LevelMap.add l (Some (if Level.is_global l then 0 else 1)) m.(initial_model); + only_model_of_V := _; + model_updates := m.(model_updates); + model_valid := declare_valid_model m.(model_valid) l hneq _ _ _ + |} + |}. Proof. - refine {| initial_model := LevelMap.add l (Some (if Level.is_global l then 0 else 1)) m.(initial_model); - only_model_of_V := _; - model_updates := m.(model_updates); |}. - have hv := only_model_of_V m. eapply zero_declared_ext. apply m.(correct_model). eapply update_model_monotone. rsets; rewrite level_value_None. @@ -1594,40 +1646,14 @@ Module Abstract. * now left. * move: b => [] cl [] hin. right. apply (clauses_levels_declared m a). rsets. firstorder. + - destruct m as [levels clauses vm]; cbn in *. + apply LevelSetFact.not_mem_iff in hneq; lsets. - destruct m as [levels clauses vm]; cbn in *. destruct vm as [init zerod azerod dpos en omofV W incl vm]. - destruct vm as [M mofV mupd mcls mok]. cbn in *. - refine {| model_model := LevelMap.add l (Some (if Level.is_global l then 0 else 1)) M |}. - * intros k. rewrite LevelSet.add_spec LevelMapFact.F.add_in_iff. firstorder. now left. - * move: mupd; rewrite /is_update_of. - destruct (LevelSet.is_empty) eqn:hw. - { now intros ->. } - { eapply levelset_not_Empty_is_empty in hw. - apply LevelSetFact.not_mem_iff in hneq. - intros s. eapply strictly_updates_weaken; revgoals. - now eapply strictly_updates_add. now clsets. } - * rewrite clauses_conclusions_add. cbn. rsets. destruct H; subst. - + right. apply omofV. now apply zero_declared_in. - + right; lsets. - * apply LevelSetFact.not_mem_iff in hneq. - rewrite ClausesProp.add_union_singleton is_model_union //. - split => //. - rewrite is_model_valid. - intros cl; rsets. subst cl. - rewrite /init_clause_of_level. - rewrite /valid_clause. cbn. rewrite min_premise_singleton //=. - rewrite level_value_add /level_value_above. - set value := Some _. - have hl : (Some 1 ≤ level_value (LevelMap.add l value M) Level.zero)%opt. - { rewrite level_value_add_other. intros ->. apply hneq. - { now apply omofV, zero_declared_in. } - eapply is_update_of_ext in mupd. - eapply zero_declared_ext in zerod; tea. - destruct zerod as [k hzero]. rewrite (level_value_MapsTo hzero). - subst value. constructor. lia. } - depelim hl. rewrite H0. - apply Z.leb_le. cbn. destruct Level.is_global; lia. - apply is_model_add => //. lsets => //. + apply zero_declared_in in zerod. + now apply omofV. + - destruct m as [levels clauses vm]; cbn in *. + apply (declared_zero vm). Qed. Lemma declare_level_clauses {m l m'} : @@ -2098,21 +2124,17 @@ Module Abstract. Definition inconsistent_ext m cls := forall v : Level.t -> option Z, positive_opt_valuation v -> clauses_sem v (clauses m) -> ~ clauses_sem v cls. - Lemma enforce_dec m cls : - clauses_levels cls ⊂_lset levels m -> + Equations? enforce_dec m cls (wf : clauses_levels cls ⊂_lset levels m) : { consistent (Clauses.union (clauses m) cls) } + - { inconsistent_opt_ext m cls }. + { inconsistent_opt_ext m cls } := + enforce_dec m cls wf with inspect (enforce_clauses m cls) := + | exist None ec => !%prg (* impossible by wf *) + | exist (Some (inl model)) ec => in_left + | exist (Some (inr loop)) ec => in_right. Proof. - intros hm. - destruct (enforce_clauses m cls) eqn:ec. - destruct s as [model|loop]. - - left. move/enforce_clauses_clauses: ec. + - move/enforce_clauses_clauses: ec. intros <-. apply clauses_consistent. - - right. now move/enforce_clauses_inconsistent_opt: ec. - (* intros he v semcs semc. red in he. - specialize (he ) - apply he. red. exists v. split => //. - apply clauses_sem_union. split => //. *) + - now move/enforce_clauses_inconsistent_opt: ec. - move/enforce_clauses_None: ec. contradiction. Qed. diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index 69c3366d6..73cfd53a0 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -370,7 +370,7 @@ Definition lexprod_rel := lexprod lt lt. #[local] Instance lexprod_rel_wf : WellFounded lexprod_rel. Proof. - eapply (Acc_intro_generator 1000). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. + eapply (Acc_intro_generator 2). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. Defined. Lemma model_incl {V W m cls} : valid_model V W m cls -> W ⊂_lset V. diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index e02a58e07..e7e24f6b7 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -94,56 +94,28 @@ Definition of_level (l : Level.t_) : Universe.t := Universe.of_level l. Coercion of_level : Level.t_ >-> Universe.t. Coercion Universe.of_level : Level.t >-> Universe.t. -Definition test_model : bool := +Definition test_model : option universe_model := let la := Level.level "a" in let lb := Level.level "b" in - let ls := levels_of_list [la; lb] in - let cs := constraints_of_list [(la <= lb)%cstr] in - match push_uctx init_model (ls, cs) with - | Some m => true - | None => false - end. + let lc := Level.level "c" in + let ls := levels_of_list [la; lb; lc] in + let cs := constraints_of_list [la <= lb; lb <= lc]%cstr in + push_uctx init_model (ls, cs). -Lemma test_model_spec : test_model = true. +Lemma test_model_spec : (if test_model is Some _ then true else false) = true. Proof. - rewrite /test_model. - set ls := levels_of_list _. - set cs := constraints_of_list _. - rewrite /push_uctx /push_uctx_clause_1. - set m := UnivLoopChecking.declare_levels init_model ls. - rewrite /enforce_constraints /enforce_constraints_aux. - cbn -[enforce]. - set m' := {| model := _ |}. - unfold enforce. - set ef := LoopCheck.enforce m' _. - cbn -[LoopCheck.enforce] in ef. - unfold to_atoms in ef. - cbn -[LoopCheck.enforce] in ef. - unfold LoopCheck.enforce in ef. - unfold LoopCheck.Impl.Abstract.enforce_clauses in ef. - hnf in ef. - unfold LoopCheck.Impl.CorrectModel.infer_extension_correct in ef. - unfold LoopCheck.Impl.CorrectModel.infer_extension_correct_clause_1 in ef. - unfold LoopCheck.Impl.infer_extension in ef. - unfold LoopCheck.Impl.infer_model_extension in ef. - hnf in ef. - set (l := LoopCheck.Impl.I.loop _ _ _ _ _ _) in *. - match goal with - | [ l := LoopCheck.Impl.I.loop _ _ _ _ _ ?pre |- _ ] => - set (precond := pre) in * + reflexivity. +Qed. +Search UnivLoopChecking.univ_model. +Definition check_model c := + match test_model with + | Some m => check m c + | None => false end. - clearbody precond. - - - lazy in ef. - unfold LoopCheck.Impl.I.loop in ef. - hnf in ef. - set () - unfold FixWf in ef. - - hnf in ef. - Eval compute in test_model. +Example check_model_impl : check_model (Level.level "a" <= Level.level "b")%cstr = true := eq_refl. +Example check_model_impl_trans : check_model (Level.level "a" <= Level.level "c")%cstr = true := eq_refl. +Example check_model_nimpl : check_model (Level.level "b" <= Level.level "a")%cstr = false := eq_refl. Import UnivLoopChecking. From b38fdb6a4f31ad1fa57c9c6a6353f8f8a970e312 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sat, 15 Nov 2025 18:42:31 +0100 Subject: [PATCH 153/164] Revert deactivated tests now that loop checking works in Rocq itself --- coq-partialfun | 1 + examples/metarocq_tour.v | 3 +-- examples/metarocq_tour_prelude.v | 2 -- test-suite/reduction_test.v | 5 ++--- translations/param_generous_packed.v | 2 -- translations/times_bool_fun.v | 2 -- translations/times_bool_fun2.v | 2 -- 7 files changed, 4 insertions(+), 13 deletions(-) create mode 160000 coq-partialfun diff --git a/coq-partialfun b/coq-partialfun new file mode 160000 index 000000000..ace79844d --- /dev/null +++ b/coq-partialfun @@ -0,0 +1 @@ +Subproject commit ace79844da3990e2ecb11073b6dcb5aec48b887b diff --git a/examples/metarocq_tour.v b/examples/metarocq_tour.v index 6f20cfc9a..88ed7a0d4 100644 --- a/examples/metarocq_tour.v +++ b/examples/metarocq_tour.v @@ -77,7 +77,7 @@ Check type_of_subtype. (* Running the safe checker inside Rocq *) From MetaRocq.Examples Require Import metarocq_tour_prelude. -(* Check check_inh. *) +Check check_inh. (** We construct a proof of typing entirely within Rocq, calling the typechecker to produce the derivation *) (* Lemma identity_typing (u := Universe.make univ): @@ -91,7 +91,6 @@ Proof. Qed. *) (** The extracted typechecker also runs in OCaml *) -(* FIXME: checker unusable in OCaml due to representation of universes *) (* MetaRocq SafeCheck (fun x : nat => x + 1). *) (** Erasure *) diff --git a/examples/metarocq_tour_prelude.v b/examples/metarocq_tour_prelude.v index d2dd042de..5f22dd651 100644 --- a/examples/metarocq_tour_prelude.v +++ b/examples/metarocq_tour_prelude.v @@ -47,7 +47,6 @@ Definition make_wf_env_ext (Σ : global_env_ext) : EnvCheck wf_env_ext wf_env_ex '(exist Σ' pf) <- check_wf_ext optimized_abstract_env_impl Σ ;; ret Σ'. -(* Definition gctx_wf_env : wf_env_ext. Proof. let wf_proof := eval hnf in (make_wf_env_ext gctx) in @@ -82,4 +81,3 @@ Ltac fill_inh t := end | [ |- inh _ ?Γ _ ] => fail "Missing local wellformedness assumption for" Γ end. -*) \ No newline at end of file diff --git a/test-suite/reduction_test.v b/test-suite/reduction_test.v index 74d7bbfa6..d37a72e1f 100644 --- a/test-suite/reduction_test.v +++ b/test-suite/reduction_test.v @@ -105,6 +105,5 @@ Program Definition eval_compute_cheat (cf := default_checker_flags) [] p'.2 (todo "welltyped") in PCUICToTemplate.trans tm. -Time Definition bar'' := Eval lazy in eval_compute_cheat default_normal foo Monomorphic_ctx. - -MetaRocq Unquote Definition bar''' := bar''. +Time Definition bar'' := Eval lazy in eval_compute default_normal foo Monomorphic_ctx. +MetaRocq Unquote Definition bar''' := (match bar'' with inl x => x | inr _ => todo "" end). diff --git a/translations/param_generous_packed.v b/translations/param_generous_packed.v index 22dc16ea3..0947f1942 100644 --- a/translations/param_generous_packed.v +++ b/translations/param_generous_packed.v @@ -183,7 +183,6 @@ Next Obligation. - cbn; intros A B x y. exact y.2. Defined. -(* Time MetaRocq Run (TC <- ImplementExisting TC' "sigT_ind" ;; tmDefinition "TC''" TC). Next Obligation. @@ -309,4 +308,3 @@ Next Obligation. intros [[[] [[] H]] _]. apply H; reflexivity. - cbn. intros [[[] [[] H]] _]. apply H; reflexivity. Defined. *) -*) \ No newline at end of file diff --git a/translations/times_bool_fun.v b/translations/times_bool_fun.v index 57ecd8d15..2b781eaed 100644 --- a/translations/times_bool_fun.v +++ b/translations/times_bool_fun.v @@ -339,7 +339,6 @@ Next Obligation. tIntro y. tIntro p. destruct p. exact t. Defined. -(* MetaRocq Run (TC <- TranslateRec eqTC'' wUnivalence ;; tmDefinition "eqTC3" TC). @@ -406,4 +405,3 @@ Next Obligation. apply (f_equal bool_of_Equivᵗ) in X. cbn in X. inversion X. Defined. -*) \ No newline at end of file diff --git a/translations/times_bool_fun2.v b/translations/times_bool_fun2.v index 99454f3b5..de2452d14 100644 --- a/translations/times_bool_fun2.v +++ b/translations/times_bool_fun2.v @@ -79,7 +79,6 @@ Defined. Definition UA := forall A B, isequiv (id2equiv A B). -(* MetaRocq Run (TC <- Translate eqTC "isequiv" ;; TC <- Translate TC "equiv" ;; TC <- ImplementExisting TC "eq" ;; @@ -186,4 +185,3 @@ Definition αequiv_weakfunext : contr_isequivα -> weakFunext. 2: exact (equiv_contrfib _ (Hα A P H) idmap). exact (contr_retract_α A P H). Defined. -*) \ No newline at end of file From 2494d7205a3fd04c1454b0b26a96251b633ce118 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sun, 16 Nov 2025 00:16:00 +0100 Subject: [PATCH 154/164] Fix transparency issues --- .../LoopChecking/PartialLoopChecking.v | 2 +- common/theories/Universes.v | 9 ++++---- safechecker/theories/PCUICEqualityDec.v | 21 +++++++++++-------- 3 files changed, 18 insertions(+), 14 deletions(-) diff --git a/common/theories/LoopChecking/PartialLoopChecking.v b/common/theories/LoopChecking/PartialLoopChecking.v index 73cfd53a0..69c3366d6 100644 --- a/common/theories/LoopChecking/PartialLoopChecking.v +++ b/common/theories/LoopChecking/PartialLoopChecking.v @@ -370,7 +370,7 @@ Definition lexprod_rel := lexprod lt lt. #[local] Instance lexprod_rel_wf : WellFounded lexprod_rel. Proof. - eapply (Acc_intro_generator 2). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. + eapply (Acc_intro_generator 1000). unfold lexprod_rel. eapply wf_lexprod, lt_wf. eapply lt_wf. Defined. Lemma model_incl {V W m cls} : valid_model V W m cls -> W ⊂_lset V. diff --git a/common/theories/Universes.v b/common/theories/Universes.v index 4bea21410..03692027c 100644 --- a/common/theories/Universes.v +++ b/common/theories/Universes.v @@ -376,14 +376,15 @@ End LevelExpr. Module LevelExprSet. Include MSetList.MakeWithLeibniz LevelExpr. - Lemma reflect_eq : ReflectEq t. - Proof. - refine {| eqb := equal |}. - intros x y. have := (equal_spec x y). + #[program] Instance reflect_eq : ReflectEq t := + {| eqb := equal |}. + Next Obligation. + have := (equal_spec x y). destruct equal => //; constructor. now apply eq_leibniz, H. intros ->. destruct H. now forward H0 by reflexivity. Qed. + End LevelExprSet. Module LevelExprSetFact := WFactsOn LevelExpr LevelExprSet. diff --git a/safechecker/theories/PCUICEqualityDec.v b/safechecker/theories/PCUICEqualityDec.v index 386ea3763..e65c26b9e 100644 --- a/safechecker/theories/PCUICEqualityDec.v +++ b/safechecker/theories/PCUICEqualityDec.v @@ -9,6 +9,7 @@ From MetaRocq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICPrimitive PCUICTa From Equations.Prop Require Import DepElim. From Equations Require Import Equations. +Set Equations Transparent. Local Set Keyed Unification. @@ -825,25 +826,27 @@ Proof. rewrite -init_constraints_of_clean_uctx. reflexivity. Qed. -Lemma graph_of_wf {cf:checker_flags} {Σ : global_env} (HΣ : ∥ wf Σ ∥) -: ∑ G, model_of_uctx G (global_uctx Σ). +Equations? graph_of_wf {cf:checker_flags} {Σ : global_env} (HΣ : ∥ wf Σ ∥) : ∑ G, model_of_uctx G (global_uctx Σ) := + graph_of_wf HΣ with inspect (push_uctx init_model (clean_uctx (global_uctx Σ))) := + | exist (Some u) hp := existT _ u _ + | exist None hp => False_rect _ _. Proof. - destruct (push_uctx init_model (clean_uctx (global_uctx Σ))) eqn:hp. - - exists u. apply push_uctx_init_model_sat in hp. + - apply push_uctx_init_model_sat in hp. now apply model_of_clean_uctx. - apply push_uctx_init_model_unsat in hp; tea. - * exfalso. destruct HΣ. apply hp. + * destruct HΣ. apply hp. assert (consistent (global_uctx Σ).2) as HC. { sq; apply (wf_consistent _ X). } destruct HC as [v sat]. now exists v. * destruct HΣ. eapply wf_global_uctx_invariants. exact X. Qed. -Lemma graph_of_wf_ext {cf:checker_flags} {Σ : global_env_ext} (HΣ : ∥ wf_ext Σ ∥) -: ∑ G, model_of_uctx G (global_ext_uctx Σ). +Equations? graph_of_wf_ext {cf:checker_flags} {Σ : global_env_ext} (HΣ : ∥ wf_ext Σ ∥) : ∑ G, model_of_uctx G (global_ext_uctx Σ) := + graph_of_wf_ext HΣ with inspect (push_uctx init_model (clean_uctx (global_ext_uctx Σ))) := + | exist (Some u) hp := existT _ u _ + | exist None hp => False_rect _ _. Proof. - destruct (push_uctx init_model (clean_uctx (global_ext_uctx Σ))) eqn:hp. - - exists u. apply push_uctx_init_model_sat in hp. + - apply push_uctx_init_model_sat in hp. now apply model_of_clean_uctx. - apply push_uctx_init_model_unsat in hp; tea. * exfalso. destruct HΣ. apply hp. From a74423c4600997ae6f5919049c53308e01542f33 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sun, 16 Nov 2025 00:37:29 +0100 Subject: [PATCH 155/164] MetaRocq tour fully works again, with evaluation of safechecker in Rocq itself --- examples/metarocq_tour.v | 33 ++++++++++++++++++++------------ examples/metarocq_tour_prelude.v | 32 +++++++++++++++++++++++++++---- 2 files changed, 49 insertions(+), 16 deletions(-) diff --git a/examples/metarocq_tour.v b/examples/metarocq_tour.v index 88ed7a0d4..8850d799c 100644 --- a/examples/metarocq_tour.v +++ b/examples/metarocq_tour.v @@ -1,6 +1,6 @@ From MetaRocq.Utils Require Import utils. From MetaRocq.Common Require Import config. -From MetaRocq.Template Require Import All. +From MetaRocq.Template Require Import Loader. From MetaRocq.Template Require Import TemplateMonad. From MetaRocq.PCUIC Require Import PCUICAst PCUICReduction PCUICCumulativity PCUICTyping PCUICSafeLemmata. @@ -79,19 +79,31 @@ From MetaRocq.Examples Require Import metarocq_tour_prelude. Check check_inh. +Ltac set_head_match c := + let c := eval cbn delta [c] in c in + match c with + | match ?d with _ => _ end => + set_head_match d || (let head := fresh in set (head := d)) + end. + +Arguments infer_type {cf nor X_type X normalization_in infer}. +About Checked_comp. + (** We construct a proof of typing entirely within Rocq, calling the typechecker to produce the derivation *) -(* Lemma identity_typing (u := Universe.make univ): - inh gctx_wf_env [] (tProd (bNamed "s") (tSort u) (tImpl (tRel 0) (tRel 0))). +Lemma identity_typing (u := Universe.of_level univ): + inh gctx_wf_env [] (tProd (bNamed "s") (tSort (sType u)) (tImpl (tRel 0) (tRel 0))). Proof. (* We construct a term *) - set (impl := tLambda (bNamed "s") (tSort u) (tLambda bAnon (tRel 0) (tRel 0))). + set (impl := tLambda (bNamed "s") (tSort (sType u)) (tLambda bAnon (tRel 0) (tRel 0))). (* Show that the empty context is well-formed *) assert (wfΓ : forall Σ0 : global_env_ext, abstract_env_ext_rel gctx_wf_env Σ0 -> ∥ wf_local Σ0 [] ∥) by do 2 constructor. + (** And build the typing derivation reflexively using the type checker *) fill_inh impl. -Qed. *) +Qed. (** The extracted typechecker also runs in OCaml *) -(* MetaRocq SafeCheck (fun x : nat => x + 1). *) +MetaRocq SafeCheck (fun x : nat => x + 1). +MetaRocq SafeCheck (forall x : Set, x -> x). (** Erasure *) From MetaRocq.ErasurePlugin Require Import Erasure Loader. @@ -121,8 +133,7 @@ MetaRocq Erase singleton_elim. - All metatheory proofs are finished. Compared to Rocq's implementation: - - full (max (i + k, j + l)) universe support (including a naïve acyclicity checking - algorithm) + - full (max (i + k, j + l)) universe support including an efficient loop checker. - partial support for SProp (in programs but not yet formalized typing rules) @@ -141,12 +152,10 @@ MetaRocq Erase singleton_elim. - Relation to CertiRocq: fast and verified correct erasure, not depending on type-checking (only retyping). - + CertiRocq needs to have all constructors eta-expanded, a proof of the - syntactic translation expanding constructors is in progress. - - + Otherwise the front-end part of CertiRocq is complete with proofs. + + Eta-expansion and let-expansion proofs are part of MetaRocq + Future work: handling of primitive types (ints, floats, arrays, ...) + at the level of the specification *) diff --git a/examples/metarocq_tour_prelude.v b/examples/metarocq_tour_prelude.v index 5f22dd651..05d1fd1b2 100644 --- a/examples/metarocq_tour_prelude.v +++ b/examples/metarocq_tour_prelude.v @@ -47,17 +47,41 @@ Definition make_wf_env_ext (Σ : global_env_ext) : EnvCheck wf_env_ext wf_env_ex '(exist Σ' pf) <- check_wf_ext optimized_abstract_env_impl Σ ;; ret Σ'. +(* These tactics can be useful to debug an opaque function blocking reduction of the + safe checker *) + +Ltac abs_checked_comp H := + let t := eval cbv delta [H] in H in + match t with + | Checked_comp ((?t; ?prf)) => + let Hc := fresh in set (Hc := prf) in H; clearbody Hc; cbn in H, Hc + end. + +Ltac set_head_match_aux H c := + match c with + | match ?d with _ => _ end => + set_head_match_aux H d || (let head := fresh in set (head := d) in H) + end. + +Ltac set_head_match c := let t := eval cbv delta [c] in c in + set_head_match_aux c t. + +Ltac hnf_head_match c := + let c := eval hnf in c in + match c with + | match ?d with _ => _ end => let head := fresh in set (head := d) + | match ?d with _ => _ end eq_refl => let head := fresh in set (head := d) + end. + Definition gctx_wf_env : wf_env_ext. Proof. let wf_proof := eval hnf in (make_wf_env_ext gctx) in match wf_proof with | CorrectDecl _ ?x => exact x - | _ => fail "Couldn't prove the global environment is well-formed" + | ?h => fail "Couldn't prove the global environment is well-formed" h end. Defined. - - (** There is always a proof of `forall x : Sort s, x -> x` *) Definition inh (Σ : wf_env_ext) Γ T := (∑ t, forall Σ0 : global_env_ext, abstract_env_ext_rel Σ Σ0 -> ∥ typing Σ0 Γ t T ∥). @@ -71,7 +95,7 @@ Ltac fill_inh t := lazymatch goal with [ wfΓ : forall _ _ , ∥ wf_local _ ?Γ ∥ |- inh ?Σ ?Γ ?T ] => let t := uconstr:(check_inh Σ Γ wfΓ t (T:=T)) in - let proof := eval cbn in t in + let proof := eval hnf in t in match proof with | Checked ?d => exact_no_check d | TypeError ?e => From 318aa92815b2ee203bd2fce248d892ca03fe9d53 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sun, 16 Nov 2025 00:41:32 +0100 Subject: [PATCH 156/164] Fixed test-suite file --- examples/typing_correctness.v | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/examples/typing_correctness.v b/examples/typing_correctness.v index 4621eae64..248f2bce9 100644 --- a/examples/typing_correctness.v +++ b/examples/typing_correctness.v @@ -91,7 +91,7 @@ Definition univ := Level.level "s". (* TODO move to SafeChecker *) Definition gctx : global_env_ext := - ({| universes := (LS.union (LevelSet.singleton Level.lzero) (LevelSet.singleton univ), UnivConstraintSet.empty); declarations := [] + ({| universes := (LevelSet.singleton univ, UnivConstraintSet.empty); declarations := [] ; retroknowledge := Retroknowledge.empty |}, Monomorphic_ctx). (** We use the environment checker to produce the proof that gctx, which is a singleton with only @@ -159,14 +159,7 @@ Time Qed. *) Lemma identity_typing (s := sType (Universe.of_level univ)): (∑ t : term, forall Σ0 : global_env_ext, - Σ0 = - ({| - universes := - (LS.union (LevelSet.singleton Level.lzero) - (LevelSet.singleton univ), UnivConstraintSet.empty); - declarations := []; - retroknowledge := Retroknowledge.empty - |}, Monomorphic_ctx) -> + Σ0 = gctx_wf_env -> ∥ Σ0;;; [] |- t : tProd (bNamed "s") (tSort s) (tImpl (tRel 0) (tRel 0)) ∥). (* inh gctx_wf_env [] (tProd (bNamed "s") (tSort u) (tImpl (tRel 0) (tRel 0))). *) From c3857001538045ac3e64c4d84688dbf79d60a113 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sun, 16 Nov 2025 07:24:59 +0100 Subject: [PATCH 157/164] Remove unnecessary files --- common/theories/LoopChecking/Expressions.v | 0 .../theories/LoopChecking/OldPresentation.v | 266 ------------------ 2 files changed, 266 deletions(-) delete mode 100644 common/theories/LoopChecking/Expressions.v delete mode 100644 common/theories/LoopChecking/OldPresentation.v diff --git a/common/theories/LoopChecking/Expressions.v b/common/theories/LoopChecking/Expressions.v deleted file mode 100644 index e69de29bb..000000000 diff --git a/common/theories/LoopChecking/OldPresentation.v b/common/theories/LoopChecking/OldPresentation.v deleted file mode 100644 index e53bdf529..000000000 --- a/common/theories/LoopChecking/OldPresentation.v +++ /dev/null @@ -1,266 +0,0 @@ - Record presentation := - { V : LevelSet.t; C : rels }. - - Definition presentation_of cstrs := - {| V := levels_of_z_constraints cstrs; - C := relations_of_constraints cstrs |}. - - - Definition presentation_of_clauses cls := - {| V := Clauses.clauses_levels cls; - C := relations_of_clauses cls |}. - - - Definition entails_cstr cstrs c := - entails_clauses (to_clauses cstrs) (LoopCheck.to_clauses (to_constraint c)). - - Definition entails_z_cstr cstrs c := - entails_clauses (of_z_constraints cstrs) (LoopCheck.to_clauses c). - - Definition entails_cstrs cstrs cstrs' := - entails_clauses (of_z_constraints cstrs) (of_z_constraints cstrs'). - - - Lemma check_valid m c : - check m c <-> entails_cstr (constraints m) c. - Proof. - rewrite /check LoopCheck.check_spec. - rewrite /entails_clauses. - enough ((LoopCheck.clauses (model m)) =_clset (to_clauses (constraints m))). - { split; intros ? ?. - move/H0. now rewrite H. - move/H0. now rewrite H. } - intros cl. - rewrite to_clauses_spec. - split. - - now move/(repr_constraints_inv m). - - intros [cstr [hin incl]]. - eapply (repr_constraints m); tea. - Qed. - - Lemma presentation_of_clauses_spec cls prems concl : - Clauses.In (prems, concl) cls -> - In (NES.singleton concl ∨ prems, prems) (C (presentation_of_clauses cls)). - Proof. - rewrite /presentation_of_clauses //=. - move/relations_of_clauses_spec_inv => //=. - Qed. - - (* Import LoopCheck.Impl.I.Model.Model.Clauses.FLS. *) - - Definition presentation_entails cstrs c := - let '(l, d, r) := to_constraint c in - match d with - | ConstraintType.Le => relations_of_constraints (to_z_cstrs cstrs) ⊢ℒ l ≤ r - | ConstraintType.Eq => relations_of_constraints (to_z_cstrs cstrs) ⊢ℒ l ≡ r - end. - - Lemma check_valid_pres m c : - check m c <-> presentation_entails (constraints m) c. - Proof. - rewrite check_valid. - destruct c as [[l []] r]; cbn. - - rewrite completeness_le. - rewrite /entails_cstr /entails_z_cstr. - now rewrite to_clauses_of_z_constraints. - - rewrite completeness_eq_cstrs. - rewrite /entails_cstr /entails_z_cstr. - now rewrite to_clauses_of_z_constraints. - Qed. - Lemma presentation_entails_valid_eq {p l r} : - p ⊢ℒ l ≡ r -> valid_constraint p (l, ConstraintType.Eq, r). - Proof. - move/completeness. - rewrite /valid_relation /valid_constraint /interp_z_cstr //=. - Qed. - - Lemma presentation_entails_valid_le {p l r} : - p ⊢ℒ l ≤ r -> valid_constraint p (l, ConstraintType.Le, r). - Proof. - rewrite /valid_constraint /interp_z_cstr //=. - move/presentation_entails_valid_eq => vc v hc. - specialize (vc v hc). cbn in vc. - rewrite interp_nes_union in vc. apply vc. - Qed. - - Lemma presentation_entails_valid {p c} : - entails_L_cstr p c -> valid_constraint p c. - Proof. - destruct c as [[l []] r]; cbn. - - apply presentation_entails_valid_le. - - apply presentation_entails_valid_eq. - Qed. - - Lemma presentation_entails_satisfies {p cstrs} : - entails_L_cstrs p cstrs -> valid_cstrs p cstrs. - Proof. - intros ha c hin. specialize (ha c hin). - now apply presentation_entails_valid. - Qed. - - Lemma completeness_eq_cstrs cstrs s t : - relations_of_constraints cstrs ⊢ℒ s ≡ t <-> - entails_z_cstr cstrs (s, ConstraintType.Eq, t). - Proof. - unfold entails_z_cstr. - rewrite -entails_L_entails_ℋ_equiv. - rewrite -LoopCheck.Impl.Abstract.entails_L_rels_entails_L_clauses. - rewrite relation_of_constraint_of_clause //=. - now rewrite rels_of_z_constraints_spec entails_L_all_tip. - Qed. - - Lemma completeness_le cstrs s t : - relations_of_constraints cstrs ⊢ℒ s ≤ t <-> - entails_z_cstr cstrs (s, ConstraintType.Le, t). - Proof. - unfold entails_z_cstr. - split. - - move/completeness_eq_cstrs. cbn. - intros h; red in h. cbn in h. - eapply Theory.le_spec. now rewrite /Clauses.le. - - move/entails_ℋ_entails_L. apply entails_L_clauses_le. - Qed. - - - - Lemma entails_clauses_le {cstrs l r} : - ZUnivConstraintSet.In (l, ConstraintType.Le, r) cstrs -> - of_z_constraints cstrs ⊢a r → l. - Proof. - intros hin l' cl. - eapply in_pred_closure_entails_clause, incls0. - rewrite of_z_constraints_spec. eexists; split; tea. - now apply in_clause_of_le. - Qed. - - Lemma entails_clauses_eq_left {cstrs l r} : - ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> - of_z_constraints cstrs ⊢a r → l. - Proof. - intros hin l' cl. - eapply in_pred_closure_entails_clause, incls0. - rewrite of_z_constraints_spec. eexists; split; tea. - rewrite LoopCheck.to_clauses_spec. left. exists l'. split => //. - Qed. - - Lemma entails_clauses_eq_right {cstrs l r} : - ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> - of_z_constraints cstrs ⊢a l → r. - Proof. - intros hin l' cl. - eapply in_pred_closure_entails_clause, incls0. - rewrite of_z_constraints_spec. eexists; split; tea. - rewrite LoopCheck.to_clauses_spec. right. exists l'. split => //. - Qed. - - Lemma entails_clauses_eq_cstr {cstrs l r} : - ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> - of_z_constraints cstrs ⊢ℋ l ≡ r. - Proof. - intros hin. - apply Theory.eq_antisym. - split. - - rewrite to_entails_all. now apply entails_clauses_eq_left. - - rewrite to_entails_all. now apply entails_clauses_eq_right. - Qed. - - Lemma entails_clauses_le_cstr {cstrs l r} : - ZUnivConstraintSet.In (l, ConstraintType.Le, r) cstrs -> - of_z_constraints cstrs ⊢ℋ l ⋞ r. - Proof. - intros hin. - rewrite to_entails_all. now apply entails_clauses_le. - Qed. - - Lemma entails_L_clauses_eq_cstr {cstrs l r} : - ZUnivConstraintSet.In (l, ConstraintType.Eq, r) cstrs -> - relations_of_clauses (of_z_constraints cstrs) ⊢ℒ l ≡ r. - Proof. - move/entails_clauses_eq_cstr. - rewrite -entails_L_entails_ℋ_equiv. - now rewrite -(entails_L_clauses_entails_L_relations _ (l, r)). - Qed. - - Lemma entails_L_clauses_le_cstr {cstrs l r} : - ZUnivConstraintSet.In (l, ConstraintType.Le, r) cstrs -> - relations_of_clauses (of_z_constraints cstrs) ⊢ℒ l ≤ r. - Proof. - move/entails_clauses_le_cstr. - rewrite -entails_L_entails_ℋ_equiv. - now rewrite /entails_L_clauses Clauses.entails_L_pres_clauses_of_le. - Qed. - - Lemma entails_L_clauses_leq_def {p l r} : - entails_L_clauses p (l ⋞ r) <-> entails_L_clauses p (l ∨ r ≡ r). - Proof. - rewrite /entails_L_clauses. - rewrite entails_L_pres_clauses_of_relations_eq. - now rewrite Clauses.entails_L_pres_clauses_of_le. - Qed. - - Lemma entails_to_clauses {prems concl cstr} : - Clauses.In (prems, concl) (LoopCheck.to_clauses cstr) -> - [relation_of_constraint cstr] ⊢ℒ (singleton concl ≤ prems). - Proof. - destruct cstr as [[l []] r]. - - intros hin. cbn -[le]. - have en := entails_L_relations_of_clauses_le l r. - setoid_rewrite <- en. cbn in hin. - now eapply entails_L_in_cls. - - intros hin; cbn in hin |- *. - rewrite -entails_L_relations_of_clauses_eq. - now eapply entails_L_in_cls. - Qed. - - Lemma entails_L_clauses_all {cstrs s t} : - (relations_of_clauses (of_z_constraints cstrs)) ⊢ℒ s ≡ t <-> - (relations_of_constraints cstrs) ⊢ℒ s ≡ t. - Proof. - now rewrite rels_of_z_constraints_spec. - Qed. - - Lemma entails_L_clauses_le {cstrs s t} : - entails_L_pres_clauses (relations_of_clauses (of_z_constraints cstrs)) (s ⋞ t) -> - relations_of_constraints cstrs ⊢ℒ s ≤ t. - Proof. - intros hf. do 2 red in hf. rw_in clauses_of_le_spec hf. - eapply entails_L_split. - move=> le hin. - move: (hf (t, le)) => /fwd. - { exists le; split => //. } - move=> h; red in h. cbn in h. - now eapply entails_L_clauses_all in h. - Qed. - - Lemma entails_L_clauses_of_eq {cstrs s t} : - entails_L_pres_clauses (relations_of_clauses (of_z_constraints cstrs)) (s ≡ t) -> - relations_of_constraints cstrs ⊢ℒ s ≡ t. - Proof. - intros hf. do 2 red in hf. - eapply entails_L_eq_antisym. split. - all: apply entails_L_clauses_le. - - intros cl hin; red. eapply hf. - rewrite /clauses_of_eq. clsets. - - intros cl hin; red. eapply hf. - rewrite /clauses_of_eq. clsets. - Qed. - - - Definition entails_L_cstr p c := - let '(l, d, r) := c in - match d with - | ConstraintType.Le => p ⊢ℒ l ≤ r - | ConstraintType.Eq => p ⊢ℒ l ≡ r - end. - - Lemma entails_L_clauses_cstr {cstrs c} : - entails_L_clauses (of_z_constraints cstrs) (LoopCheck.to_clauses c) -> - entails_L_cstr (relations_of_constraints cstrs) c. - Proof. - destruct c as [[l []] r]. - - cbn. apply entails_L_clauses_le. - - cbn. apply entails_L_clauses_of_eq. - Qed. - - Definition entails_L_cstrs p cstrs := - ZUnivConstraintSet.For_all (entails_L_cstr p) cstrs. From 55f9404b423cf6d63f45aebb48c845f20b8b8faa Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Sun, 16 Nov 2025 07:25:15 +0100 Subject: [PATCH 158/164] Fix \doteq use --- utils/theories/MRPrelude.v | 8 ++++---- utils/theories/MR_ExtrOCamlZPosInt.v | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/utils/theories/MRPrelude.v b/utils/theories/MRPrelude.v index cc16151a2..a8f25f84f 100644 --- a/utils/theories/MRPrelude.v +++ b/utils/theories/MRPrelude.v @@ -22,7 +22,7 @@ Notation "g ∘ f" := (eta_compose g f) (at level 40, left associativity). Notation " ! " := (@False_rect _ _) : metarocq_scope. -(* Use \sum to input ∑ in Company Rocq (it is not a sigma Σ). *) +(* Use \sum to input ∑ (it is not a sigma Σ). *) Notation "'∑' x .. y , p" := (sigT (fun x => .. (sigT (fun y => p%type)) ..)) (at level 200, x binder, right associativity, format "'[' '∑' '/ ' x .. y , '/ ' p ']'") @@ -36,12 +36,12 @@ Notation "( x ; y ; z ; t ; u ; v )" := (x ; ( y ; (z ; (t ; (u ; v))))). Notation "x .π1" := (@projT1 _ _ x) (at level 3, format "x '.π1'"). Notation "x .π2" := (@projT2 _ _ x) (at level 3, format "x '.π2'"). -(** Shorthand for pointwise equality relation in Proper signatures *) +(** Shorthand for pointwise equality relation in Proper signatures, + avoiding conflic with ssrfun's =1 + *) Notation "`≐1`" := (pointwise_relation _ Logic.eq) (at level 80). (* \doteq *) -#[warnings="-notation-overridden"] Infix "≐1" := (pointwise_relation _ Logic.eq) (at level 70) : type_scope. Notation "`≐2`" := (pointwise_relation _ (pointwise_relation _ Logic.eq)) (at level 80). -#[warnings="-notation-overridden"] Infix "≐2" := (pointwise_relation _ (pointwise_relation _ Logic.eq)) (at level 70) : type_scope. (** Higher-order lemma to simplify Proper proofs. *) diff --git a/utils/theories/MR_ExtrOCamlZPosInt.v b/utils/theories/MR_ExtrOCamlZPosInt.v index be41db80e..6e74c80e4 100644 --- a/utils/theories/MR_ExtrOCamlZPosInt.v +++ b/utils/theories/MR_ExtrOCamlZPosInt.v @@ -11,7 +11,7 @@ From Stdlib Require Import Extraction NArith ZArith. Extract Inductive positive => int [ "(fun p->1+2*p)" "(fun p->2*p)" "1" ] "(fun f2p1 f2p f1 p -> - if p<≐1 then f1 () else if p mod 2 = 0 then f2p (p/2) else f2p1 (p/2))". + if p<=1 then f1 () else if p mod 2 = 0 then f2p (p/2) else f2p1 (p/2))". Extract Inductive Z => int [ "0" "" "(~-)" ] "(fun f0 fp fn z -> if z=0 then f0 () else if z>0 then fp z else fn (-z))". From 97b93fa0be099f587267a44b2544d5a626531c14 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 17 Nov 2025 11:53:57 +0100 Subject: [PATCH 159/164] Revert "Deactivate quotation module for now" This reverts commit 3a6ecb48ad95f991aadb0c30725ac6d2f5358537. --- rocq-metarocq.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/rocq-metarocq.opam b/rocq-metarocq.opam index fced5ede7..8bdfd96fd 100644 --- a/rocq-metarocq.opam +++ b/rocq-metarocq.opam @@ -24,7 +24,7 @@ depends: [ "rocq-metarocq-safechecker-plugin" {= version} "rocq-metarocq-erasure-plugin" {= version} "rocq-metarocq-translations" {= version} -# "rocq-metarocq-quotation" {= version} + "rocq-metarocq-quotation" {= version} ] build: [ ["bash" "./configure.sh" ] {with-test} From 54db135a66628f63c4dfc0cb5a36ee9fe26c7f35 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 17 Nov 2025 11:54:12 +0100 Subject: [PATCH 160/164] Revert "Deactivate building quotation submodule for now in NIX" This reverts commit a9875f7a25c694e94823abe0de01845101ba5772. --- .nix/rocq-overlays/metarocq/default.nix | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.nix/rocq-overlays/metarocq/default.nix b/.nix/rocq-overlays/metarocq/default.nix index b49cf7f9c..5c0ba0ef1 100644 --- a/.nix/rocq-overlays/metarocq/default.nix +++ b/.nix/rocq-overlays/metarocq/default.nix @@ -34,11 +34,11 @@ let "safechecker" "template-pcuic" ]; - # "quotation" = [ - # "template-rocq" - # "pcuic" - # "template-pcuic" - # ]; + "quotation" = [ + "template-rocq" + "pcuic" + "template-pcuic" + ]; "safechecker-plugin" = [ "template-pcuic" "safechecker" @@ -52,7 +52,7 @@ let "safechecker-plugin" "erasure-plugin" "translations" - # "quotation" + "quotation" ]; }; @@ -111,7 +111,7 @@ let (lib.elem package [ "erasure" "template-pcuic" - # "quotation" + "quotation" "safechecker-plugin" "erasure-plugin" "translations" From e1a44a6efedea37f4772fb0df32ffba7f3d64de6 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 17 Nov 2025 14:55:25 +0100 Subject: [PATCH 161/164] Fix quotation --- common/theories/uGraph.v | 25 ++++++++++++ .../ToPCUIC/Common/EnvironmentTyping.v | 6 +-- quotation/theories/ToPCUIC/Common/Universes.v | 38 +++++++++---------- .../Universes/ConstraintSet/Instances.v | 4 +- .../ConstraintSetExtraDecide/Instances.v | 4 +- .../ConstraintSetExtraOrdProp/Instances.v | 4 +- .../ConstraintSetOrdProp/Instances.v | 4 +- .../PCUICAst/PCUICEnvironment/Instances.v | 2 +- .../ToTemplate/Common/EnvironmentTyping.v | 6 +-- .../theories/ToTemplate/Common/Universes.v | 31 ++++++++------- quotation/theories/ToTemplate/Init.v | 2 +- .../Universes/ConstraintSet/Instances.v | 4 +- .../ConstraintSetExtraDecide/Instances.v | 4 +- .../ConstraintSetExtraOrdProp/Instances.v | 4 +- .../ConstraintSetOrdProp/Instances.v | 4 +- .../QuotationOf/Template/Ast/Env/Instances.v | 4 +- .../Template/Ast/EnvHelper/Instances.v | 2 +- .../Template/Ast/TemplateLookup/Instances.v | 2 +- .../Ast/TemplateTermUtils/Instances.v | 2 +- .../Template/ReflectAst/EnvDecide/Instances.v | 2 +- .../Typing/TemplateConversion/Instances.v | 2 +- .../Typing/TemplateConversionPar/Instances.v | 2 +- .../TemplateDeclarationTyping/Instances.v | 2 +- .../Typing/TemplateEnvTyping/Instances.v | 2 +- .../Typing/TemplateGlobalMaps/Instances.v | 2 +- .../Typing/TemplateTyping/Instances.v | 2 +- quotation/theories/ToTemplate/Template/Ast.v | 2 +- .../theories/ToTemplate/Template/Typing.v | 2 +- 28 files changed, 96 insertions(+), 74 deletions(-) diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index e7e24f6b7..0b6af69a0 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -683,6 +683,31 @@ Section CheckLeq. End CheckerFlags. End CheckLeq. + +Definition satisfies_cstr v (c : UnivConstraint.t) : bool := + match c with + | (l, Eq, r) => val v l =? val v r + | (l, Le, r) => val v l <=? val v r + end. + +Definition satisfiesb v : UnivConstraintSet.t -> bool := + UnivConstraintSet.for_all (satisfies_cstr v). + +Lemma satisfies_dec {cf : checker_flags} ctrs v : + { satisfies v ctrs } + { ~ satisfies v ctrs }. +Proof. + rewrite /satisfies. + destruct (satisfiesb v ctrs) eqn:hsat. + - left. move:hsat => /UnivConstraintSet.for_all_spec ha c /ha. + destruct c as [[l []] r]; cbn in *. + + constructor; lia. + + constructor; lia. + - right. move=> ha. + move/negbT/negP: hsat; apply. + apply UnivConstraintSet.for_all_spec; tc. + move=> c /ha. intros []; cbn; lia. +Qed. + (* Lemma consistent_ext_on_full_ext0 `{cf: checker_flags} [uctx G uctx' G'] `{wGraph.invariants G, wGraph.invariants G', wGraph.acyclic_no_loop G'} : diff --git a/quotation/theories/ToPCUIC/Common/EnvironmentTyping.v b/quotation/theories/ToPCUIC/Common/EnvironmentTyping.v index b6b2fa73e..88a9ac4cf 100644 --- a/quotation/theories/ToPCUIC/Common/EnvironmentTyping.v +++ b/quotation/theories/ToPCUIC/Common/EnvironmentTyping.v @@ -132,8 +132,8 @@ Module QuoteGlobalMaps (Import T : Term) (Import E : EnvironmentSig T) (Import T #[export] Instance quote_satisfiable_udecl {univs ϕ} : ground_quotable (@satisfiable_udecl univs ϕ) := ltac:(cbv [satisfiable_udecl]; exact _). - #[export] Instance quote_valid_on_mono_udecl {univs ϕ} : ground_quotable (@valid_on_mono_udecl univs ϕ) - := ltac:(cbv [valid_on_mono_udecl]; exact _). + (* #[export] Instance quote_valid_on_mono_udecl {univs ϕ} : ground_quotable (@valid_on_mono_udecl univs ϕ) *) + (* := ltac:(cbv [valid_on_mono_udecl]; exact _). *) #[export] Instance quote_on_udecl {univs udecl} : ground_quotable (@on_udecl univs udecl) := ltac:(cbv [on_udecl]; exact _). @@ -171,7 +171,7 @@ Module QuoteGlobalMaps (Import T : Term) (Import E : EnvironmentSig T) (Import T quote_on_type_rel quote_on_udecl quote_satisfiable_udecl - quote_valid_on_mono_udecl + (* quote_valid_on_mono_udecl *) quote_positive_cstr_arg quote_positive_cstr quote_ind_respects_variance diff --git a/quotation/theories/ToPCUIC/Common/Universes.v b/quotation/theories/ToPCUIC/Common/Universes.v index 35308de7f..5b575e428 100644 --- a/quotation/theories/ToPCUIC/Common/Universes.v +++ b/quotation/theories/ToPCUIC/Common/Universes.v @@ -17,8 +17,8 @@ Module QuoteLevelSet := MSets.QuoteMSetAVL Level LevelSet LevelSetOrdProp LevelS Export (hints) QuoteLevelSet. Module QuoteLevelExprSet := MSets.QuoteMSetListWithLeibniz LevelExpr LevelExprSet LevelExprSetOrdProp LevelExprSetExtraOrdProp qLevelExpr qLevelExprSet qLevelExprSetOrdProp qLevelExprSetExtraOrdProp. Export (hints) QuoteLevelExprSet. -Module QuoteConstraintSet := MSets.QuoteMSetAVL UnivConstraint UnivConstraintSet UnivConstraintSetOrdProp UnivConstraintSetExtraOrdProp UnivConstraintSetExtraDecide qUnivConstraint qConstraintSet qConstraintSetOrdProp qConstraintSetExtraOrdProp qConstraintSetExtraDecide. -Export (hints) QuoteConstraintSet. +Module QuoteUnivConstraintSet := MSets.QuoteMSetAVL UnivConstraint UnivConstraintSet UnivConstraintSetOrdProp UnivConstraintSetExtraOrdProp UnivConstraintSetExtraDecide qUnivConstraint qUnivConstraintSet qUnivConstraintSetOrdProp qUnivConstraintSetExtraOrdProp qUnivConstraintSetExtraDecide. +Export (hints) QuoteUnivConstraintSet. Module QuoteUniverses1. Module Import Level. @@ -58,6 +58,7 @@ End QuoteUniverses1. Export (hints) QuoteUniverses1. #[export] Hint Unfold + LevelInstance.t Instance.t UContext.t AUContext.t @@ -67,12 +68,16 @@ Export (hints) QuoteUniverses1. : quotation. #[export] Typeclasses Transparent + LevelInstance.t Instance.t UContext.t AUContext.t ContextSet.t . +#[export] Instance quote_nonEmptyLevelExprSet : ground_quotable Universe.NES.t := ltac:(destruct 1; exact _). +#[export] Instance quote_Universe : ground_quotable Universe.t := ltac:(destruct 1; exact _). + Module QuoteUniverses2. Module Import Universe. #[export] Instance quote_t_ {univ} {quniv : quotation_of univ} {quote_univ : ground_quotable univ} : ground_quotable (Sort.t_ univ) := ltac:(destruct 1; exact _). @@ -83,12 +88,12 @@ Module QuoteUniverses2. End Universe. Export (hints) Universe. - Module Import ConstraintType. + Module Import UnivConstraintType. #[export] Instance quote_t_ : ground_quotable UnivConstraintType.ConstraintType.t_ := ltac:(destruct 1; exact _). #[export] Hint Unfold UnivConstraintType.ConstraintType.t : quotation. #[export] Typeclasses Transparent UnivConstraintType.ConstraintType.t. - End ConstraintType. - Export (hints) ConstraintType. + End UnivConstraintType. + Export (hints) UnivConstraintType. Module Import UnivConstraint. #[export] Hint Unfold UnivConstraint.t : quotation. @@ -106,9 +111,6 @@ Module QuoteUniverses2. End QuoteUniverses2. Export (hints) QuoteUniverses2. -#[export] Instance quote_nonEmptyLevelExprSet : ground_quotable nonEmptyLevelExprSet := ltac:(destruct 1; exact _). -#[export] Instance quote_Universe : ground_quotable Universe.t := ltac:(destruct 1; exact _). - #[export] Instance quote_concrete_sort : ground_quotable concrete_sort := ltac:(destruct 1; exact _). Import StrongerInstances. @@ -116,21 +118,17 @@ Import StrongerInstances. #[export] Instance quote_declared_cstr_levels {levels cstr} : ground_quotable (declared_univ_cstr_levels levels cstr) := ltac:(cbv [declared_univ_cstr_levels]; exact _). #[export] Instance quote_universes_decl : ground_quotable universes_decl := ltac:(destruct 1; exact _). -#[export] Instance quote_satisfies0 {v s} {qv : quotation_of v} : ground_quotable (@satisfies0 v s) - := ground_quotable_of_iff (iff_sym (@uGraph.gc_of_constraint_spec config.default_checker_flags v s)). #[export] Instance quote_satisfies {v s} {qv : quotation_of v} : ground_quotable (@satisfies v s) - := ground_quotable_of_iff (iff_sym (@uGraph.gc_of_constraints_spec config.default_checker_flags v s)). + := ground_quotable_of_dec (@uGraph.satisfies_dec config.default_checker_flags s v). #[export] Instance quote_consistent {ctrs} : ground_quotable (@consistent ctrs) := ground_quotable_of_dec (@consistent_dec ctrs). -#[export] Instance quote_consistent_extension_on {cs cstr} : ground_quotable (@consistent_extension_on cs cstr) - := ground_quotable_of_dec (@consistent_extension_on_dec cs cstr). -#[export] Instance quote_leq_universe_n {cf n ϕ u u'} : ground_quotable (@leq_universe_n cf (uGraph.Z_of_bool n) ϕ u u') - := ground_quotable_of_dec (@leq_universe_n_dec cf _ ϕ u u'). -#[export] Instance quote_leq_universe {cf ϕ s s'} : ground_quotable (@leq_universe cf ϕ s s') := @quote_leq_universe_n cf false ϕ s s'. -#[export] Instance quote_leq_sort_n_ {cf univ leq_universe_n n s s'} {quote_leq_universe_n : forall u u', ground_quotable (leq_universe_n n u u':Prop)} : ground_quotable (@leq_sort_n_ cf univ leq_universe_n n s s') := ltac:(cbv [leq_sort_n_]; exact _). -#[export] Instance quote_leq_csort_n {cf n s s'} : ground_quotable (@leq_csort_n cf n s s') := @quote_leq_sort_n_ cf nat _ n s s' _. -#[export] Instance quote_leq_sort_n {cf n ϕ s s'} : ground_quotable (@leq_sort_n cf (uGraph.Z_of_bool n) ϕ s s') := ltac:(cbv [leq_sort_n]; exact _). -#[export] Instance quote_leq_sort {cf ϕ s s'} : ground_quotable (@leq_sort cf ϕ s s') := @quote_leq_sort_n cf false ϕ s s'. +(* #[export] Instance quote_consistent_extension_on {cs cstr} : ground_quotable (@consistent_extension_on cs cstr) + := ground_quotable_of_dec (@consistent_extension_on_dec cs cstr). *) +#[export] Instance quote_leq_universe {cf ϕ u u'} : ground_quotable (@leq_universe cf ϕ u u') + := ground_quotable_of_dec (@leq_universe_dec cf ϕ u u'). +#[export] Instance quote_leq_sort_ {cf univ leq_universe s s'} {quote_leq_universe : forall u u', ground_quotable (leq_universe u u':Prop)} : ground_quotable (@leq_sort_ cf univ leq_universe s s') := ltac:(cbv [leq_sort_]; exact _). +#[export] Instance quote_leq_csort_ {cf s s'} : ground_quotable (@leq_csort cf s s') := @quote_leq_sort_ cf nat _ s s' _. +#[export] Instance quote_leq_sort {cf ϕ s s'} : ground_quotable (@leq_sort cf ϕ s s') := ltac:(cbv [leq_sort]; exact _). #[export] Instance quote_eq_universe {cf ϕ u u'} : ground_quotable (@eq_universe cf ϕ u u') := ground_quotable_of_dec (@eq_universe_dec cf ϕ u u'). #[export] Instance quote_eq_sort_ {univ eq_universe s s'} {quote_eq_universe : forall u u', ground_quotable (eq_universe u u':Prop)} : ground_quotable (@eq_sort_ univ eq_universe s s') := ltac:(cbv [eq_sort_]; exact _). diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSet/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSet/Instances.v index af747bf21..78977a888 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSet/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSet/Instances.v @@ -2,6 +2,6 @@ From MetaRocq.Common Require Import Universes. From MetaRocq.Quotation.ToPCUIC Require Import Init. From MetaRocq.Quotation.ToPCUIC.QuotationOf.Stdlib.MSets Require Import MSetAVL.Sig. -Module qConstraintSet <: MSetAVL.QuotationOfMake UnivConstraint UnivConstraintSet. +Module qUnivConstraintSet <: MSetAVL.QuotationOfMake UnivConstraint UnivConstraintSet. MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSet"). -End qConstraintSet. +End qUnivConstraintSet. diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v index 15ef43804..d85748a59 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v @@ -2,6 +2,6 @@ From MetaRocq.Common Require Import Universes. From MetaRocq.Quotation.ToPCUIC Require Import Init. From MetaRocq.Quotation.ToPCUIC.QuotationOf.Utils Require Import MRMSets.Sig. -Module qConstraintSetExtraDecide <: MSetAVL.QuotationOfDecide UnivConstraintSet.E UnivConstraintSet UnivConstraintSetExtraDecide. +Module qUnivConstraintSetExtraDecide <: MSetAVL.QuotationOfDecide UnivConstraintSet.E UnivConstraintSet UnivConstraintSetExtraDecide. MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetExtraDecide"). -End qConstraintSetExtraDecide. +End qUnivConstraintSetExtraDecide. diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v index 2c2ebd0a0..b4aab3568 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v @@ -4,9 +4,9 @@ From MetaRocq.Quotation.ToPCUIC.QuotationOf.Utils Require Import MRMSets.Sig. Import List.ListNotations. Local Open Scope list_scope. -Module qConstraintSetExtraOrdProp <: QuotationOfExtraOrdProperties UnivConstraintSet UnivConstraintSetOrdProp UnivConstraintSetExtraOrdProp. +Module qUnivConstraintSetExtraOrdProp <: QuotationOfExtraOrdProperties UnivConstraintSet UnivConstraintSetOrdProp UnivConstraintSetExtraOrdProp. Module qP <: QuotationOfWExtraPropertiesOn UnivConstraintSet.E UnivConstraintSet UnivConstraintSetOrdProp.P UnivConstraintSetExtraOrdProp.P. MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetExtraOrdProp.P"). End qP. MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["P"]]%bs) None "UnivConstraintSetExtraOrdProp"). -End qConstraintSetExtraOrdProp. +End qUnivConstraintSetExtraOrdProp. diff --git a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v index dd5383c20..f72570dd6 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v @@ -5,7 +5,7 @@ From MetaRocq.Quotation.ToPCUIC.QuotationOf.Stdlib.MSets Require Import MSetProp Import List.ListNotations. Local Open Scope list_scope. -Module qConstraintSetOrdProp <: QuotationOfOrdProperties UnivConstraintSet UnivConstraintSetOrdProp. +Module qUnivConstraintSetOrdProp <: QuotationOfOrdProperties UnivConstraintSet UnivConstraintSetOrdProp. Module qME <: QuotationOfOrderedTypeFacts UnivConstraintSet.E UnivConstraintSetOrdProp.ME. MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetOrdProp.ME"). End qME. @@ -22,4 +22,4 @@ Module qConstraintSetOrdProp <: QuotationOfOrdProperties UnivConstraintSet UnivC MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["Dec"]; ["FM"]]%bs) None "UnivConstraintSetOrdProp.P"). End qP. MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["ME"]; ["ML"]; ["P"]]%bs) None "UnivConstraintSetOrdProp"). -End qConstraintSetOrdProp. +End qUnivConstraintSetOrdProp. diff --git a/quotation/theories/ToPCUIC/QuotationOf/PCUIC/PCUICAst/PCUICEnvironment/Instances.v b/quotation/theories/ToPCUIC/QuotationOf/PCUIC/PCUICAst/PCUICEnvironment/Instances.v index aa0d7c48b..6af04bd47 100644 --- a/quotation/theories/ToPCUIC/QuotationOf/PCUIC/PCUICAst/PCUICEnvironment/Instances.v +++ b/quotation/theories/ToPCUIC/QuotationOf/PCUIC/PCUICAst/PCUICEnvironment/Instances.v @@ -1,6 +1,6 @@ -From MetaRocq.PCUIC Require Import PCUICAst. From MetaRocq.Quotation.ToPCUIC Require Import Init. From MetaRocq.Quotation.ToPCUIC.QuotationOf.Common Require Import Environment.Sig. +From MetaRocq.PCUIC Require Import PCUICAst. Module qPCUICEnvironment <: QuotationOfEnvironment PCUICTerm PCUICEnvironment. MetaRocq Run (tmMakeQuotationOfModule everything None "PCUICEnvironment"). diff --git a/quotation/theories/ToTemplate/Common/EnvironmentTyping.v b/quotation/theories/ToTemplate/Common/EnvironmentTyping.v index 91cecb40a..a1c5c8a9f 100644 --- a/quotation/theories/ToTemplate/Common/EnvironmentTyping.v +++ b/quotation/theories/ToTemplate/Common/EnvironmentTyping.v @@ -132,8 +132,8 @@ Module QuoteGlobalMaps (Import T : Term) (Import E : EnvironmentSig T) (Import T #[export] Instance quote_satisfiable_udecl {univs ϕ} : ground_quotable (@satisfiable_udecl univs ϕ) := ltac:(cbv [satisfiable_udecl]; exact _). - #[export] Instance quote_valid_on_mono_udecl {univs ϕ} : ground_quotable (@valid_on_mono_udecl univs ϕ) - := ltac:(cbv [valid_on_mono_udecl]; exact _). + (* #[export] Instance quote_valid_on_mono_udecl {univs ϕ} : ground_quotable (@valid_on_mono_udecl univs ϕ) *) + (* := ltac:(cbv [valid_on_mono_udecl]; exact _). *) #[export] Instance quote_on_udecl {univs udecl} : ground_quotable (@on_udecl univs udecl) := ltac:(cbv [on_udecl]; exact _). @@ -171,7 +171,7 @@ Module QuoteGlobalMaps (Import T : Term) (Import E : EnvironmentSig T) (Import T quote_on_type_rel quote_on_udecl quote_satisfiable_udecl - quote_valid_on_mono_udecl + (* quote_valid_on_mono_udecl *) quote_positive_cstr_arg quote_positive_cstr quote_ind_respects_variance diff --git a/quotation/theories/ToTemplate/Common/Universes.v b/quotation/theories/ToTemplate/Common/Universes.v index e8872dc5b..c4c9d4772 100644 --- a/quotation/theories/ToTemplate/Common/Universes.v +++ b/quotation/theories/ToTemplate/Common/Universes.v @@ -17,7 +17,7 @@ Module QuoteLevelSet := MSets.QuoteMSetAVL Level LevelSet LevelSetOrdProp LevelS Export (hints) QuoteLevelSet. Module QuoteLevelExprSet := MSets.QuoteMSetListWithLeibniz LevelExpr LevelExprSet LevelExprSetOrdProp LevelExprSetExtraOrdProp qLevelExpr qLevelExprSet qLevelExprSetOrdProp qLevelExprSetExtraOrdProp. Export (hints) QuoteLevelExprSet. -Module QuoteConstraintSet := MSets.QuoteMSetAVL UnivConstraint UnivConstraintSet UnivConstraintSetOrdProp UnivConstraintSetExtraOrdProp UnivConstraintSetExtraDecide qUnivConstraint qConstraintSet qConstraintSetOrdProp qConstraintSetExtraOrdProp qConstraintSetExtraDecide. +Module QuoteUnivConstraintSet := MSets.QuoteMSetAVL UnivConstraint UnivConstraintSet UnivConstraintSetOrdProp UnivConstraintSetExtraOrdProp UnivConstraintSetExtraDecide qUnivConstraint qUnivConstraintSet qUnivConstraintSetOrdProp qUnivConstraintSetExtraOrdProp qUnivConstraintSetExtraDecide. Export (hints) QuoteUnivConstraintSet. Module QuoteUniverses1. @@ -58,7 +58,7 @@ End QuoteUniverses1. Export (hints) QuoteUniverses1. #[export] Hint Unfold - Instance.t + LevelInstance.t UContext.t AUContext.t ContextSet.t @@ -67,6 +67,7 @@ Export (hints) QuoteUniverses1. : quotation. #[export] Typeclasses Transparent + LevelInstance.t Instance.t UContext.t AUContext.t @@ -103,7 +104,7 @@ Module QuoteUniverses2. End QuoteUniverses2. Export (hints) QuoteUniverses2. -#[export] Instance quote_nonEmptyLevelExprSet : ground_quotable nonEmptyLevelExprSet := ltac:(destruct 1; exact _). +#[export] Instance quote_Universe_NES : ground_quotable Universe.NES.t := ltac:(destruct 1; exact _). #[export] Instance quote_Universe : ground_quotable Universe.t := ltac:(destruct 1; exact _). #[export] Instance quote_concrete_sort : ground_quotable concrete_sort := ltac:(destruct 1; exact _). @@ -113,21 +114,19 @@ Import StrongerInstances. #[export] Instance quote_declared_cstr_levels {levels cstr} : ground_quotable (declared_univ_cstr_levels levels cstr) := ltac:(cbv [declared_univ_cstr_levels]; exact _). #[export] Instance quote_universes_decl : ground_quotable universes_decl := ltac:(destruct 1; exact _). -#[export] Instance quote_satisfies0 {v s} {qv : quotation_of v} : ground_quotable (@satisfies0 v s) - := ground_quotable_of_iff (iff_sym (@uGraph.gc_of_constraint_spec config.default_checker_flags v s)). +(* #[export] Instance quote_satisfies0 {v s} {qv : quotation_of v} : ground_quotable (@satisfies0 v s) *) + (* := ground_quotable_of_iff (iff_sym (@uGraph.gc_of_constraint_spec config.default_checker_flags v s)). *) #[export] Instance quote_satisfies {v s} {qv : quotation_of v} : ground_quotable (@satisfies v s) - := ground_quotable_of_iff (iff_sym (@uGraph.gc_of_constraints_spec config.default_checker_flags v s)). + := ground_quotable_of_dec (@uGraph.satisfies_dec config.default_checker_flags s v). #[export] Instance quote_consistent {ctrs} : ground_quotable (@consistent ctrs) := ground_quotable_of_dec (@consistent_dec ctrs). -#[export] Instance quote_consistent_extension_on {cs cstr} : ground_quotable (@consistent_extension_on cs cstr) - := ground_quotable_of_dec (@consistent_extension_on_dec cs cstr). -#[export] Instance quote_leq_universe_n {cf n ϕ u u'} : ground_quotable (@leq_universe_n cf (uGraph.Z_of_bool n) ϕ u u') - := ground_quotable_of_dec (@leq_universe_n_dec cf _ ϕ u u'). -#[export] Instance quote_leq_universe {cf ϕ s s'} : ground_quotable (@leq_universe cf ϕ s s') := @quote_leq_universe_n cf false ϕ s s'. -#[export] Instance quote_leq_sort_n_ {cf univ leq_universe_n n s s'} {quote_leq_universe_n : forall u u', ground_quotable (leq_universe_n n u u':Prop)} : ground_quotable (@leq_sort_n_ cf univ leq_universe_n n s s') := ltac:(cbv [leq_sort_n_]; exact _). -#[export] Instance quote_leq_csort_n {cf n s s'} : ground_quotable (@leq_csort_n cf n s s') := @quote_leq_sort_n_ cf nat _ n s s' _. -#[export] Instance quote_leq_sort_n {cf n ϕ s s'} : ground_quotable (@leq_sort_n cf (uGraph.Z_of_bool n) ϕ s s') := ltac:(cbv [leq_sort_n]; exact _). -#[export] Instance quote_leq_sort {cf ϕ s s'} : ground_quotable (@leq_sort cf ϕ s s') := @quote_leq_sort_n cf false ϕ s s'. +(* #[export] Instance quote_consistent_extension_on {cs cstr} : ground_quotable (@consistent_extension_on cs cstr) *) + (* := ground_quotable_of_dec (@consistent_extension_on_dec cs cstr). *) +#[export] Instance quote_leq_universe {cf ϕ u u'} : ground_quotable (@leq_universe cf ϕ u u') + := ground_quotable_of_dec (@leq_universe_dec cf ϕ u u'). +#[export] Instance quote_leq_sort_ {cf univ leq_universe s s'} {quote_leq_universe : forall u u', ground_quotable (leq_universe u u':Prop)} : ground_quotable (@leq_sort_ cf univ leq_universe s s') := ltac:(cbv [leq_sort_]; exact _). +#[export] Instance quote_leq_csort_ {cf s s'} : ground_quotable (@leq_csort cf s s') := @quote_leq_sort_ cf nat _ s s' _. +#[export] Instance quote_leq_sort {cf ϕ s s'} : ground_quotable (@leq_sort cf ϕ s s') := ltac:(cbv [leq_sort]; exact _). #[export] Instance quote_eq_universe {cf ϕ u u'} : ground_quotable (@eq_universe cf ϕ u u') := ground_quotable_of_dec (@eq_universe_dec cf ϕ u u'). #[export] Instance quote_eq_sort_ {univ eq_universe s s'} {quote_eq_universe : forall u u', ground_quotable (eq_universe u u':Prop)} : ground_quotable (@eq_sort_ univ eq_universe s s') := ltac:(cbv [eq_sort_]; exact _). @@ -142,4 +141,4 @@ Import StrongerInstances. #[export] Instance quote_is_allowed_elimination {cf ϕ allowed u} : ground_quotable (@is_allowed_elimination cf ϕ allowed u) := ground_quotable_of_dec (@is_allowed_elimination_dec cf ϕ allowed u). -#[export] Instance quote_universes_entry : ground_quotable universes_entry := ltac:(destruct 1; exact _). +#[export] Instance quote_universes_entry : ground_quotable universes_entry := ltac:(destruct 1; exact _). \ No newline at end of file diff --git a/quotation/theories/ToTemplate/Init.v b/quotation/theories/ToTemplate/Init.v index ab039b338..a65390614 100644 --- a/quotation/theories/ToTemplate/Init.v +++ b/quotation/theories/ToTemplate/Init.v @@ -1,12 +1,12 @@ From MetaRocq.Utils Require Export bytestring. From MetaRocq.Utils Require Import utils MRList. From MetaRocq.Common Require Import MonadBasicAst. -From MetaRocq.Template Require Import MonadAst TemplateMonad Ast Loader. From MetaRocq.Quotation Require Export CommonUtils. From Equations.Prop Require Import Classes. From Stdlib Require Import Lists.List. Export TemplateMonad.Common (export, local, global). Import ListNotations. +From MetaRocq.Template Require Import MonadAst TemplateMonad Ast Loader. Local Set Primitive Projections. Local Unset Universe Minimization ToSet. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v index 866d4f662..66866959f 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v @@ -2,6 +2,6 @@ From MetaRocq.Common Require Import Universes. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Stdlib.MSets Require Import MSetAVL.Sig. -Module qConstraintSet <: MSetAVL.QuotationOfMake UnivConstraint UnivConstraintSet. +Module qUnivConstraintSet <: MSetAVL.QuotationOfMake UnivConstraint UnivConstraintSet. MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSet"). -End qConstraintSet. +End qUnivConstraintSet. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v index 6df03fa4f..f92f679f8 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraDecide/Instances.v @@ -2,6 +2,6 @@ From MetaRocq.Common Require Import Universes. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Utils Require Import MRMSets.Sig. -Module qConstraintSetExtraDecide <: MSetAVL.QuotationOfDecide UnivConstraintSet.E UnivConstraintSet UnivConstraintSetExtraDecide. +Module qUnivConstraintSetExtraDecide <: MSetAVL.QuotationOfDecide UnivConstraintSet.E UnivConstraintSet UnivConstraintSetExtraDecide. MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetExtraDecide"). -End qConstraintSetExtraDecide. +End qUnivConstraintSetExtraDecide. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v index 52c4a6bf6..618c927f3 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetExtraOrdProp/Instances.v @@ -4,9 +4,9 @@ From MetaRocq.Quotation.ToTemplate.QuotationOf.Utils Require Import MRMSets.Sig. Import List.ListNotations. Local Open Scope list_scope. -Module qConstraintSetExtraOrdProp <: QuotationOfExtraOrdProperties UnivConstraintSet UnivConstraintSetOrdProp UnivConstraintSetExtraOrdProp. +Module qUnivConstraintSetExtraOrdProp <: QuotationOfExtraOrdProperties UnivConstraintSet UnivConstraintSetOrdProp UnivConstraintSetExtraOrdProp. Module qP <: QuotationOfWExtraPropertiesOn UnivConstraintSet.E UnivConstraintSet UnivConstraintSetOrdProp.P UnivConstraintSetExtraOrdProp.P. MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetExtraOrdProp.P"). End qP. MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["P"]]%bs) None "UnivConstraintSetExtraOrdProp"). -End qConstraintSetExtraOrdProp. +End qUnivConstraintSetExtraOrdProp. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v index 72c228617..e11afc93f 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v @@ -5,7 +5,7 @@ From MetaRocq.Quotation.ToTemplate.QuotationOf.Stdlib.MSets Require Import MSetP Import List.ListNotations. Local Open Scope list_scope. -Module qConstraintSetOrdProp <: QuotationOfOrdProperties UnivConstraintSet UnivConstraintSetOrdProp. +Module qUnivConstraintSetOrdProp <: QuotationOfOrdProperties UnivConstraintSet UnivConstraintSetOrdProp. Module qME <: QuotationOfOrderedTypeFacts UnivConstraintSet.E UnivConstraintSetOrdProp.ME. MetaRocq Run (tmMakeQuotationOfModule everything None "UnivConstraintSetOrdProp.ME"). End qME. @@ -22,4 +22,4 @@ Module qConstraintSetOrdProp <: QuotationOfOrdProperties UnivConstraintSet UnivC MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["Dec"]; ["FM"]]%bs) None "UnivConstraintSetOrdProp.P"). End qP. MetaRocq Run (tmMakeQuotationOfModule (all_submodules_except [["ME"]; ["ML"]; ["P"]]%bs) None "UnivConstraintSetOrdProp"). -End qConstraintSetOrdProp. +End qUnivConstraintSetOrdProp. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/Env/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/Env/Instances.v index 08b7ca9de..bfc8a70f9 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/Env/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/Env/Instances.v @@ -1,7 +1,7 @@ -From MetaRocq.Template Require Import Ast. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Common Require Import Environment.Sig. -About Env. +From MetaRocq.Template Require Import Ast. + Module qEnv <: QuotationOfEnvironment TemplateTerm Env. MetaRocq Run (tmMakeQuotationOfModule everything None "Env"). End qEnv. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/EnvHelper/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/EnvHelper/Instances.v index 49935bab7..b3be63f67 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/EnvHelper/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/EnvHelper/Instances.v @@ -1,6 +1,6 @@ -From MetaRocq.Template Require Import Ast. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.Common Require Import Environment. +From MetaRocq.Template Require Import Ast. Module QuoteEnvHelper <: QuoteEnvironmentHelperSig TemplateTerm Env := QuoteEnvironmentHelper TemplateTerm Env. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateLookup/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateLookup/Instances.v index 891e70da4..99a249133 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateLookup/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateLookup/Instances.v @@ -1,6 +1,6 @@ -From MetaRocq.Template Require Import Ast. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. +From MetaRocq.Template Require Import Ast. Module qTemplateLookup <: QuotationOfLookup TemplateTerm Env TemplateLookup. MetaRocq Run (tmMakeQuotationOfModule everything None "TemplateLookup"). diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateTermUtils/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateTermUtils/Instances.v index 088864a12..bc95f5472 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateTermUtils/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateTermUtils/Instances.v @@ -1,6 +1,6 @@ -From MetaRocq.Template Require Import Ast. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Common Require Import Environment.Sig. +From MetaRocq.Template Require Import Ast. Module qTemplateTermUtils <: QuotationOfTermUtils TemplateTerm Env TemplateTermUtils. MetaRocq Run (tmMakeQuotationOfModule everything None "TemplateTermUtils"). diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/EnvDecide/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/EnvDecide/Instances.v index adf2cfb4d..9a2ab78fe 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/EnvDecide/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/EnvDecide/Instances.v @@ -1,6 +1,6 @@ -From MetaRocq.Template Require Import Ast ReflectAst. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Common Require Import Environment.Sig. +From MetaRocq.Template Require Import Ast ReflectAst. Module qEnvDecide <: QuotationOfEnvironmentDecide TemplateTerm Env EnvDecide. MetaRocq Run (tmMakeQuotationOfModule everything None "EnvDecide"). diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversion/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversion/Instances.v index 55dcde503..cf95297d2 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversion/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversion/Instances.v @@ -1,6 +1,6 @@ -From MetaRocq.Template Require Import Ast Typing. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. +From MetaRocq.Template Require Import Ast Typing. Module qTemplateConversion <: QuotationOfConversion TemplateTerm Env TemplateTermUtils TemplateEnvTyping TemplateConversion. MetaRocq Run (tmMakeQuotationOfModule everything None "TemplateConversion"). diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversionPar/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversionPar/Instances.v index 840ba071a..c64e0a501 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversionPar/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversionPar/Instances.v @@ -1,6 +1,6 @@ -From MetaRocq.Template Require Import Ast Typing. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. +From MetaRocq.Template Require Import Ast Typing. Module qTemplateConversionPar <: QuotationOfConversionPar TemplateTerm Env TemplateTermUtils TemplateEnvTyping TemplateConversionPar. MetaRocq Run (tmMakeQuotationOfModule everything None "TemplateConversionPar"). diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateDeclarationTyping/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateDeclarationTyping/Instances.v index 3673b70c8..d1480ce13 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateDeclarationTyping/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateDeclarationTyping/Instances.v @@ -1,6 +1,6 @@ -From MetaRocq.Template Require Import Ast Typing. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. +From MetaRocq.Template Require Import Ast Typing. Module qTemplateDeclarationTyping <: QuotationOfDeclarationTyping TemplateTerm Env TemplateTermUtils TemplateEnvTyping TemplateConversion TemplateConversionPar TemplateTyping TemplateLookup TemplateGlobalMaps TemplateDeclarationTyping. MetaRocq Run (tmMakeQuotationOfModule everything None "TemplateDeclarationTyping"). diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateEnvTyping/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateEnvTyping/Instances.v index 651485492..eafd27b3d 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateEnvTyping/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateEnvTyping/Instances.v @@ -1,6 +1,6 @@ -From MetaRocq.Template Require Import Ast Typing. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. +From MetaRocq.Template Require Import Ast Typing. Module qTemplateEnvTyping <: QuotationOfEnvTyping TemplateTerm Env TemplateTermUtils TemplateEnvTyping. MetaRocq Run (tmMakeQuotationOfModule everything None "TemplateEnvTyping"). diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateGlobalMaps/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateGlobalMaps/Instances.v index 267dff22c..599f052c8 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateGlobalMaps/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateGlobalMaps/Instances.v @@ -1,6 +1,6 @@ -From MetaRocq.Template Require Import Ast Typing. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. +From MetaRocq.Template Require Import Ast Typing. Module qTemplateGlobalMaps <: QuotationOfGlobalMaps TemplateTerm Env TemplateTermUtils TemplateEnvTyping TemplateConversion TemplateLookup TemplateGlobalMaps. MetaRocq Run (tmMakeQuotationOfModule everything None "TemplateGlobalMaps"). diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateTyping/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateTyping/Instances.v index 76b655e09..fb705ddeb 100644 --- a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateTyping/Instances.v +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateTyping/Instances.v @@ -1,6 +1,6 @@ -From MetaRocq.Template Require Import Ast Typing. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. +From MetaRocq.Template Require Import Ast Typing. Module qTemplateTyping <: QuotationOfTyping TemplateTerm Env TemplateTermUtils TemplateEnvTyping TemplateConversion TemplateConversionPar TemplateTyping. MetaRocq Run (tmMakeQuotationOfModule everything None "TemplateTyping"). diff --git a/quotation/theories/ToTemplate/Template/Ast.v b/quotation/theories/ToTemplate/Template/Ast.v index a349dbd74..dc228506e 100644 --- a/quotation/theories/ToTemplate/Template/Ast.v +++ b/quotation/theories/ToTemplate/Template/Ast.v @@ -1,10 +1,10 @@ -From MetaRocq.Template Require Import Ast ReflectAst Induction. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate Require Import (hints) Stdlib.Init Stdlib.Lists Stdlib.Numbers Stdlib.Floats. From MetaRocq.Quotation.ToTemplate.Common Require Import (hints) Universes BasicAst Kernames. From MetaRocq.Quotation.ToTemplate.Common Require Import Environment EnvironmentTyping. From MetaRocq.Quotation.ToTemplate.QuotationOf.Common Require Import Environment.Sig EnvironmentTyping.Sig. From MetaRocq.Quotation.ToTemplate.QuotationOf.Template Require Import Ast.Instances ReflectAst.Instances. +From MetaRocq.Template Require Import Ast ReflectAst Induction. #[export] Instance quote_pstring : ground_quotable PrimString.string := fun s => Ast.tString s. diff --git a/quotation/theories/ToTemplate/Template/Typing.v b/quotation/theories/ToTemplate/Template/Typing.v index b6afcab4c..348f70f76 100644 --- a/quotation/theories/ToTemplate/Template/Typing.v +++ b/quotation/theories/ToTemplate/Template/Typing.v @@ -1,4 +1,3 @@ -From MetaRocq.Template Require Import Ast Typing. From MetaRocq.Quotation.ToTemplate Require Import Init. From MetaRocq.Quotation.ToTemplate Require Import (hints) Stdlib.Init Stdlib.Lists Stdlib.Numbers Stdlib.Floats. From MetaRocq.Quotation.ToTemplate.Utils Require Import (hints) utils All_Forall (* MRProd*). @@ -9,6 +8,7 @@ From MetaRocq.Quotation.ToTemplate.Common Require Import Environment Environment From MetaRocq.Quotation.ToTemplate.Template Require Import Ast. From MetaRocq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. From MetaRocq.Quotation.ToTemplate.QuotationOf.Template Require Import Ast.Instances Typing.Instances. +From MetaRocq.Template Require Import Ast Typing. #[export] Instance quote_instantiate_params_subst_spec {params pars s pty s' pty'} : ground_quotable (@instantiate_params_subst_spec params pars s pty s' pty'). Proof. From 360a696d4a13987a61eccd89420bed286155d7bd Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 17 Nov 2025 14:59:22 +0100 Subject: [PATCH 162/164] Restore build of quotation component --- Makefile | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/Makefile b/Makefile index ecbc42112..3c56fa4cc 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ -all: printconf template-rocq pcuic safechecker erasure erasure-plugin safechecker-plugin +all: printconf template-rocq pcuic safechecker erasure erasure-plugin safechecker-plugin quotation -include Makefile.conf @@ -33,7 +33,7 @@ install: all $(MAKE) -C pcuic install $(MAKE) -C safechecker install $(MAKE) -C template-pcuic install -# $(MAKE) -C quotation install + $(MAKE) -C quotation install $(MAKE) -C safechecker-plugin install $(MAKE) -C erasure install $(MAKE) -C erasure-plugin install @@ -45,7 +45,7 @@ uninstall: $(MAKE) -C pcuic uninstall $(MAKE) -C safechecker uninstall $(MAKE) -C template-pcuic uninstall -# $(MAKE) -C quotation uninstall + $(MAKE) -C quotation uninstall $(MAKE) -C safechecker-plugin uninstall $(MAKE) -C erasure uninstall $(MAKE) -C erasure-plugin uninstall @@ -65,6 +65,7 @@ html: all -R safechecker-plugin/theories MetaRocq.SafeCheckerPlugin \ -R erasure/theories MetaRocq.Erasure \ -R erasure-plugin/theories MetaRocq.ErasurePlugin \ + -R quotation/theories MetaRocq.Quotation \ -R translations MetaRocq.Translations \ -R examples MetaRocq.Examples \ -d html */theories/*.v */theories/*/*.v translations/*.v examples/*.v @@ -79,7 +80,7 @@ clean: $(MAKE) -C safechecker clean $(MAKE) -C safechecker-plugin clean $(MAKE) -C template-pcuic clean -# $(MAKE) -C quotation clean + $(MAKE) -C quotation clean $(MAKE) -C erasure clean $(MAKE) -C erasure-plugin clean $(MAKE) -C examples clean @@ -94,7 +95,7 @@ vos: $(MAKE) -C safechecker vos $(MAKE) -C safechecker-plugin vos $(MAKE) -C template-pcuic vos -# $(MAKE) -C quotation vos + $(MAKE) -C quotation vos $(MAKE) -C erasure vos $(MAKE) -C erasure-plugin vos $(MAKE) -C translations vos @@ -107,7 +108,7 @@ quick: $(MAKE) -C safechecker quick $(MAKE) -C safechecker-plugin quick $(MAKE) -C template-pcuic quick -# $(MAKE) -C quotation vos # quick # we cannot unset universe checking in 8.16 due to COQBUG(https://github.com/coq/coq/issues/17361), and quick does not buy much in quotation anyway, where almost everything is transparent + $(MAKE) -C quotation vos # quick # we cannot unset universe checking in 8.16 due to COQBUG(https://github.com/coq/coq/issues/17361), and quick does not buy much in quotation anyway, where almost everything is transparent $(MAKE) -C erasure quick $(MAKE) -C erasure-plugin quick $(MAKE) -C translations quick @@ -120,7 +121,7 @@ mrproper: $(MAKE) -C safechecker mrproper $(MAKE) -C safechecker-plugin mrproper $(MAKE) -C template-pcuic mrproper -# $(MAKE) -C quotation mrproper + $(MAKE) -C quotation mrproper $(MAKE) -C erasure mrproper $(MAKE) -C erasure-plugin mrproper $(MAKE) -C examples mrproper @@ -135,7 +136,7 @@ mrproper: $(MAKE) -C safechecker .merlin $(MAKE) -C safechecker-plugin .merlin $(MAKE) -C template-pcuic .merlin -# $(MAKE) -C quotation .merlin + $(MAKE) -C quotation .merlin $(MAKE) -C erasure .merlin $(MAKE) -C erasure-plugin .merlin @@ -157,8 +158,8 @@ safechecker: pcuic template-pcuic: template-rocq pcuic $(MAKE) -C template-pcuic -# quotation: template-rocq pcuic template-pcuic -# $(MAKE) -C quotation +quotation: template-rocq pcuic template-pcuic + $(MAKE) -C quotation safechecker-plugin: safechecker template-pcuic $(MAKE) -C safechecker-plugin @@ -206,9 +207,7 @@ ci-quick: ci-opam: # Use -v so that regular output is produced - rm -f rocq-metarocq-quotation.opam - opam pin add -y . - opam install --with-test -v -y rocq-metarocq + opam install --with-test -v -y . opam remove -y rocq-metarocq rocq-metarocq-template checktodos: From d9109d2eef126054fcc2a81ce2fe9990078fab1e Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 17 Nov 2025 16:27:07 +0100 Subject: [PATCH 163/164] Add an example universe file --- common/theories/uGraph.v | 33 ---------------------- examples/universes.v | 61 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 61 insertions(+), 33 deletions(-) create mode 100644 examples/universes.v diff --git a/common/theories/uGraph.v b/common/theories/uGraph.v index 0b6af69a0..e9b58923f 100644 --- a/common/theories/uGraph.v +++ b/common/theories/uGraph.v @@ -84,39 +84,6 @@ Definition constraints_of_list (l : list UnivConstraint.t) : UnivConstraintSet.t Import MRMonadNotation. -Declare Scope cstr_scope. -Delimit Scope cstr_scope with cstr. -Bind Scope cstr_scope with UnivConstraint.t. -Notation " x <= y " := (@pair (Universe.t * UnivConstraintType.ConstraintType.t) Universe.t - (@pair Universe.t _ x Le) y) : cstr_scope. - -Definition of_level (l : Level.t_) : Universe.t := Universe.of_level l. -Coercion of_level : Level.t_ >-> Universe.t. -Coercion Universe.of_level : Level.t >-> Universe.t. - -Definition test_model : option universe_model := - let la := Level.level "a" in - let lb := Level.level "b" in - let lc := Level.level "c" in - let ls := levels_of_list [la; lb; lc] in - let cs := constraints_of_list [la <= lb; lb <= lc]%cstr in - push_uctx init_model (ls, cs). - -Lemma test_model_spec : (if test_model is Some _ then true else false) = true. -Proof. - reflexivity. -Qed. -Search UnivLoopChecking.univ_model. -Definition check_model c := - match test_model with - | Some m => check m c - | None => false - end. - -Example check_model_impl : check_model (Level.level "a" <= Level.level "b")%cstr = true := eq_refl. -Example check_model_impl_trans : check_model (Level.level "a" <= Level.level "c")%cstr = true := eq_refl. -Example check_model_nimpl : check_model (Level.level "b" <= Level.level "a")%cstr = false := eq_refl. - Import UnivLoopChecking. (** ** Check of consistency ** *) diff --git a/examples/universes.v b/examples/universes.v new file mode 100644 index 000000000..e0bd4dade --- /dev/null +++ b/examples/universes.v @@ -0,0 +1,61 @@ +From Stdlib Require Import ssreflect ssrfun ssrbool. +From MetaRocq.Utils Require Import utils. +From MetaRocq.Common Require Import UnivConstraintType Universes UnivLoopChecking uGraph. +Declare Scope univ_scope. +Delimit Scope univ_scope with univ. +Bind Scope univ_scope with Universe.t. + +Declare Scope cstr_scope. +Delimit Scope cstr_scope with cstr. +Bind Scope cstr_scope with UnivConstraint.t. +Import ConstraintType. + +Notation " x ≤ y " := (@pair (Universe.t * UnivConstraintType.ConstraintType.t) Universe.t + (@pair Universe.t _ x%univ Le) y%univ) (at level 70) : cstr_scope. +Notation " x = y " := (@pair (Universe.t * UnivConstraintType.ConstraintType.t) Universe.t + (@pair Universe.t _ x%univ Eq) y%univ) (at level 70) : cstr_scope. + +Definition of_level (l : Level.t_) : Universe.t := Universe.of_level l. +Coercion of_level : Level.t_ >-> Universe.t. +(* Coercion Universe.of_level : Level.t >-> Universe.t. *) + +Coercion Level.level : string >-> Level.t_. + +Definition makel (l : Level.t) (n : nat) : Universe.t := Universe.make (l, n). + +Notation " l + k " := (Universe.make (Level.level l, k)). + +Notation "x ⊔ y" := (Universe.union x y) (at level 60) : univ_scope. + + +Definition test_model : option universe_model := + let la := Level.level "a" in + let lb := Level.level "b" in + let lc := Level.level "c" in + let ls := levels_of_list [la; lb; lc] in + let cs := constraints_of_list ["a" + 1 ≤ lb; lb ≤ la ⊔ lc]%cstr in + push_uctx init_model (ls, cs). + +Lemma test_model_spec : (if test_model is Some _ then true else false) = true. +Proof. + reflexivity. +Qed. + +Import UnivLoopChecking.LoopCheck. + +Definition check_model c := + match test_model with + | Some m => checkb m c + | None => false + end. + +Check eq_refl : check_model ("a" ≤ "b"). +Check eq_refl : check_model ("b" ≤ "c"). +Check eq_refl : check_model ("a" + 1 ≤ "c"). +Check eq_refl : check_model ("a" + 2 ≤ "c") = false. +Check eq_refl : check_model (("b" + 1) ≤ "a") = false. +Check eq_refl : check_model (("b" + 1) ≤ "a") = false. +Check eq_refl : check_model ("a" ⊔ "b" ≤ "b" + 1). +Check eq_refl : check_model ("a" ⊔ "a" + 1 = "a" + 1). +Check eq_refl : check_model ("a" ⊔ "a" + 1 = "a") = false. +Check eq_refl : check_model ("a" ≤ "a" ⊔ "b" ⊔ "b" + 1). \ No newline at end of file From a8faa937fa192fcb86b97bffb2f4122158af4ef7 Mon Sep 17 00:00:00 2001 From: Matthieu Sozeau Date: Mon, 17 Nov 2025 16:27:42 +0100 Subject: [PATCH 164/164] Add universes.v to examples --- examples/_RocqProject.in | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/examples/_RocqProject.in b/examples/_RocqProject.in index 01d700b97..02e3003c0 100644 --- a/examples/_RocqProject.in +++ b/examples/_RocqProject.in @@ -6,4 +6,5 @@ add_constructor.v tauto.v # typing_correctness.v metarocq_tour_prelude.v -metarocq_tour.v \ No newline at end of file +metarocq_tour.v +universes.v \ No newline at end of file